; ACL2 Version 6.3 -- A Computational Logic for Applicative Common Lisp
; Copyright (C) 2013, 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 78701 U.S.A.

(in-package "ACL2")

;  We permit macros under the following constraints on the args.

;  1.  No destructuring.  (Maybe some day.)
;  2.  No &aux.           (LET* is better.)
;  3.  Initforms must be quotes.  (Too hard for us to do evaluation right.)
;  4.  No &environment.   (Just not clearly enough specified in CLTL.)
;  5.  No nonstandard lambda-keywords.  (Of course.)
;  6.  No multiple uses of :allow-other-keys.  (Implementations differ.)

;  There are three nests of functions that have the same view of
;  the subset of macro args that we support:  macro-vars...,
;  chk-macro-arglist..., and bind-macro-args...  Of course, it is
;  necessary to keep them all with the same view of the subset.

; The following code is a ``pseudo'' translation of the functions between
; chk-legal-init-msg and chk-macro-arglist.  Those checkers cause errors when
; their requirements are violated and these functions are just predicates.
; However, they are ``pseudo'' translations because they do not check, for
; example, that alleged variable symbols really are legal variable symbols.
; They are used in the guards for the functions leading up to and including
; macro-vars, which recovers all the variable symbols used in the formals list
; of an acceptable defmacro.

(defun legal-initp (x)
  (and (consp x)
       (true-listp x)
       (equal 2 (length x))
       (eq (car x) 'quote)))

; The following function is just the negation of chk-macro-arglist-keysp, when
; applied to a true-listp args.  The reason it must be applied to a true-listp
; is that macro-arglist-keysp terminates on an endp test and its counterpart
; checker terminates on a null test and may recur one additional time on
; non-true-lists.

(defun macro-arglist-keysp (args keys-passed)
  (declare (xargs :guard (and (true-listp args)
                              (true-listp keys-passed))))
  (cond ((endp args) t)
        ((eq (car args) '&allow-other-keys)
         (null (cdr args)))
        ((atom (car args))
         (cond ((symbolp (car args))
                (let ((new (intern (symbol-name (car args)) "KEYWORD")))
                  (and (not (member new keys-passed))
                       (macro-arglist-keysp (cdr args)
                                            (cons new keys-passed)))))
               (t nil)))
        ((or (not (true-listp (car args)))
             (> (length (car args)) 3))
         nil)
        (t (and (or (symbolp (caar args))
                    (and (true-listp (caar args))
                         (equal (length (caar args)) 2)
                         (keywordp (car (caar args)))
                         (symbolp (cadr (caar args)))))
                (implies (> (length (car args)) 1)
                         (legal-initp (cadr (car args))))
                (implies (> (length (car args)) 2)
                         (symbolp (caddr (car args))))
                (let ((new (cond ((symbolp (caar args))
                                  (intern (symbol-name (caar args))
                                          "KEYWORD"))
                                 (t (car (caar args))))))
                  (and (not (member new keys-passed))
                       (macro-arglist-keysp (cdr args)
                                            (cons new keys-passed))))))))

(defun macro-arglist-after-restp (args)
  (declare (xargs :guard (true-listp args)))
  (cond ((endp args) t)
        ((eq (car args) '&key)
         (macro-arglist-keysp (cdr args) nil))
        (t nil)))

(defun macro-arglist-optionalp (args)
  (declare (xargs :guard (true-listp args)))
  (cond ((endp args) t)
        ((member (car args) '(&rest &body))
         (cond ((and (cdr args)
                     (symbolp (cadr args))
                     (not (lambda-keywordp (cadr args))))
                (macro-arglist-after-restp (cddr args)))
               (t nil)))
        ((eq (car args) '&key)
         (macro-arglist-keysp (cdr args) nil))
        ((symbolp (car args))
         (macro-arglist-optionalp (cdr args)))
        ((or (atom (car args))
             (not (true-listp (car args)))
             (not (< (length (car args)) 4)))
         nil)
        ((not (symbolp (car (car args))))
         nil)
        ((and (> (length (car args)) 1)
              (not (legal-initp (cadr (car args)))))
         nil)
        ((and (equal (length (car args)) 3)
              (not (symbolp (caddr (car args)))))
         nil)
        (t (macro-arglist-optionalp (cdr args)))))

(defun macro-arglist1p (args)
  (declare (xargs :guard (true-listp args)))
  (cond ((endp args) t)
        ((not (symbolp (car args)))
         nil)
        ((member (car args) '(&rest &body))
         (cond ((and (cdr args)
                     (symbolp (cadr args))
                     (not (lambda-keywordp (cadr args))))
                (macro-arglist-after-restp (cddr args)))
               (t nil)))
        ((eq (car args) '&optional)
         (macro-arglist-optionalp (cdr args)))
        ((eq (car args) '&key)
         (macro-arglist-keysp (cdr args) nil))
        (t (macro-arglist1p (cdr args)))))

(defun subsequencep (lst1 lst2)

  (declare (xargs :guard (and (eqlable-listp lst1)
                              (true-listp lst2))))

; We return t iff lst1 is a subsequence of lst2, in the sense that
; '(a c e) is a subsequence of '(a b c d e f) but '(a c b) is not.

  (cond ((endp lst1) t)
        (t (let ((tl (member (car lst1) lst2)))
             (cond ((endp tl) nil)
                   (t (subsequencep (cdr lst1) (cdr tl))))))))

(defun collect-lambda-keywordps (lst)
  (declare (xargs :guard (true-listp lst)))
  (cond ((endp lst) nil)
        ((lambda-keywordp (car lst))
         (cons (car lst) (collect-lambda-keywordps (cdr lst))))
        (t (collect-lambda-keywordps (cdr lst)))))

(defun macro-args-structurep (args)
  (declare (xargs :guard t))
  (and (true-listp args)
       (let ((lambda-keywords (collect-lambda-keywordps args)))
         (and
          (or (subsequencep lambda-keywords
                            '(&whole &optional &rest &key &allow-other-keys))
              (subsequencep lambda-keywords
                            '(&whole &optional &body &key &allow-other-keys)))
          (and (not (member-eq '&whole (cdr args)))
               (implies (member-eq '&allow-other-keys args)
                        (member-eq '&allow-other-keys
                                   (member-eq '&key args)))
               (implies (eq (car args) '&whole)
                        (and (consp (cdr args))
                             (symbolp (cadr args))
                             (not (lambda-keywordp (cadr args)))
                             (macro-arglist1p (cddr args))))
               (macro-arglist1p args))))))

(defun macro-vars-key (args)

  (declare (xargs :guard (and (true-listp args)
                              (macro-arglist-keysp args nil))))

;  We have passed &key.

  (cond ((endp args) nil)
        ((eq (car args) '&allow-other-keys)
         (cond ((null (cdr args))
                nil)
               (t (er hard nil "macro-vars-key"))))
        ((atom (car args))
         (cons (car args) (macro-vars-key (cdr args))))
        (t (let ((formal (cond
                          ((atom (car (car args)))
                           (car (car args)))
                          (t (cadr (car (car args)))))))
             (cond ((int= (length (car args)) 3)
                    (cons formal
                          (cons (caddr (car args))
                                (macro-vars-key (cdr args)))))
                   (t (cons formal (macro-vars-key (cdr args)))))))))

(defun macro-vars-after-rest (args)

;  We have just passed &rest or &body.

  (declare (xargs :guard
                  (and (true-listp args)
                       (macro-arglist-after-restp args))))

  (cond ((endp args) nil)
        ((eq (car args) '&key)
         (macro-vars-key (cdr args)))
        (t (er hard nil "macro-vars-after-rest"))))

(defun macro-vars-optional (args)

  (declare (xargs :guard (and (true-listp args)
                              (macro-arglist-optionalp args))))

;  We have passed &optional but not &key or &rest or &body.

  (cond ((endp args) nil)
        ((eq (car args) '&key)
         (macro-vars-key (cdr args)))
        ((member (car args) '(&rest &body))
         (cons (cadr args) (macro-vars-after-rest (cddr args))))
        ((symbolp (car args))
         (cons (car args) (macro-vars-optional (cdr args))))
        ((int= (length (car args)) 3)
         (cons (caar args)
               (cons (caddr (car args))
                     (macro-vars-optional (cdr args)))))
        (t (cons (caar args)
                 (macro-vars-optional (cdr args))))))

(defun macro-vars (args)
  (declare
   (xargs :guard
          (macro-args-structurep args)
          :guard-hints (("Goal" :in-theory (disable LAMBDA-KEYWORDP)))))
  (cond ((endp args)
         nil)
        ((eq (car args) '&whole)
         (cons (cadr args) (macro-vars (cddr args))))
        ((member (car args) '(&rest &body))
         (cons (cadr args) (macro-vars-after-rest (cddr args))))
        ((eq (car args) '&optional)
         (macro-vars-optional (cdr args)))
        ((eq (car args) '&key)
         (macro-vars-key (cdr args)))
        ((or (not (symbolp (car args)))
             (lambda-keywordp (car args)))
         (er hard nil "macro-vars"))
        (t (cons (car args) (macro-vars (cdr args))))))

(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 doc doc-pair w state)
  (let ((w (update-doc-database
            name doc doc-pair
            (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-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* 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)

)

(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)
  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
  (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)

; 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.

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

(defun defconst-fn (name form state doc 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
   (if (output-in-infixp state) event-form (cons 'defconst name))
   (let ((wrld1 (w state))
         (event-form (or event-form (list* 'defconst name form
                                           (if doc (list doc) nil)))))
     (er-progn
      (chk-all-but-new-name name ctx 'const wrld1 state)
      (chk-legal-defconst-name name state)
      (let ((const-prop (getprop name 'const nil 'current-acl2-world wrld1)))
        (cond
         ((and const-prop
               (not (ld-redefinition-action state))
               (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))
         (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))
            (t
             (enforce-redundancy
              event-form ctx wrld1
              (er-let*
               ((wrld2 (chk-just-new-name name 'const nil ctx wrld1 state))
                (doc-pair (translate-doc name doc ctx state))
                (wrld3 (defconst-fn1 name val doc doc-pair wrld2 state)))
               (install-event name
                              event-form
                              'defconst
                              name
                              nil
                              (list 'defconst name form val)
                              nil nil wrld3 state)))))))))))))

(defun chk-legal-init-msg (x)

; See the note in chk-macro-arglist before changing this fn to
; translate the init value.

  (cond ((and (consp x)
              (true-listp x)
              (int= 2 (length x))
              (eq (car x) 'quote))
         nil)
        (t (msg "Illegal initial value.  In ACL2 we require that initial ~
                 values be quoted forms and you used ~x0.~#1~[  You should ~
                 just write '~x0 instead.  Warren Teitelman once remarked ~
                 that it was really dumb of a Fortran compiler to say ~
                 ``missing comma!''  ``If it knows a comma is missing, why ~
                 not just put one in?''  Indeed.~/~]  See :DOC macro-args."
                x
                (if (or (eq x nil)
                        (eq x t)
                        (acl2-numberp x)
                        (stringp x)
                        (characterp x))
                    0
                  1)))))

(defun chk-legal-init (x ctx state)
  (let ((msg (chk-legal-init-msg x)))
    (cond (msg (er soft ctx "~@0" msg))
          (t (value nil)))))

(defun chk-macro-arglist-keys (args keys-passed)
  (cond ((null args) nil)
        ((eq (car args) '&allow-other-keys)
         (cond ((null (cdr args)) nil)
               (t (msg "&ALLOW-OTHER-KEYS may only occur as the last member ~
                        of an arglist so it is illegal to follow it with ~x0.  ~
                        See :DOC macro-args."
                       (cadr args)))))
        ((atom (car args))
         (cond ((symbolp (car args))
                (let ((new (intern (symbol-name (car args)) "KEYWORD")))
                  (cond ((member new keys-passed)
                         (msg "The symbol-name of each keyword parameter ~
                               specifier must be distinct.  But you have used ~
                               the symbol-name ~s0 twice.  See :DOC ~
                               macro-args."
                              (symbol-name (car args))))
                        (t (chk-macro-arglist-keys
                            (cdr args)
                            (cons new keys-passed))))))
               (t (msg "Each keyword parameter specifier must be either a ~
                        symbol or a list.  Thus, ~x0 is illegal.  See :DOC ~
                        macro-args."
                       (car args)))))
        ((or (not (true-listp (car args)))
             (> (length (car args)) 3))
         (msg "Each keyword parameter specifier must be either a symbol or a ~
               truelist of length 1, 2, or 3.  Thus, ~x0 is illegal.  See ~
               :DOC macro-args."
              (car args)))
        (t (or (cond ((symbolp (caar args)) nil)
                     (t (cond ((or (not (true-listp (caar args)))
                                   (not (equal (length (caar args))
                                               2))
                                   (not (keywordp (car (caar args))))
                                   (not (symbolp (cadr (caar args)))))
                               (msg "Keyword parameter specifiers in which ~
                                     the keyword is specified explicitly, ~
                                     e.g., specifiers of the form ((:key var) ~
                                     init svar), must begin with a truelist ~
                                     of length 2 whose first element is a ~
                                     keyword and whose second element is a ~
                                     symbol.  Thus, ~x0 is illegal.  See :DOC ~
                                     macro-args."
                                    (car args)))
                              (t nil))))
               (let ((new (cond ((symbolp (caar args))
                                 (intern (symbol-name (caar args))
                                         "KEYWORD"))
                                (t (car (caar args))))))
                 (or
                  (cond ((member new keys-passed)
                         (msg "The symbol-name of each keyword parameter ~
                               specifier must be distinct.  But you have used ~
                               the symbol-name ~s0 twice.  See :DOC ~
                               macro-args."
                              (symbol-name new)))
                        (t nil))
                  (cond ((> (length (car args)) 1)
                         (chk-legal-init-msg (cadr (car args))))
                        (t nil))
                  (cond ((> (length (car args)) 2)
                         (cond ((symbolp (caddr (car args)))
                                nil)
                               (t (msg "~x0 is an illegal keyword parameter ~
                                        specifier because the ``svar'' ~
                                        specified, ~x1, is not a symbol.  See ~
                                        :DOC macro-args."
                                       (car args)
                                       (caddr (car args))))))
                        (t nil))
                  (chk-macro-arglist-keys (cdr args) (cons new keys-passed))))))))

(defun chk-macro-arglist-after-rest (args)
  (cond ((null args) nil)
        ((eq (car args) '&key)
         (chk-macro-arglist-keys (cdr args) nil))
        (t (msg "Only keyword specs may follow &REST or &BODY.  See :DOC ~
                 macro-args."))))

(defun chk-macro-arglist-optional (args)
  (cond ((null args) nil)
        ((member (car args) '(&rest &body))
         (cond ((and (cdr args)
                     (symbolp (cadr args))
                     (not (lambda-keywordp (cadr args))))
                (chk-macro-arglist-after-rest (cddr args)))
               (t (msg "~x0 must be followed by a variable symbol.  See :DOC ~
                        macro-args."
                       (car args)))))
        ((eq (car args) '&key)
         (chk-macro-arglist-keys (cdr args) nil))
        ((symbolp (car args))
         (chk-macro-arglist-optional (cdr args)))
        ((or (atom (car args))
             (not (true-listp (car args)))
             (not (< (length (car args)) 4)))
         (msg "Each optional parameter specifier must be either a symbol or a ~
               true list of length 1, 2, or 3.  ~x0 is thus illegal.  See ~
               :DOC macro-args."
              (car args)))
        ((not (symbolp (car (car args))))
         (msg "~x0 is an illegal optional parameter specifier because the ~
               ``variable symbol'' used is not a symbol.  See :DOC macro-args."
              (car args)))
        ((and (> (length (car args)) 1)
              (chk-legal-init-msg (cadr (car args)))))
        ((and (int= (length (car args)) 3)
              (not (symbolp (caddr (car args)))))
         (msg "~x0 is an illegal optional parameter specifier because the ~
               ``svar'' specified, ~x1, is not a symbol.  See :DOC macro-args."
              (car args)
              (caddr (car args))))
        (t (chk-macro-arglist-optional (cdr args)))))

(defun chk-macro-arglist1 (args)
  (cond ((null args) nil)
        ((not (symbolp (car args)))
         (msg "~x0 is illegal as the name of a required formal parameter.  ~
               See :DOC macro-args."
              (car args)))
        ((member (car args) '(&rest &body))
         (cond ((and (cdr args)
                     (symbolp (cadr args))
                     (not (lambda-keywordp (cadr args))))
                (chk-macro-arglist-after-rest (cddr args)))
               (t (msg "~x0 must be followed by a variable symbol.  See :DOC ~
                        macro-args."
                       (car args)))))
        ((eq (car args) '&optional)
         (chk-macro-arglist-optional (cdr args)))
        ((eq (car args) '&key)
         (chk-macro-arglist-keys (cdr args) nil))
        (t (chk-macro-arglist1 (cdr args)))))

(defun chk-macro-arglist-msg (args chk-state wrld)

; This "-msg" function supports the community book books/misc/defmac.lisp.

; Any modification to this function and its subordinates must cause
; one to reflect on the two function nests bind-macro-args...  and
; macro-vars... because they assume the presence of the structure that
; this function checks for.  See the comment before macro-vars for the
; restrictions we impose on macros.

; The subordinates of this function do not check that symbols that
; occur in binding spots are non-keywords and non-constants and
; without duplicates.  That check is performed here, with chk-arglist,
; as a final pass.

; Important Note:  If ever we change this function so that instead of
; just checking the args it "translates" the args, so that it returns
; the translated form of a proper arglist, then we must visit a similar
; change on the function primordial-event-macro-and-fn, which currently
; assumes that if a defmacro will be processed without error then
; the macro-args are exactly as presented in the defmacro.

; The idea of translating macro args is not ludicrous.  For example,
; the init-forms in keyword parameters must be quoted right now.  We might
; want to allow naked numbers or strings or t or nil.  But then we'd
; better go look at primordial-event-macro-and-fn.

; It is very suspicious to think about allowing the init forms to be
; anything but quoted constants because Common Lisp is very vague about
; when you get the bindings for free variables in such expressions
; or when such forms are evaluated.

  (or
   (and (not (true-listp args))
        (msg "The arglist ~x0 is not a true list.  See :DOC macro-args."
             args))
   (let ((lambda-keywords (collect-lambda-keywordps args))
         (err-string-for-&whole
          "When the &whole lambda-list keyword is used it must be the first ~
           element of the lambda-list and it must be followed by a variable ~
           symbol.  This is not the case in ~x0.  See :DOC macro-args."))
     (cond
      ((or (subsequencep lambda-keywords
                         '(&whole &optional &rest &key &allow-other-keys))
           (subsequencep lambda-keywords
                         '(&whole &optional &body &key &allow-other-keys)))
       (cond (args
              (cond ((member-eq '&whole (cdr args))
                     (msg err-string-for-&whole args))
                    ((and (member-eq '&allow-other-keys args)
                          (not (member-eq '&allow-other-keys
                                          (member-eq '&key args))))

; The Common Lisp Hyperspec does not seem to guarantee the normal expected
; functioning of &allow-other-keys unless it is preceded by &key.  We have
; observed in Allegro CL 8.0, for example, that if we define,
; (defmacro foo (x &allow-other-keys) (list 'quote x)), then we get an error
; with (foo x :y 3).

                     (msg "The use of ~x0 is only permitted when preceded by ~
                            ~x1.  The argument list ~x2 is thus illegal."
                          '&allow-other-keys
                          '&key
                          args))
                    ((eq (car args) '&whole)
                     (cond ((and (consp (cdr args))
                                 (symbolp (cadr args))
                                 (not (lambda-keywordp (cadr args))))
                            (chk-macro-arglist1 (cddr args)))
                           (t (msg err-string-for-&whole args))))
                    (t (chk-macro-arglist1 args))))
             (t nil)))
      (t (msg "The lambda-list keywords allowed by ACL2 are &WHOLE, ~
                &OPTIONAL, &REST, &BODY, &KEY, and &ALLOW-OTHER-KEYS.  These ~
                must occur (if at all) in that order, with no duplicate ~
                occurrences and at most one of &REST and &BODY.  The argument ~
                list ~x0 is thus illegal."
              args))))
   (chk-arglist-msg (macro-vars args) chk-state wrld)))

(defun chk-macro-arglist (args chk-state ctx state)
  (let ((msg (chk-macro-arglist-msg args chk-state (w state))))
    (cond (msg (er soft ctx "~@0" msg))
          (t (value nil)))))

(defun defmacro-fn1 (name args doc doc-pair guard body w state)
  (let ((w (update-doc-database
            name doc doc-pair
            (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 chk-defmacro-width (rst)
  (cond ((or (not (true-listp rst))
             (not (> (length rst) 2)))
         (mv "Defmacro requires at least 3 arguments.  ~x0 is ~
              ill-formed.  See :DOC defmacro."
             (cons 'defmacro rst)))
        (t
         (let ((name (car rst))
               (args (cadr rst))
               (value (car (last rst)))
               (dcls-and-docs (butlast (cddr rst) 1)))
           (mv nil
               (list name args dcls-and-docs value))))))

(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 (getprop name 'absolute-event-number nil 'current-acl2-world 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 (getprop name 'macro-body nil 'current-acl2-world 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
   (if (output-in-infixp state) event-form (cons 'defmacro (car mdef)))
   (let ((wrld1 (w state))
         (event-form (or event-form (cons 'defmacro mdef))))
     (mv-let
      (err-string four)
      (chk-defmacro-width mdef)
      (cond
       (err-string (er soft ctx err-string four))
       (t
        (let ((name (car four))
              (args (cadr four))
              (dcls (caddr four))
              (body (cadddr four)))
          (er-progn
           (chk-all-but-new-name name ctx 'macro wrld1 state)

; Important Note: In chk-macro-arglist-msg there is a comment warning us about
; the idea of "translating" the args to a macro to obtain the "internal" form
; of acceptable args.  See that comment before implementing any such change.

           (chk-macro-arglist args nil ctx state)
           (er-let*
               ((edcls (collect-declarations
                        dcls (macro-vars args)
                        'defmacro state ctx)))
             (let ((doc (if (stringp (car edcls)) (car edcls) nil))
                   (edcls (if (stringp (car edcls)) (cdr edcls) edcls)))
               (er-let*
                   ((tguard (translate
                             (conjoin-untranslated-terms
                              (get-guards1 edcls '(guards) wrld1))
                             '(nil) nil nil ctx wrld1 state)))
                 (mv-let
                  (ctx1 tbody)
                  (translate-cmp body '(nil) nil nil ctx wrld1
                                 (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))))
                   ((redundant-defmacrop name args tguard tbody wrld1)
                    (cond ((and (not (f-get-global 'in-local-flg state))
                                (not (global-val 'boot-strap-flg (w 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)))
                          (t (stop-redundant-event ctx state))))
                   (t
                    (enforce-redundancy
                     event-form ctx wrld1
                     (er-let*
                         ((wrld2 (chk-just-new-name name 'macro nil ctx wrld1 state))
                          (ignored (value (ignore-vars edcls)))
                          (ignorables (value (ignorable-vars edcls)))
                          (doc-pair (translate-doc name doc ctx state)))
                       (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 doc doc-pair
                                      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 otf-flg guard-debug doc)
      (list 'verify-guards-fn
            (list 'quote name)
            'state
            (list 'quote hints)
            (list 'quote otf-flg)
            (list 'quote guard-debug)
            (list 'quote doc)
            (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 doc)
            (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
                             doc)
      (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 doc)
            (list 'quote event-form)
            #+:non-standard-analysis ; std-p
            nil))
    (defmacro defaxiom (&whole event-form
                               name term
                               &key (rule-classes '(:REWRITE))
                               doc)
      (list 'defaxiom-fn
            (list 'quote name)
            (list 'quote term)
            'state
            (list 'quote rule-classes)
            (list 'quote doc)
            (list 'quote event-form)))
    (defmacro deflabel (&whole event-form name &key doc)
      (list 'deflabel-fn
            (list 'quote name)
            'state
            (list 'quote doc)
            (list 'quote event-form)))
    (defmacro defdoc (&whole event-form name doc)
      (list 'defdoc-fn
            (list 'quote name)
            'state
            (list 'quote doc)
            (list 'quote event-form)))
    (defmacro deftheory (&whole event-form name expr &key doc)
      (list 'deftheory-fn
            (list 'quote name)
            (list 'quote expr)
            'state
            (list 'quote doc)
            (list 'quote event-form)))
    (defmacro in-theory (&whole event-form expr &key doc)
      (list 'in-theory-fn
            (list 'quote expr)
            'state
            (list 'quote doc)
            (list 'quote event-form)))
    (defmacro in-arithmetic-theory (&whole event-form expr &key doc)
      (list 'in-arithmetic-theory-fn
            (list 'quote expr)
            'state
            (list 'quote doc)
            (list 'quote event-form)))
    (defmacro regenerate-tau-database (&whole event-form &key doc)
      (list 'regenerate-tau-database-fn
            'state
            (list 'quote doc)
            (list 'quote event-form)))
    (defmacro push-untouchable (&whole event-form name fn-p &key doc)
      (list 'push-untouchable-fn
            (list 'quote name)
            (list 'quote fn-p)
            'state
            (list 'quote doc)
            (list 'quote event-form)))
    (defmacro reset-prehistory (&whole event-form &optional permanent-p doc)
      (list 'reset-prehistory-fn
            (list 'quote permanent-p)
            'state
            (list 'quote doc)
            (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
                                   doc)
      (list 'include-book-fn
            (list 'quote user-book-name)
            'state
            (list 'quote load-compiled-file)
            (list 'quote :none)
            (list 'quote uncertified-okp)
            (list 'quote defaxioms-okp)
            (list 'quote skip-proofs-okp)
            (list 'quote ttags)
            (list 'quote doc)
            (list 'quote dir)
            (list 'quote event-form)))
    (defmacro local (x)
      (list 'if
            '(equal (ld-skip-proofsp state) 'include-book)
            '(mv nil nil state)
            (list 'if
                  '(equal (ld-skip-proofsp state) 'initialize-acl2)
                  '(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)
                                  :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)
                                       :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)
                                            :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 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 :common-lisp-compliant
                    (putprop
                     name-fn 'formals formals
                     (putprop
                      name-fn 'stobjs-in stobjs-in
                      (putprop
                       name-fn 'stobjs-out *error-triple-sig*

; The above may make sense, but the following act of fakery deserves
; some comment.  In order to get, e.g. defconst-fn, to work before
; it is defined in a boot-strap, we give it a body, which makes
; ev-fncall think it is ok to take a short cut and use the Common Lisp
; definition.  Of course, we are asking for trouble by laying down
; this recursive call!  But it never happens.

                       (putprop
                        name-fn 'def-bodies
                        (list (make def-body
                                    :formals formals
                                    :hyp nil
                                    :concl (cons name-fn formals)
                                    :rune
                                    *fake-rune-for-anonymous-enabled-rule*
                                    :nume 0 ; fake
                                    :recursivep nil
                                    :controller-alist nil))
                        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)

; 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))
           (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*))))
           (list 'recognizer-alist *initial-recognizer-alist*)
           (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)
                    (hons-enabled

; Why are we comfortable making hons-enabled a world global?  Note that even if
; if hons-enabled were a state global, the world would be sensitive to whether
; or not we are in the hons version: for example, we get different evaluation
; results for the following.

;   (getprop 'memoize-table 'table-guard *t* 'current-acl2-world (w state))

; By making hons-enabled a world global, we can access its value without state
; in history query functions such as :pe.

                     #+hons t #-hons nil)
                    (include-book-alist nil)
                    (include-book-alist-all nil)
                    (pcert-books nil)
                    (include-book-path nil)
                    (certification-tuple nil)
                    (documentation-alist nil)
                    (proved-functional-instances-alist nil)
                    (nonconstructive-axiom-names nil)
                    (standard-theories (nil nil nil nil))
                    (current-theory nil)
                    (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)
                    (free-var-runes-all nil)
                    (free-var-runes-once 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 defdoc 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 defdoc-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

                         ))
                    (ttags-seen nil)
                    (untouchable-fns nil)
                    (untouchable-vars nil)
                    (defined-hereditarily-constrained-fns nil)
                    (attachment-records nil)
                    (proof-supporters-alist 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 execution.  Our approach is to disallow all
; attachments to these functions, all of which are constrained since defined
; functions cannot receive attachments for execution.  So we search the code
; for encapsulated functions that we do not want executed.

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

; 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.

          ))

;; RAG - I added the treatment of *non-standard-primitives*

(defun primordial-world (operating-system)
  (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-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*)
                       (primordial-world-globals
                        operating-system))))))))))))))))))
      t))))

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

(deflabel package-reincarnation-import-restrictions
  :doc
  ":Doc-Section Miscellaneous

   re-defining undone ~ilc[defpkg]s~/

   Suppose ~c[(defpkg \"pkg\" imports)] is the most recently executed
   successful definition of ~c[\"pkg\"] in this ACL2 session and that it
   has since been undone, as by ~c[:]~ilc[ubt].  Any future attempt in this
   session to define ~c[\"pkg\"] as a package must specify an identical
   imports list.~/

   The restriction stems from the need to implement the reinstallation
   of saved logical ~il[world]s as in error recovery and the ~c[:]~ilc[oops] ~il[command].
   Suppose that the new ~ilc[defpkg] attempts to import some symbol, ~c[a::sym],
   not imported by the previous definition of ~c[\"pkg\"].  Because it was
   not imported in the original package, the symbol ~c[pkg::sym], different
   from ~c[a::sym], may well have been created and may well be used in some
   saved ~il[world]s.  Those saved ~il[world]s are Common Lisp objects being held
   for you ``behind the scenes.''  In order to import ~c[a::sym] into
   ~c[\"pkg\"] now we would have to unintern ~c[pkg::sym], rendering those
   saved ~il[world]s ill-formed.  It is because of saved ~il[world]s that we do
   not actually clear out a package when it is undone.

   At one point we thought it was sound to allow the new ~ilc[defpkg] to
   import a subset of the old.  But that is incorrect.  Suppose the old
   definition of ~c[\"pkg\"] imported ~c[a::sym] but the new one does not.
   Suppose we allowed that and implemented it simply by setting the
   imports of ~c[\"pkg\"] to the new subset.  Then consider the conjecture
   ~c[(eq a::sym pkg::sym)].  This ought not be a theorem because we did
   not import ~c[a::sym] into ~c[\"pkg\"].  But in fact in AKCL it is a theorem
   because ~c[pkg::sym] is read as ~c[a::sym] because of the old imports."

; Once upon a time the documentation included the following additional text.
; We deleted it on the grounds that we shouldn't tell the user how to go behind
; our backs.  But we might want to recall this hack in the future for our own
; use.

;    If you really must change the imports list of a previously defined
;    but now undone package, we recommend that you either invent a new
;    package name for subsequent use in this session or that you save
;    your state and reconstruct it in a new ACL2 session.  If you wish to
;    try behind the scenes surgery to allow the new ~ilc[defpkg] to succeed ~-[]
;    at the expense of ACL2's soundness in the rest of the session ~-[]
;    exit ~ilc[lp] and type the following to raw Lisp:
;    ~bv[]
;    (let ((name \"pkg\")           ; fill in pkg name
;          (new-imports '(...))     ; fill in new imports
;          (p (find-package name)))
;      (do-symbols (sym p) (unintern sym p))
;      (import new-imports p)
;      (setq *ever-known-package-alist*
;            (cons (make-package-entry :name name :imports new-imports)
;                  (remove-package-entry name *ever-known-package-alist*)))
;      name)
;    ~ev[]
;    This will render ill-formed any saved ~il[world]s involving symbols in
;    ~c[\"pkg\"] and it may be impossible to recover from certain errors.  In
;    addition, because ACL2 is probably unsound after this hack we
;    recommend that you treat the rest of the session as merely
;    exploratory.
)

(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-name-to-cert-name (x cert-op)

; X is assumed to satisfy chk-book-name.  We generate the corresponding
; certification file name.

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

  (coerce (append (reverse (cddddr (reverse (coerce x 'list))))
                  (case cert-op
                    ((t)
                     '(#\c #\e #\r #\t))
                    ((:create-pcert :create+convert-pcert)
                     '(#\p #\c #\e #\r #\t #\0))
                    (:convert-pcert
                     '(#\p #\c #\e #\r #\t #\1))
                    (otherwise ; including :write-acl2x
                     (er hard 'convert-book-name-to-cert-name
                         "Bad value of cert-op for ~
                          convert-book-name-to-cert-name:  ~x0"
                         cert-op))))
          'string))

(defun unrelativize-book-path (lst dir)
  (cond ((endp lst) nil)
        ((consp (car lst))
         (assert$ (eq (caar lst) :system) ; see relativize-book-path
                  (cons (concatenate 'string dir (cdar lst))
                        (unrelativize-book-path (cdr lst) dir))))
        (t (cons (car lst)
                 (unrelativize-book-path (cdr lst) dir)))))

(defun tilde-@-defpkg-error-phrase (name package-entry new-not-old old-not-new
                                         book-path defpkg-book-path w
                                         distrib-books-dir)
  (let ((book-path
         (unrelativize-book-path book-path distrib-books-dir))
        (defpkg-book-path
          (unrelativize-book-path defpkg-book-path distrib-books-dir)))
    (list
     "The proposed defpkg conflicts with a previously-executed 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 previous 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 "current" "previous"))
     (cons #\5 (zero-one-or-more book-path))
     (cons #\7 (car book-path))
     (cons #\8 (reverse book-path))
     (cons #\9 (if defpkg-book-path
                   "~|This previous 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
                      (global-val 'include-book-path w)))
                 (if (or include-book-path
                         defpkg-book-path)
                     (msg "~|The new 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 new proposed defpkg ~
                           event.~|  ~F0"
                          (reverse (append defpkg-book-path include-book-path)))
                   ""))))))

(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 (global-val 'boot-strap-flg w))
              (find-package-entry
               name
               (global-val 'known-package-alist w)))))
    (cond
     ((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 (standard-char-listp (coerce name 'list)))
         (er soft ctx
             "~x0 is not a legal package name for defpkg, which requires the ~
              name to contain only standard characters."
             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*))
        ((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))
        (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 (global-val 'boot-strap-flg w))))
        (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 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
                            (f-get-global 'system-books-dir state))))
                      ((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
                                             '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
   (if (output-in-infixp state) event-form (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* ((doc-pair (translate-doc name doc ctx state))
               (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, labelled 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)))))
                       (w3 (cond
                            (hidden-p w2) ; may as well skip :doc on hidden pkg
                            (t (update-doc-database name doc doc-pair w2)))))
                  (install-event name
                                 event-form
                                 'defpkg
                                 name
                                 nil
                                 (list 'defpkg name form)
                                 :protect ctx w3 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 throrough 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))))

(defmacro check-theory (lst wrld ctx form)
  `(cond ((theoryp! ,lst ,wrld)
          ,form)
         (t (er hard ,ctx
                "A theory function has been called on an argument that does ~
                 not represent a theory.  See the **NOTE**s above and see ~
                 :DOC theories."))))

(defun intersection-theories-fn (lst1 lst2 wrld)
  (check-theory
   lst1 wrld 'intersection-theories-fn
   (check-theory
    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.

  ":Doc-Section Theories

  intersect two ~il[theories]~/
  ~bv[]
  Example:
  (intersection-theories (current-theory :here)
                         (theory 'arith-patch))~/

  General Form:
  (intersection-theories th1 th2)
  ~ev[]
  where ~c[th1] and ~c[th2] are theories (~pl[theories]).  To each of
  the arguments there corresponds a runic theory.  This function
  returns the intersection of those two runic ~il[theories], represented as
  a list and ordered chronologically.

  This ``function'' is actually a macro that expands to a term
  mentioning the single free variable ~ilc[world].  When theory expressions
  are evaluated by ~ilc[in-theory] or the ~c[:]~ilc[in-theory] hint, ~ilc[world] is bound to
  the current ACL2 ~il[world].~/

  :cited-by theory-functions"

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

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

; Let lst1 and lst2 be augmented theories: descendingly ordered lists
; of pairs mapping numes to runes.  We return their union as an
; unagumented 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 the runic-theoryp check.

  (cond
   ((or lst1-known-to-be-runic
        (runic-theoryp lst1 wrld))
    (check-theory 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))))))

(defmacro union-theories (lst1 lst2)

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

  ":Doc-Section Theories

  union two ~il[theories]~/
  ~bv[]
  Example:
  (union-theories (current-theory 'lemma3)
                  (theory 'arith-patch))~/

  General Form:
  (union-theories th1 th2)
  ~ev[]
  where ~c[th1] and ~c[th2] are theories (~pl[theories]).  To each of
  the arguments there corresponds a runic theory.  This function
  returns the union of those two runic ~il[theories], represented as a list
  and ordered chronologically.

  This ``function'' is actually a macro that expands to a term
  mentioning the single free variable ~ilc[world].  When theory expressions
  are evaluated by ~ilc[in-theory] or the ~c[:]~ilc[in-theory] hint, ~ilc[world] is bound to
  the current ACL2 ~il[world].~/

  :cited-by theory-functions"

  (cond ((theory-fn-callp lst1)
         (list 'union-theories-fn
               lst1
               lst2
               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-augmented-theories-fn1 (lst1 lst2 ans)

; Let lst1 and lst2 be augmented theories: descendingly ordered lists
; of pairs mapping numes to runes.  We return their set-difference as
; an unagumented 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-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 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))
    (check-theory 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
     (check-theory
      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))))))

(defmacro set-difference-theories (lst1 lst2)

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

  ":Doc-Section Theories

  difference of two ~il[theories]~/
  ~bv[]
  Example:
  (set-difference-theories (current-theory :here)
                           '(fact (fact)))~/

  General Form:
  (set-difference-theories th1 th2)
  ~ev[]
  where ~c[th1] and ~c[th2] are ~il[theories] (~pl[theories]).  To each of
  the arguments there corresponds a runic theory.  This function
  returns the set-difference of those two runic ~il[theories], represented
  as a list and ordered chronologically.  That is, a ~il[rune] is in the
  result iff it is in the first runic theory but not in the second.

  The standard way to ``disable'' a theory, ~c[lst], is:
  ~c[(in-theory (set-difference-theories (current-theory :here) lst))].

  This ``function'' is actually a macro that expands to a term
  mentioning the single free variable ~ilc[world].  When theory expressions
  are evaluated by ~ilc[in-theory] or the ~c[:]~ilc[in-theory] hint, ~ilc[world] is bound to
  the current ACL2 ~il[world].~/

  :cited-by theory-functions"

  (list 'set-difference-theories-fn
        lst1
        lst2
        (theory-fn-callp lst1)
        '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.

  ":Doc-Section Theories

  all rules as of logical name~/
  ~bv[]
  Examples:
  (universal-theory :here)
  (universal-theory 'lemma3)
  ~ev[]
  ~l[logical-name].~/
  ~bv[]
  General Form:
  (universal-theory logical-name)
  ~ev[]
  Returns the theory consisting of all the ~il[rune]s that existed
  immediately after ~ilc[logical-name] was introduced.  ~l[theories]
  and ~pl[logical-name].  The theory includes ~ilc[logical-name] itself
  (if there is a rule by that name).  (Note that since some ~il[events] do
  not introduce rules (e.g., ~ilc[defmacro], ~ilc[defconst] or ~ilc[defthm] with
  ~c[:]~ilc[rule-classes] ~c[nil]), the universal-theory does not necessarily
  include a ~il[rune] for every event name.)  The universal-theory is very
  long and you will probably regret printing it.

  You may experience a fencepost problem in deciding which
  ~il[logical-name] to use.  ~ilc[Deflabel] can always be used to mark
  unambiguously for future reference a particular point in the
  development of your theory.  This is convenient because ~ilc[deflabel]
  does not introduce any rules and hence it doesn't matter if you
  count it as being in the interval or not.  The order of ~il[events] in
  the vicinity of an ~ilc[encapsulate] is confusing.  ~l[encapsulate].

  This ``function'' is actually a macro that expands to a term
  mentioning the single free variable ~ilc[world].  When theory expressions
  are evaluated by ~ilc[in-theory] or the ~c[:]~ilc[in-theory] hint, ~ilc[world] is bound to
  the current ACL2 ~il[world].

  Also ~pl[current-theory].  ~c[Current-theory] is much more commonly used than
  ~c[universal-theory].  The former includes only the ~il[enable]d ~il[rune]s
  as of the given ~ilc[logical-name], which is probably what you want, while
  the latter includes ~il[disable]d ones as well.~/

  :cited-by theory-functions"

  (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)
                                (case token
                                      (:DEFINITION
                                       (cons (cdr (car (cddr (car lst)))) ans))
                                      (: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.

                                       (let ((x (cdr (cadr (cddr (car lst))))))
                                         (if (null x)
                                             ans
                                           (cons x ans))))
                                      (otherwise
                                       (cons (cdr (car (cddr (car lst))))
                                             (cons (cdr (cadr (cddr (car lst))))
                                                   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.

  ":Doc-Section Theories

  function symbol rules as of logical name~/
  ~bv[]
  Examples:
  (function-theory :here)
  (function-theory 'lemma3)
  ~ev[]
  ~l[logical-name].~/
  ~bv[]
  General Form:
  (function-theory logical-name)
  ~ev[]
  Returns the theory containing all the ~c[:]~ilc[definition] ~il[rune]s, whether
  ~il[enable]d or not, that existed immediately after ~ilc[logical-name] was
  introduced.  See the documentation for ~il[theories],
  ~il[logical-name] and ~ilc[executable-counterpart-theory].

  You may experience a fencepost problem in deciding which logical
  name to use.  ~ilc[Deflabel] can always be used to mark unambiguously for
  future reference a particular point in the development of your
  theory.  The order of ~il[events] in the vicinity of an ~ilc[encapsulate] is
  confusing.  ~l[encapsulate].

  This ``function'' is actually a macro that expands to a term
  mentioning the single free variable ~ilc[world].  When theory expressions
  are evaluated by ~ilc[in-theory] or the ~c[:]~ilc[in-theory] hint, ~ilc[world] is bound to
  the current ACL2 ~il[world].~/

  :cited-by theory-functions"

  (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.

  ":Doc-Section Theories

  executable counterpart rules as of logical name~/
  ~bv[]
  Examples:
  (executable-counterpart-theory :here)
  (executable-counterpart-theory 'lemma3)
  ~ev[]
  ~l[logical-name].~/
  ~bv[]
  General Form:
  (executable-counterpart-theory logical-name)
  ~ev[]
  Returns the theory containing all the ~c[:]~ilc[executable-counterpart]
  ~il[rune]s, whether ~il[enable]d or not, that existed immediately after
  ~ilc[logical-name] was introduced.  See the documentation for
  ~il[theories], ~il[logical-name], ~il[executable-counterpart] and
  ~ilc[function-theory].

  You may experience a fencepost problem in deciding which logical
  name to use.  ~ilc[Deflabel] can always be used to mark unambiguously for
  future reference a particular point in the development of your
  theory.  The order of ~il[events] in the vicinity of an ~ilc[encapsulate] is
  confusing.  ~l[encapsulate].

  This ``function'' is actually a macro that expands to a term
  mentioning the single free variable ~ilc[world].  When theory expressions
  are evaluated by ~ilc[in-theory] or the ~c[:]~ilc[in-theory] hint, ~ilc[world] is bound to
  the current ACL2 ~il[world].~/

  :cited-by theory-functions"

  (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)))

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

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

; 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)))
    (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))
     (assert$-runic-theoryp (current-theory1 wrld2 nil nil)
                            wrld))))

(defmacro current-theory (logical-name)

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

  ":Doc-Section Theories

  currently ~il[enable]d rules as of logical name~/
  ~bv[]
  Examples:
  (current-theory :here)
  (current-theory 'lemma3)
  ~ev[]
  ~l[logical-name].~/
  ~bv[]
  General Form:
  (current-theory logical-name)
  ~ev[]
  Returns the current theory as it existed immediately after the
  introduction of ~ilc[logical-name] provided it is evaluated in
  an environment in which the variable symbol WORLD is bound to the
  current ACL2 logical world, ~c[(w state)].  Thus,
  ~bv[]
  ACL2 !>(current-theory :here)
  ~ev[]
  will cause an (unbound variable) error while
  ~bv[]
  ACL2 !>(let ((world (w state))) (current-theory :here))
  ~ev[]
  will return the current theory in world.

  ~l[theories] and ~pl[logical-name] for a discussion of
  theories in general and why the commonly used ``theory functions''
  such as ~c[current-theory] are really macros that expand into terms
  involving the variable ~c[world].

  The theory returned by ~c[current-theory] is in fact the theory selected by
  the ~ilc[in-theory] event most recently preceding logical name, extended by
  the rules introduced up through ~ilc[logical-name].

  You may experience a fencepost problem in deciding which logical
  name to use.  ~ilc[Deflabel] can always be used to mark unambiguously for
  future reference a particular point in the development of your
  theory.  The order of ~il[events] in the vicinity of an ~ilc[encapsulate] is
  confusing.  ~l[encapsulate].

  This ``function'' is actually a macro that expands to a term
  mentioning the single free variable ~ilc[world].  When theory expressions
  are evaluated by ~ilc[in-theory] or the ~c[:]~ilc[in-theory] hint, ~ilc[world] is bound to
  the current ACL2 ~il[world].~/

  :cited-by theory-functions"

  (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.

(defconst *initial-return-last-table*
  '((time$1-raw . time$1)
    (memoize-on-raw . memoize-on)
    (memoize-off-raw . memoize-off)
    (with-prover-time-limit1-raw . with-prover-time-limit1)
    (with-fast-alist-raw . with-fast-alist)
    (with-stolen-alist-raw . with-stolen-alist)
    (fast-alist-free-on-exit-raw . fast-alist-free-on-exit)

; Keep the following comment in sync with *initial-return-last-table* and with
; chk-return-last-entry.

; The following could be omitted since return-last gives them each special
; handling: prog2$ and mbe1 are used during the boot-strap before tables are
; supported, and ec-call1 and (in ev-rec-return-last) with-guard-checking gets
; special handling.  It is harmless though to include them explicitly, in
; particular at the end so that they do not add time in the expected case of
; finding one of the other entries in the table.  If we decide to avoid special
; handling (which we have a right to do, by the way, since users who modify
; return-last-table are supposed to know what they are doing, as a trust tag is
; needed), then we should probably move these entries to the top where they'll
; be seen more quickly.

    (progn . prog2$)
    (mbe1-raw . mbe1)
    (ec-call1-raw . ec-call1)
    (with-guard-checking1-raw . with-guard-checking1)))

(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 'proof-supporters-alist nil))
                 (putprop 'acl2-defaults-table
                          'table-alist
                          *initial-acl2-defaults-table*
                          (putprop 'return-last-table
                                   'table-alist
                                   *initial-return-last-table*
                                   wrld))))
         (wrld2 (update-current-theory (current-theory1 wrld nil nil) 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))))

(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 (getprop name 'theory t 'current-acl2-world 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)
         (getprop name 'theory nil 'current-acl2-world 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.

  ":Doc-Section Theories

  retrieve named theory~/
  ~bv[]
  Example:
  (theory 'ground-zero)
  ~ev[]
  In the example above, the theory returned is the one in force when ACL2 is
  started up (~pl[ground-zero]).~/

  ~bv[]
  General Form:
  (theory name)
  ~ev[]
  where ~c[name] is the name of a previously executed ~ilc[deftheory] event
  (otherwise a hard error occurs).  Returns the named theory.  ~l[theories].

  This ``function'' is actually a macro that expands to a term mentioning the
  single free variable ~ilc[world].  When theory expressions are evaluated by
  ~ilc[in-theory] or the ~c[:]~ilc[in-theory] hint, ~ilc[world] is bound to the
  current ACL2 ~il[world].~/

  :cited-by theory-functions"

  (list 'theory-fn name 'world))

(defun deftheory-fn (name expr state doc 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-chaning 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
    (if (output-in-infixp state) event-form (cons 'deftheory name))
    (let ((wrld (w state))
          (event-form (or event-form
                          (list* 'deftheory name expr
                                 (if doc
                                     (list :doc doc)
                                   nil)))))
      (er-progn
       (chk-all-but-new-name name ctx nil wrld state)
       (er-let*
        ((wrld1 (chk-just-new-name name 'theory nil ctx wrld state))
         (doc-pair (translate-doc name doc ctx state))
         (theory0 (translate-in-theory-hint expr nil ctx wrld1 state)))
        (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)
                 theory0
                 :none
                 wrld)
                (declare (ignore theory-augmented-ignore))
                (let ((wrld2 (update-doc-database
                              name doc doc-pair
                              (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 (length theory)
                                 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 in-theory-fn (expr state doc 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
    (if (output-in-infixp state)
        event-form
      (cond ((atom expr)
             (cond ((null doc)
                    (msg "( IN-THEORY ~x0)" expr))
                   (t (cons 'in-theory expr))))
            ((symbolp (car expr))
             (cond ((null doc)
                    (msg "( IN-THEORY (~x0 ...))"
                         (car expr)))
                   (t (msg "( IN-THEORY (~x0 ...) ...)"
                           (car expr)))))
            ((null doc) "( IN-THEORY (...))")
            (t "( IN-THEORY (...) ...)")))
    (let ((wrld (w state))
          (event-form (or event-form
                          (list* 'in-theory expr
                                 (if doc
                                     (list :doc doc)
                                   nil)))))
      (er-let*
       ((doc-pair (translate-doc nil doc ctx state))
        (theory0 (translate-in-theory-hint expr t ctx wrld state)))
       (let* ((ens1 (ens state))
              (force-xnume-en1 (enabled-numep *force-xnume* ens1))
              (imm-xnume-en1 (enabled-numep *immediate-force-modep-xnume* ens1))
              (wrld1 (update-current-theory theory0 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.

         (er-let*
          ((val (install-event (length theory0)
                                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 (list :NUMBER-OF-ENABLED-RUNES val))))))))))

(defun in-arithmetic-theory-fn (expr state doc 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 and 'current-theory-index.
; Someday we may want to make analogous changes to the present function.

  (when-logic
   "IN-ARITHMETIC-THEORY"
   (with-ctx-summarized
    (if (output-in-infixp state)
        event-form
      (cond ((atom expr)
             (cond ((null doc)
                    (msg "( IN-ARITHMETIC-THEORY ~x0)" expr))
                   (t (cons 'in-arithmetic-theory expr))))
            ((symbolp (car expr))
             (cond ((null doc)
                    (msg "( IN-ARITHMETIC-THEORY (~x0 ...))"
                         (car expr)))
                   (t (msg "( IN-ARITHMETIC-THEORY (~x0 ...) ...)"
                           (car expr)))))
            ((null doc) "( IN-ARITHMETIC-THEORY (...))")
            (t "( IN-ARITHMETIC-THEORY (...) ...)")))
    (let ((wrld (w state))
          (event-form (or event-form
                          (list* 'in-arithmetic-theory expr
                                 (if doc
                                     (list :doc doc)
                                   nil)))))
      (cond
       ((not (quotep expr))
        (er soft ctx
            "Arithmetic theory expressions must be quoted constants.  ~
             See :DOC in-arithmetic-theory."))
       (t
        (er-let*
          ((doc-pair (translate-doc nil doc ctx state))
           (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.

  ":Doc-Section Theories

  deletes names from current theory~/
  ~bv[]
  Example:
  (disable fact (fact) associativity-of-app)~/

  General Form:
  (disable name1 name2 ... namek)
  ~ev[]
  where each ~c[namei] is a runic designator; ~pl[theories].  The
  result is the theory that contains all the names in the current
  theory except those listed.  Note that this is merely a function
  that returns a theory.  The result is generally a very long list of
  ~il[rune]s and you will probably regret printing it.

  The standard way to ``disable'' a fixed set of names, is as follows;
  ~pl[hints] and ~pl[in-theory].
  ~bv[]
  :in-theory (disable name1 name2 ... namek)    ; in a hint
  (in-theory (disable name1 name2 ... namek))   ; as an event
  (local ; often desirable, to avoid exporting from the current context
   (in-theory (disable name1 name2 ... namek)))
  ~ev[]
  Note that all the names are implicitly quoted.  If you wish to
  disable a computed list of names, ~c[lst], use the theory expression
  ~c[(set-difference-theories (current-theory :here) lst)].~/

  :cited-by theory-functions"

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

(defmacro enable (&rest rst)

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

  ":Doc-Section Theories

  adds names to current theory~/
  ~bv[]
  Example:
  (enable fact (fact) associativity-of-app)~/

  General Form:
  (enable name1 name2 ... namek)
  ~ev[]
  where each ~c[namei] is a runic designator; ~pl[theories].  The
  result is the theory that contains all the names in the current
  theory plus those listed.  Note that this is merely a function that
  returns a theory.  The result is generally a very long list of ~il[rune]s
  and you will probably regret printing it.

  The standard way to ``enable'' a fixed set of names, is as follows;
  ~pl[hints] and ~pl[in-theory].
  ~bv[]
  :in-theory (enable name1 name2 ... namek)  ; in a hint
  (in-theory (enable name1 name2 ... namek)) ; as an event
  (local ; often desirable, to avoid exporting from the current context
   (in-theory (enable name1 name2 ... namek)))
  ~ev[]
  Note that all the names are implicitly quoted.  If you wish to
  enable a computed list of names, ~c[lst], use the theory expression
  ~c[(union-theories (current-theory :here) lst)].~/

  :cited-by theory-functions"

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

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

(table theory-invariant-table nil nil
       :guard (and (consp val)
                   (consp (cdr val))
                   (let ((tterm (access theory-invariant-record val
                                        :tterm)))
                     (and (termp tterm world)
                          (booleanp (access theory-invariant-record val
                                            :error))
                          (subsetp-eq (all-vars tterm) '(ens state))))))

#+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
; reexecute 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.

  ":Doc-Section Events

  user-specified invariants on ~il[theories]~/
  ~bv[]
  Examples:
  (theory-invariant (not (and (active-runep '(:rewrite left-to-right))
                              (active-runep '(:rewrite right-to-left))))
                    :key my-invariant
                    :error nil)

  ; Equivalent to the above:
  (theory-invariant (incompatible (:rewrite left-to-right)
                                  (:rewrite right-to-left))
                    :key my-invariant
                    :error nil)~/

  General Form:
  (theory-invariant term &key key error)
  ~ev[]
  where:~bq[]

  o ~c[term] is a term that uses no variables other than ~c[ens] and
  ~ilc[state];

  o ~c[key] is an arbitrary ``name'' for this invariant (if omitted, an integer
  is generated and used); and

  o ~c[:error] specifies the action to be taken when an invariant is violated
  ~-[] either ~c[nil] if a warning is to be printed, else ~c[t] (the default)
  if an error is to be caused.

  ~eq[]~c[Theory-invariant] is an event that adds to or modifies the ~il[table]
  of user-supplied theory invariants that are checked each time a theory
  expression is evaluated.

  The theory invariant mechanism is provided via a table
  (~pl[table]) named ~c[theory-invariant-table].  In fact, the
  ~c[theory-invariant] ``event'' is just a macro that expands into a use of the
  ~ilc[table] event.  More general access to the ~c[theory-invariant]
  ~il[table] is provided by ~ilc[table] itself.  For example, the ~il[table]
  can be inspected or cleared with ~ilc[table]; you can clear an individual
  theory invariant by setting the invariant to ~c[t], or eliminate all theory
  invariants with the command ~c[(table theory-invariant-table nil nil :clear)].

  ~c[Theory-invariant-table] maps arbitrary keys to records containing terms
  that mention, at most, the variables ~c[ens] and ~ilc[state].  Every time an
  alleged theory expression is evaluated, e.g., in the ~ilc[in-theory] event or
  ~c[:]~ilc[in-theory] hint, each of the terms in ~c[theory-invariant-table] is
  evaluated with ~c[ens] bound to a so-called ``enabled structure'' obtained
  from the theory expression and ~ilc[state] bound to the current ACL2 state
  (~pl[state]).  Users generally need not know about the enabled structure,
  other than that it can be accessed using the macros ~c[active-runep] and
  ~c[incompatible]; ~pl[active-runep] and ~pl[incompatible].  If the result is
  ~c[nil], a message is printed and an error occurs (except, only a warning
  occurs if ~c[:error nil] is specified).  Thus, the ~il[table] can be thought
  of as a list of conjuncts.  Each ~c[term] in the ~il[table] has a ``name,''
  which is just the key under which the term is stored.  When a theory violates
  the restrictions specified by some term, both the name and the term are
  printed.  By calling ~c[theory-invariant] with a new term but the same name,
  you can overwrite that conjunct of the theory invariant; but see the Local
  Redefinition Caveat at the end of this note.  You may want to avoid using
  explicit names, since otherwise the subsequent inclusion of another book that
  defines a theory invariant with the same name will override your theory
  invariant.

  Theory invariants are particularly useful in the context of large rule sets
  intended for re-use.  Such sets often contain conflicting rules, e.g., rules
  that are to be ~il[enable]d when certain function symbols are ~il[disable]d,
  rules that rewrite in opposite directions and thus loop if simultaneously
  ~il[enable]d, groups of rules which should be ~il[enable]d in concert, etc.
  The developer of such rule sets understands these restrictions and probably
  documents them.  The theory invariant mechanism allows the developer to
  codify his restrictions so that the user is alerted when they are violated.

  Since theory invariants are arbitrary terms, macros may be used to
  express commonly used restrictions.  For example, executing the event
  ~bv[]
  (theory-invariant (incompatible (:rewrite left-to-right)
                                  (:rewrite right-to-left)))
  ~ev[]
  would subsequently cause an error any time the current theory contained both
  of the two ~il[rune]s shown.  Of course, ~il[incompatible] is just defined as
  a macro.  Its definition may be inspected with ~c[:pe incompatible].

  In order for a ~c[theory-invariant] event to be accepted, the proposed theory
  invariant must be satisfied by the current theory (~pl[current-theory]).  The
  value returned upon successful execution of the event is the key (whether
  user-supplied or generated).

  Local Redefinition Caveat.  Care needs to be taken when redefining a theory
  invariant in a ~il[local] context.  Consider the following example.

  ~bv[]
  (theory-invariant
   (active-runep '(:definition binary-append))
   :key app-inv)

  (encapsulate
   ()
   (local (theory-invariant t :key app-inv))
   (in-theory (disable binary-append))
   (defthm ...))
  ~ev[]
  The second pass of the ~ilc[encapsulate] will fail, because the
  ~ilc[in-theory] event violates the original ~c[theory-invariant] and the
  ~ilc[local] ~c[theory-invariant] is skipped in the second pass of the
  ~ilc[encapsulate].  Of course, ~ilc[local] ~ilc[theory-invariant]s in
  ~il[books] can cause the analogous problem in the second (~ilc[include-book])
  pass of a ~ilc[certify-book].  In both cases, though, the theory invariants
  are only checked at the conclusion of the (~c[include-book] or
  ~c[encapsulate]) event.  Indeed, theory invariants are checked at the end of
  every event related to ~il[theories], including ~ilc[defun], ~ilc[defthm],
  ~ilc[in-theory], ~ilc[encapsulate], and ~ilc[include-book], except for events
  executed on behalf of an ~ilc[include-book] or the second pass of an
  ~ilc[encapsulate].~/"

  `(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 ,(if key
                               `(quote ,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)
                               :put
                               nil
                               'theory-invariant
                               (w 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)
                            (with-output
                             :off summary
                             (in-theory (current-theory :here)))
                            (declare (ignore val))
                            (cond
                             (erp
                              (er soft 'theory-invariant
                                  "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 (&rest args)
  (declare (ignore args))
  nil)

(defmacro incompatible (rune1 rune2)
  ":Doc-Section Theories

  declaring that two rules should not both be ~il[enable]d~/
  ~bv[]
  Example:
  (theory-invariant (incompatible (:rewrite left-to-right)
                                  (:rewrite right-to-left)))~/

  General Form:
  (incompatible rune1 rune2)
  ~ev[]
  where ~c[rune1] and ~c[rune2] are two specific ~il[rune]s.  The arguments are
  not evaluated.  ~c[Invariant] is just a macro that expands into a term
  that checks that not both ~il[rune]s are enabled.  ~l[theory-invariant].~/"

  (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-runep ',rune1)
                    (active-runep ',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)))))

; 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.

(deflabel signature
  :doc
  ":Doc-Section Miscellaneous

  how to specify the arity of a constrained function~/

  We start with a gentle introduction to signatures, where we pretend that
  there are no single-threaded objects (more on that below ~-[] for now, if you
  don't know anything about single-threaded objects, that's fine!).  Here are
  some simple examples of signatures.
  ~bv[]
  ((hd *) => *)
  ((pair * *) => *)
  ((foo * *) => (mv * * *))
  ~ev[]
  The first of these says that ~c[hd] is a function of one argument, while the
  other two say that ~c[pair] and ~c[foo] are functions that each take two
  arguments.  The first two say that ~c[hd] and ~c[pair] return a single
  value.  The third says that ~c[foo] returns three values, much as the
  following definition returns three values:
  ~bv[]
  (defun bar (x y)
    (mv y x (cons x y)))
  ~ev[]

  Corresponding ``old-style'' signatures are as follows.  In each case, a
  function symbol is followed by a list of formal parameters and then either
  ~c[t], to denote a single value return, or ~c[(mv t t t)], to denote a
  multiple value return (in this case, returning three values).
  ~bv[]
  (hd (x) t)
  (pair (x y) t)
  (foo (x y) (mv t t t))
  ~ev[]

  That concludes our gentle introduction.  The documentation below is more
  general, for example covering single-threaded objects and keyword values such
  as ~c[:guard].  When reading what follows below, it is sufficient to know
  about single-threaded objects (or ``stobjs'') that each has a unique symbolic
  name and that ~ilc[state] is the name of the only built-in single-threaded
  object.  All other stobjs are introduced by the user via ~ilc[defstobj] or
  ~ilc[defabsstobj].  An object that is not a single-threaded object is said to
  be ``ordinary.''  For a discussion of single-threaded objects, ~pl[stobj].~/

  ~bv[]
  Examples:
  ((hd *) => *)
  ((hd *) => * :formals (x) :guard (consp x))
  ((printer * state) => (mv * * state))
  ((mach * mach-state * state) => (mv * mach-state))

  General Form:
  ((fn ...) => *)
  ((fn ...) => stobj)
  or
  ((fn ...) => (mv ...))
  or for part1 and part2 as above,
  (part1 => part2 :kwd1 val1 ... :kwdn valn)
  ~ev[]
  where ~c[fn] is the constrained function symbol, ~c[...] is a list of
  asterisks and/or the names of single-threaded objects, ~c[stobj] is a
  single-threaded object name, and the optional ~c[:kwdi] and ~c[:vali] are as
  described below.  ACL2 also supports an older style of signature, described
  below after we describe the preferred style.

  Signatures specify three syntactic aspects of a function symbol: (1) the
  ``arity'' or how many arguments the function takes, (2) the ``multiplicity''
  or how many results it returns via ~c[MV], and (3) which of those arguments
  and results are single-threaded objects and which objects they are.

  A signature typically has the form ~c[((fn x1 ... xn) => val)].  Such a
  signature has two parts, separated by the symbol ``=>''.  The first part,
  ~c[(fn x1 ... xn)], is suggestive of a call of the constrained function.  The
  number of ``arguments,'' ~c[n], indicates the arity of ~c[fn].  Each ~c[xi]
  must be a symbol.  If a given ~c[xi] is the symbol ``*'' then the
  corresponding argument must be ordinary.  If a given ~c[xi] is any other
  symbol, that symbol must be the name of a single-threaded object and the
  corresponding argument must be that object.  No stobj name may occur twice
  among the ~c[xi].

  The second part, ~c[val], of a signature is suggestive of a term and
  indicates the ``shape'' of the output of ~c[fn].  If ~c[val] is a symbol then
  it must be either the symbol ``*'' or the name of a single-threaded object.
  In either case, the multiplicity of ~c[fn] is 1 and ~c[val] indicates whether
  the result is ordinary or a stobj.  Otherwise, ~c[val] is of the form
  ~c[(mv y1 ... yk)], where ~c[k] > 1.  Each ~c[yi] must be either the symbol
  ``*'' or the name of a stobj.  Such a ~c[val] indicates that ~c[fn] has
  multiplicity ~c[k] and the ~c[yi] indicate which results are ordinary and
  which are stobjs.  No stobj name may occur twice among the ~c[yi], and
  a stobj name may appear in ~c[val] only if appears among the ~c[xi].

  A signature may have the form ~c[((fn x1 ... xn) => val . k)], where ~c[k] is
  a ~ilc[keyword-value-listp], i.e., an alternating list of keywords and values
  starting with a keyword.  In this case ~c[((fn x1 ... xn) => val)] must be a
  legal signature as described above.  The legal keywords in ~c[k] are
  ~c[:GUARD] and ~c[:FORMALS] (except that for ACL2(r), also see the remark
  about ~c[:CLASSICALP] later in this topic).  The value following ~c[:FORMALS]
  is to be the list of formal parameters of ~c[fn], while the value following
  ~c[:GUARD] is a term that is to be the ~il[guard] of ~c[fn].  Note that this
  guard is never actually evaluated, and is not subject to the guard
  verification performed on functions introduced by ~ilc[defun]
  (~pl[verify-guards]).  Said differently: this guard need not itself have a
  guard of ~c[t].  Indeed, the guard is only used for attachments;
  ~pl[defattach].  Note that if ~c[:GUARD] is supplied then ~c[:FORMALS] must
  also be supplied (in order to related the variables occurring in the guard to
  the parameters of ~c[fn]).  One final observation about guards: if the
  ~c[:GUARD] keyword is omitted, then the guard defaults to ~c[T].

  Before ACL2 supported user-declared single-threaded objects there was only
  one single-threaded object: ACL2's built-in notion of ~ilc[state].  The
  notion of signature supported then gave a special role to the symbol
  ~c[state] and all other symbols were considered to denote ordinary objects.
  ACL2 still supports the old form of signature, but it is limited to functions
  that operate on ordinary objects or ordinary objects and ~c[state].

  ~bv[]
  Old-Style General Form:
  (fn formals result . k)
  ~ev[]

  where ~c[fn] is the constrained function symbol, ~c[formals] is a suitable
  list of formal parameters for it, ~c[k] is an optional
  ~ilc[keyword-value-listp] (see below), and ~c[result] is either a symbol
  denoting that the function returns one result or else ~c[result] is an
  ~ilc[mv] expression, ~c[(mv s1 ... sn)], where ~c[n>1], each ~c[si] is a
  symbol, indicating that the function returns ~c[n] results.  At most one of
  the formals may be the symbol ~c[STATE], indicating that corresponding
  argument must be ACL2's built-in ~ilc[state].  If ~c[state] appears in
  ~c[formals] then ~c[state] may appear once in ~c[result].  All ``variable
  symbols'' other than ~c[state] in old style signatures denote ordinary
  objects, regardless of whether the symbol has been defined to be a
  single-threaded object name!

  The optional ~c[k] is as described above for newer-style signatures, except
  that the user is also allowed to declare which symbols (besides ~c[state])
  are to be considered single-threaded object names.  Thus ~c[:STOBJS] is also
  a legal keyword.  The form
  ~bv[]
  (fn formals result ... :stobjs names ...)
  ~ev[]
  specifies that ~c[names] is either the name of a single-threaded object or
  else is a list of such names.  Every name in ~c[names] must have been
  previously defined as a stobj via ~ilc[defstobj] or ~ilc[defabsstobj].

  As promised above, we conclude with a remark about an additional keyword,
  ~c[:CLASSICALP], that is legal for ACL2(r) (~pl[real]).  The value of this
  keyword must be ~c[t] (the default) or ~c[nil], indicating respectively
  whether ~c[fn] is classical or not.~/")

(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 :FORMALS))

(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 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 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))
         ((not (and (symbol-listp pretty-flags1)
                    (no-duplicatesp-equal
                     (collect-non-x '* 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))
         ((not (or (symbolp val)
                   (and (consp val)
                        (eq (car val) 'mv)
                        (symbol-listp (cdr val))
                        (no-duplicatesp-equal
                         (collect-non-x '* (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))
         ((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 be filled by asterisks (*) or ~
                single-threaded object names."
               x)
              nil nil nil nil nil))
         ((not (subsetp-eq (collect-non-x '* (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
               (set-difference-eq (if (consp val)
                                      (cdr val)
                                    (list val))
                                  (cons '* pretty-flags1))
               (cons fn pretty-flags1))
              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))
         ((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))
         ((assoc-keyword :STOBJS kwd-value-list)
          (mv (msg "The object ~x0 is not a legal signature.  The :STOBJS ~
                    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)
              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))
         #+:non-standard-analysis
         ((not (booleanp (cadr (assoc-keyword :CLASSICALP

; If :CLASSICALP is not bound in kwd-value-list, then the above test reduces to
; (not (booleanp nil)), which is false, which is appropropriate.

                                              kwd-value-list))))
          (mv (msg "The object ~x0 is not a legal signature.  The value of ~
                    :CLASSICALP keyword must be Boolean; see :DOC signature."
                   x)
              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-x '* pretty-flags1)))
            (mv nil fn formals val stobjs 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))
         ((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))
         ((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))
         ((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))
         #+:non-standard-analysis
         ((not (booleanp (cadr (assoc-keyword :CLASSICALP

; See comment above about :CLASSICALP.

                                              kwd-value-list))))
          (mv (msg "The object ~x0 is not a legal signature.  The value of ~
                    :CLASSICALP keyword must be Boolean; see :DOC signature."
                   x)
              nil nil nil nil nil))
         (t
          (let* ((stobjs-tail (assoc-keyword :STOBJS kwd-value-list))
                 (kwd-value-list (if stobjs-tail
                                     (remove-keyword :STOBJS 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 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 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)))))))
       (& (mv (msg *generic-bad-signature-string* x) 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
                             (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)))
        (let* ((syms (cond ((symbolp val) (list val))
                           (t (cdr val))))
               (stobjs-in (compute-stobj-flags formals
                                               stobjs
                                               wrld))
               (stobjs-out (compute-stobj-flags syms
                                                stobjs
                                                wrld)))
          (cond
           ((not (subsetp (collect-non-x nil stobjs-out)
                          (collect-non-x nil 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-x nil stobjs-out)
                                   (collect-non-x nil stobjs-in))
                formals
                val))
           ((not (no-duplicatesp (collect-non-x nil 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-x nil stobjs-out))))
           (t (er-let* ((wrld1 (chk-just-new-name fn
                                                  (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 (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 (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-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)))

; The following is a complete list of the macros that are considered
; "primitive event macros".  This list includes every macro that calls
; install-event except for defpkg, which is omitted as
; explained below.  In addition, the list includes defun (which is
; just a special call of defuns).  Every name on this list has the
; property that while it takes state as an argument and possibly
; changes it, the world it produces is a function only of the world in
; the incoming state and the other arguments.  The function does not
; change the world as a function of, say, some global variable in the
; state.

; The claim above, about changing the world, is inaccurate for include-book!
; It changes the world as a function of the contents of some arbitrarily
; named input object file.  How this can be explained, I'm not sure.

; All event functions have the property that they install into state
; the world they produce, when they return non-erroneously.  More
; subtly they have the property that when the cause an error, they do
; not change the installed world.  For simple events, such as DEFUN
; and DEFTHM, this is ensured by not installing any world until the
; final STOP-EVENT.  But for compound events, such as ENCAPSULATE and
; INCLUDE-BOOK, it is ensured by the more expensive use of
; REVERT-WORLD-ON-ERROR.

(defun primitive-event-macros ()
  (declare (xargs :guard t :mode :logic))

; Warning: If you add to this list, consider adding to
; find-first-non-local-name and to the list in translate11 associated with a
; comment about primitive-event-macros.

; Warning: Keep this in sync with oneify-cltl-code (see comment there about
; primitive-event-macros).

; Warning:  See the warnings below!

; Note: This zero-ary function used to be a constant, *primitive-event-macros*.
; But Peter Dillinger wanted to be able to change this value with ttags, so
; this function has replaced that constant.  We keep the lines sorted below,
; but only for convenience.

  '(
     #+:non-standard-analysis defthm-std
     #+:non-standard-analysis defun-std
     add-custom-keyword-hint
     add-default-hints!
     add-include-book-dir
     add-ld-keyword-alias!
     add-match-free-override
     comp
     defabsstobj
     defattach
     defaxiom
     defchoose
     defconst
     defdoc
     deflabel
     defmacro
;    defpkg ; We prohibit defpkgs except in very special places.  See below.
     defstobj
     deftheory
     defthm
     defttag
     defun
     defuns
     delete-include-book-dir
     encapsulate
     in-arithmetic-theory
     in-theory
     include-book
     logic
     mutual-recursion
     progn
     progn!
     program
     push-untouchable
     regenerate-tau-database
     remove-default-hints!
     remove-untouchable
     reset-prehistory
     set-backchain-limit
     set-body
     set-bogus-defun-hints-ok
     set-bogus-mutual-recursion-ok
     set-case-split-limitations
     set-compile-fns
     set-default-backchain-limit
     set-default-hints!
     set-enforce-redundancy
     set-ignore-doc-string-error
     set-ignore-ok
     set-inhibit-warnings!
     set-invisible-fns-table
     set-irrelevant-formals-ok
     set-let*-abstractionp
     set-match-free-default
     set-measure-function
     set-non-linearp
     set-nu-rewriter-mode
     set-override-hints-macro
     set-prover-step-limit
     set-rewrite-stack-limit
     set-ruler-extenders
     set-rw-cache-state!
     set-state-ok
     set-tau-auto-mode
     set-verify-guards-eagerness
     set-well-founded-relation
     table
     theory-invariant
     value-triple
     verify-guards
     verify-termination-boot-strap
     ))

; Warning: If a symbol is on this list then it is allowed into books.
; If it is allowed into books, it will be compiled.  Thus, if you add a
; symbol to this list you must consider how compile will behave on it
; and what will happen when the .o file is loaded.  Most of the symbols
; on this list have #-acl2-loop-only definitions that make them
; no-ops.  At least one, defstub, expands into a perfectly suitable
; form involving the others and hence inherits its expansion's
; semantics for the compiler.

; Warning: If this list is changed, inspect the following definitions,
; down through CHK-EMBEDDED-EVENT-FORM.  Also consider modifying the
; list *fmt-ctx-spacers* as well.

; We define later the notion of an embedded event.  Only such events
; can be included in the body of an ENCAPSULATE or a file named by
; INCLUDE-BOOK.

; We do not allow defpkg as an embedded event.  In fact, we do not allow
; defpkg anywhere in a blessed set of files except in files that contain
; nothing but top-level defpkg forms (and those files must not be compiled).
; The reason is explained in deflabel embedded-event-form below.

; Once upon a time we allowed in-package expressions inside of
; encapsulates, in a "second class" way.  That is, they were not
; allowed to be hidden in LOCAL forms.  But the whole idea of putting
; in-package expressions in encapsulated event lists is silly:
; In-package is meant to change the package into which subsequent
; forms are read.  But no reading is being done by encapsulate and the
; entire encapsulate event list is read into whatever was the current
; package when the encapsulate was read.

; Here is an example of why in-package should never be hidden (i.e.,
; in LOCAL), even in a top-level list of events in a file.

; Consider the following list of events:

; (DEFPKG ACL2-MY-PACKAGE '(DEFTHM SYMBOL-PACKAGE-NAME EQUAL))

; (LOCAL (IN-PACKAGE "ACL2-MY-PACKAGE"))

; (DEFTHM GOTCHA (EQUAL (SYMBOL-PACKAGE-NAME 'IF) "ACL2-MY-PACKAGE"))

; When processed in pass 1, the IN-PACKAGE is executed and thus
; the subsequent form (and hence the symbol 'IF) is read into package
; ACL2-MY-PACKAGE.  Thus, the equality evaluates to T and GOTCHA is a
; theorem.  But when processed in pass 2, the IN-PACKAGE is not
; executed and the subsequent form is read into the "ACL2" package.  The
; equality evaluates to NIL and GOTCHA is not a theorem.

(deflabel embedded-event-form
  :doc
  ":Doc-Section Miscellaneous

  forms that may be embedded in other ~il[events]~/
  ~bv[]
  Examples:
  (defun hd (x) (if (consp x) (car x) 0))
  (local (defthm lemma23 ...))
  (progn (defun fn1 ...)
         (local (defun fn2 ...))
         ...)~/

  General Form:
  An embedded event form is a term, x, such that:~ev[]~bq[]

  o ~c[x] is a call of an event function other than ~ilc[DEFPKG] (~pl[events]
  for a listing of the event functions);

  o ~c[x] is of the form ~c[(]~ilc[LOCAL]~c[ x1)] where ~c[x1] is an embedded
  event form;

  o ~c[x] is of the form ~c[(]~ilc[SKIP-PROOFS]~c[ x1)] where ~c[x1] is an
  embedded event form;

  o ~c[x] is of the form ~c[(]~ilc[MAKE-EVENT]~c[ &)], where ~c[&] is any term
  whose expansion is an embedded event (~pl[make-event]);

  o ~c[x] is of the form ~c[(]~ilc[WITH-OUTPUT]~c[ ... x1)],
  ~c[(]~ilc[WITH-PROVER-STEP-LIMIT]~c[ ... x1 ...)], or
  ~c[(]~ilc[WITH-PROVER-TIME-LIMIT]~c[ ... x1)], where ~c[x1] is an embedded
  event form;

  o ~c[x] is a call of ~ilc[ENCAPSULATE], ~ilc[PROGN], ~ilc[PROGN!], or
  ~ilc[INCLUDE-BOOK];

  o ~c[x] macroexpands to one of the forms above; or

  o [intended only for the implementation] ~c[x] is
  ~c[(RECORD-EXPANSION x1 x2)], where ~c[x1] and ~c[x2] are embedded event
  forms.

  ~eq[]
  An exception: an embedded event form may not set the
  ~ilc[acl2-defaults-table] when in the context of ~ilc[local].  Thus for
  example, the form
  ~bv[]
  (local (table acl2-defaults-table :defun-mode :program))
  ~ev[]
  is not an embedded event form, nor is the form ~c[(local (program))],
  since the latter sets the ~ilc[acl2-defaults-table] implicitly.  An
  example at the end of the discussion below illustrates why there is
  this restriction.

  Only embedded event forms are allowed in a book after its initial
  ~ilc[in-package] form.  ~l[books].  However, you may find that
  ~ilc[make-event] allows you to get the effect you want for a form that is not
  an embedded event form.  For example, you can put the following into a book,
  which assigns the value 17 to ~ilc[state] global variable ~c[x]:
  ~bv[]
  (make-event (er-progn (assign x 17)
                        (value '(value-triple nil)))
              :check-expansion t)
  ~ev[]

  When an embedded event is executed while ~ilc[ld-skip-proofsp] is
  ~c[']~ilc[include-book], those parts of it inside ~ilc[local] forms are
  ignored.  Thus,
  ~bv[]
     (progn (defun f1 () 1)
            (local (defun f2 () 2))
            (defun f3 () 3))
  ~ev[]
  will define ~c[f1], ~c[f2], and ~c[f3] when ~ilc[ld-skip-proofsp] is ~c[nil]
  or ~c[t], but will define only ~c[f1] and ~c[f3] when ~ilc[ld-skip-proofsp]
  is ~c[']~ilc[include-book].

  ~em[Discussion:]

  ~ilc[Encapsulate], ~ilc[progn], and ~ilc[include-book] place restrictions on
  the kinds of forms that may be processed.  These restrictions ensure that the
  non-local ~il[events] are indeed admissible provided that the sequence of
  ~ilc[local] and non-local ~il[events] is admissible when proofs are done,
  i.e., when ~c[ld-skip-proofs] is ~c[nil].  But ~ilc[progn!] places no such
  restrictions, hence is potentially dangerous and should be avoided unless you
  understand the ramifications; so it is illegal unless there is an active
  trust tag (~pl[defttag]).

  ~ilc[Local] permits the hiding of an event or group of ~il[events] in the
  sense that ~ilc[local] ~il[events] are processed when we are trying to
  establish the admissibility of a sequence of ~il[events] embedded in
  ~ilc[encapsulate] forms or in ~il[books], but are ignored when we are
  constructing the ~il[world] produced by assuming that sequence.  Thus, for
  example, a particularly ugly and inefficient ~c[:]~ilc[rewrite] rule might be
  made ~ilc[local] to an ~il[encapsulate] that ``exports'' a desirable theorem
  whose proof requires the ugly lemma.

  To see why we can't allow just anything as an embedded event, consider
  allowing the form
  ~bv[]
  (if (ld-skip-proofsp state)
      (defun foo () 2)
      (defun foo () 1))
  ~ev[]
  followed by
  ~bv[]
  (defthm foo-is-1 (equal (foo) 1)).
  ~ev[]
  When we process the ~il[events] with ~ilc[ld-skip-proofsp] is ~c[nil], the
  second ~ilc[defun] is executed and the ~ilc[defthm] succeeds.  But when we
  process the ~il[events] with ~ilc[ld-skip-proofsp] ~c[']~ilc[include-book],
  the second ~ilc[defun] is executed, so that ~c[foo] no longer has the same
  definition it did when we proved ~c[foo-is-1].  Thus, an invalid formula is
  assumed when we process the ~ilc[defthm] while skipping proofs.  Thus, the
  first form above is not a legal embedded event form.

  If you encounter a situation where these restrictions seem to prevent you
  from doing what you want to do, then you may find ~c[make-event] to be
  helpful.  ~l[make-event].

  ~ilc[Defpkg] is not allowed because it affects how things are read after
  it is executed.  But all the forms embedded in an event are read
  before any are executed.  That is,
  ~bv[]
  (encapsulate nil
               (defpkg \"MY-PKG\" nil)
               (defun foo () 'my-pkg::bar))
  ~ev[]
  makes no sense since ~c[my-pkg::bar] must have been read before the
  ~ilc[defpkg] for ~c[\"MY-PKG\"] was executed.

  Finally, let us elaborate on the restriction mentioned earlier
  related to the ~ilc[acl2-defaults-table].  Consider the following form.
  ~bv[]
  (encapsulate
   ()
   (local (program))
   (defun foo (x)
     (if (equal 0 x)
         0
       (1+ (foo (- x))))))
  ~ev[]
  ~l[local-incompatibility] for a discussion of how ~ilc[encapsulate] processes
  event forms.  Briefly, on the first pass through the ~il[events] the
  definition of ~c[foo] will be accepted in ~ilc[defun] mode
  ~c[:]~ilc[program], and hence accepted.  But on the second pass the form
  ~c[(local (program))] is skipped because it is marked as ~ilc[local], and
  hence ~c[foo] is accepted in ~ilc[defun] mode ~c[:]~ilc[logic].  Yet, no
  proof has been performed in order to admit ~c[foo], and in fact, it is not
  hard to prove a contradiction from this definition!~/")

; One can imagine adding new event forms.  The requirement is that
; either they not take state as an argument or else they not be
; sensitive to any part of state except the current ACL2 world.

(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)
; defdoc-fn                  ---
; 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 . chk-sum))

; 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 "")))

(defun chk-embedded-event-form (form orig-form wrld ctx state names portcullisp
                                     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-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.

; In addition, if portcullisp is t we are checking that the forms are
; acceptable as the portcullis of some book and we enforce the additional
; restriction noted below.

;   (local &) is illegal because such a command would be skipped
;   when executing the portcullis during the subsequent include-book.

; 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.  (We used
; to make these restrictions when portcullisp is t, because we restored the
; initial acl2-defaults-table before certification, and hence it was misguided
; for the user to be setting the defun-mode or the compile flag in the
; certification world since they were irrelevant to the world in which the
; certification is done.)  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 "".

          (if portcullisp
              "The command ~x0, used in the construction of the current ~
               world, cannot be included in the portcullis of a certified ~
               book~@1.  See :DOC portcullis.~@2~@3"
            "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
            (portcullisp

; We will miss this case if we have an ill-formed call of local:
; (not (and (consp (cdr form)) (null (cddr form)))).  However, macroexpansion
; of local will fail later, so that isn't a problem.

             (er soft ctx er-str
                 form
                 " because LOCAL commands are not executed by include-book"
                 (chk-embedded-event-form-orig-form-msg orig-form state)
                 ""))
            ((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
                                  portcullisp 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)
                           '(add-custom-keyword-hint
                             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-doc-string-error
                             set-ignore-ok
                             set-irrelevant-formals-ok
                             set-let*-abstractionp
                             set-match-free-default
                             set-measure-function
                             set-non-linearp
                             set-nu-rewriter-mode
                             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)))
           (er soft ctx local-str
               form
               " because it implicitly 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 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 (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
                                 portcullisp in-local-flg in-encapsulatep
                                 make-event-chk)))
                     (value (and new-form (list (car form) new-form))))))
          ((and (member-eq (car form) '(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.

           (er-let* ((new-form (chk-embedded-event-form
                                (car (last form))
                                orig-form wrld ctx state
                                names portcullisp 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
                       (not (and (true-listp form)
                                 (or (consp (cadr (member-eq :check-expansion
                                                             form)))
                                     (consp (cadr (member-eq :expansion?
                                                             form)))))))
                  (er soft ctx
                      "Either the :check-expansion or :expansion? argument of ~
                       make-event should be a consp in the present context.  ~
                       Unless you called record-expansion explicitly, this is ~
                       an ACL2 bug; please contact the ACL2 implementors.  ~
                       Current form:~|~%~X01"
                      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
                                              portcullisp in-local-flg
                                              in-encapsulatep nil)
                     (chk-embedded-event-form (caddr form)
                                              (or orig-form form)
                                              wrld ctx state names
                                              portcullisp in-local-flg
                                              in-encapsulatep t)))))
          ((getprop (car form) 'macro-body nil 'current-acl2-world wrld)
           (cond
            ((member-eq (car form) (global-val 'untouchable-fns wrld))
             (er soft ctx er-str
                 form
                 ""
                 (chk-embedded-event-form-orig-form-msg orig-form state)
                 (msg "~|The macro ~x0 may not be used to generate an event, ~
                       because it has been placed on untouchable-fns.  See ~
                       :DOC push-untouchable."
                      (car form))))
            ((member-eq (car form)
                        '(mv mv-let translate-and-test with-local-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.  Please ~
                       contact the implementors if this seems to be a ~
                       hardship."
                      (car form))))
            (t
             (er-let*
              ((expansion (macroexpand1 form ctx state)))
              (chk-embedded-event-form expansion
                                       (or orig-form form)
                                       wrld ctx state names
                                       portcullisp 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.

(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) '(local skip-proofs with-output
                                       with-prover-step-limit
                                       with-prover-time-limit))
         (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! ()

  ":Doc-Section switches-parameters-and-modes

  enter ``raw mode,'' a raw Lisp environment~/

  This is the same as ~c[(]~ilc[set-raw-mode]~c[ t)] except that it first
  introduces a so-called ``trust tag'' (``ttag'') so that ~c[set-raw-mode] will
  be legal.  ~l[defttag] for a discussion of ttags and how they affect
  ~ilc[certify-book] and ~ilc[include-book].~/

  ~l[set-raw-mode] for a discussion of raw-mode.~/"

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

(defmacro set-raw-mode (flg)
  (declare (xargs :guard (member-equal flg '(t 't nil 'nil))))

  ":Doc-Section switches-parameters-and-modes

  enter or exit ``raw mode,'' a raw Lisp environment~/

  Below we discuss raw-mode.  In brief: The simplest way to turn raw-mode on is
  ~c[:SET-RAW-MODE-ON!], and to turn it off, ~c[:SET-RAW-MODE NIL].  Also
  ~pl[set-raw-mode-on!].~/

  ACL2 users often find its careful syntax checking to be helpful during code
  development.  Sometimes it is even useful to do code development in
  ~c[:]~ilc[logic] mode, where ACL2 can be used to check termination of
  (mutually) recursive functions, verify guards, or even prove properties of
  the functions.

  However, loading code using ~ilc[include-book] is much slower than using
  Common Lisp ~c[load] in raw Lisp, and in this sense ACL2 can get in the way
  of efficient execution.  Unfortunately, it is error-prone to use ACL2 sources
  (or their compilations) in raw Lisp, primarily because a number of ACL2
  primitives will not let you do so.  Perhaps you have seen this error message
  when trying to do so:
  ~bv[]
  HARD ACL2 ERROR in ACL2-UNWIND-PROTECT:  Apparently you have tried
  to execute a form in raw Lisp that is only intended to be executed
  inside the ACL2 loop.
  ~ev[]
  Even without this problem it is important to enter the ACL2 loop (~pl[lp]),
  for example in order to set the ~ilc[cbd] and (to get more technical) the
  readtable.

  ACL2 provides a ``raw mode'' for execution of raw Lisp forms.  In this mode,
  ~ilc[include-book] reduces essentially to a Common Lisp ~c[load].  More
  generally, the ACL2 logical ~ilc[world] is not routinely extended in raw mode
  (some sneaky tricks are probably required to make that happen).  To turn raw
  mode off or on:
  ~bv[]
  :set-raw-mode t   ; turn raw mode on
  :set-raw-mode nil ; turn raw mode off
  ~ev[]

  The way you can tell that you are in raw mode is by looking at the prompt
  (~pl[default-print-prompt]), which uses a capital ``~c[P]'' (suggesting
  something like program mode, but more so).
  ~bv[]
  ACL2 P>
  ~ev[]

  Typical benefits of raw mode are fast loading of source and compiled files
  and the capability to hack arbitrary Common Lisp code in an environment with
  the ACL2 sources loaded (and hence with ACL2 primitives available).  In
  addition, ACL2 hard errors will put you into the Lisp debugger, rather than
  returning you to the ACL2 loop, and this may be helpful for debugging;
  ~pl[hard-error] and ~pl[illegal], but also ~pl[break-on-error].  However, it
  probably is generally best to avoid raw mode unless these advantages seem
  important.  We expect the main benefit of raw mode to be in deployment of
  applications, where load time is much faster than the time required for a
  full-blown ~ilc[include-book], although in certain cases the fast loading of
  books and treatment of hard errors discussed above may be useful during
  development.

  Raw mode is also useful for those who want to build extensions of ACL2.  For
  example, the following form can be put into a certifiable book to load an
  arbitrary Common Lisp source or compiled file.
  ~bv[]
  (progn (defttag my-application)
         (progn! (set-raw-mode t)
                 (load \"some-file\")))
  ~ev[]
  Also see ~c[with-raw-mode] defined in community book
  ~c[books/hacking/hacker.lisp], ~pl[defttag], and ~pl[progn!].

  Below are several disadvantages to raw mode.  These should discourage users
  from using it for general code development, as ~c[:]~ilc[program] mode is
  generally preferable.
  ~bf[]
  -- Forms are in essence executed in raw Lisp.  Hence:
     -- Syntax checking is turned off; and
     -- Guard checking is completely disabled.
  -- Table events, including ~ilc[logic], are ignored, as are many
     other ~ilc[events], including ~ilc[defthm] and ~ilc[comp].
  -- Soundness claims are weakened for any ACL2 session in which raw
     mode was ever entered; ~pl[defttag].
  -- The normal undoing mechanism (~pl[ubt]) is not supported.
  -- Unexpected behavior may occur when you return from raw-mode.
     For example, if you redefine a :logic mode function whose guards
     have not been verified, you will not see the change inside the
     ACL2 loop because there, the raw Common Lisp definition is only
     executed after guards have been verified; ~pl[guards-and-evaluation]
     and ~pl[guard-evaluation-table].
  ~ef[]

  We conclude with some details.

  ~em[Printing results].  The rules for printing results are unchanged for raw
  mode, with one exception.  If the value to be printed would contain any Lisp
  object that is not a legal ACL2 object, then the ~c[print] routine is used
  from the host Lisp, rather than the usual ACL2 printing routine.  The
  following example illustrates the printing used when an illegal ACL2 object
  needs to be printed.  Notice how that ``command conventions'' are observed
  (~pl[ld-post-eval-print]); the ``~c[[Note]'' occurs one space over in the
  second example, and no result is printed in the third example.
  ~bv[]
  ACL2 P>(find-package \"ACL2\")
  [Note:  Printing non-ACL2 result.]
  #<The ACL2 package>
  ACL2 P>(mv nil (find-package \"ACL2\") state)
   [Note:  Printing non-ACL2 result.]
  #<The ACL2 package>
  ACL2 P>(mv t (find-package \"ACL2\") state)
  ACL2 P>(mv 3 (find-package \"ACL2\"))
  [Note:  Printing non-ACL2 result.]
  (3 #<The ACL2 package>)
  ACL2 P>
  ~ev[]
  If you have trouble with large structures being printed out, you might want
  to execute appropriate Common Lisp forms in raw mode, for example,
  ~c[(setq *print-length* 5)] and ~c[(setq *print-level* 5)].

  ~em[Include-book].  The ~il[events] ~ilc[add-include-book-dir] and
  ~ilc[delete-include-book-dir] have been designed to work with raw mode.
  However, if you enter raw mode and then evaluate such forms, then the effects
  of these forms will disappear when you exit raw mode, in which case you can
  expect to see a suitable warning.  Regarding ~em[include-book] itself: it
  should work in raw mode as you might expect, at least if a compiled file or
  expansion file was created when the book was certified; ~pl[certify-book].

  ~em[Packages].  Raw mode disallows the use of ~ilc[defpkg].  If you want to
  create a new package, first exit raw mode with ~c[:set-raw-mode nil];
  you can subsequently re-enter raw mode with ~c[:set-raw-mode t] if you
  wish.~/"

  (if (or (null flg)
          (equal flg '(quote nil)))
      '(set-raw-mode-off state)
    '(set-raw-mode-on state)))

#-acl2-loop-only
(defun-one-output stobj-out (val)

; Warning:  This function assumes that we are not in the context of a local
; stobj.  As of this writing, it is only used in raw mode, so this does not
; concern us too much.  With raw mode, there are no guarantees.

  (if (eq val *the-live-state*)
      'state
    (car (rassoc val *user-stobj-alist* :test 'eq))))

#-(or acl2-loop-only acl2-mv-as-values)
(defun mv-ref! (i)

; This silly function is just mv-ref, but without the restriction that the
; argument be an explicit number.

  (case i
    (1 (mv-ref 1))
    (2 (mv-ref 2))
    (3 (mv-ref 3))
    (4 (mv-ref 4))
    (5 (mv-ref 5))
    (6 (mv-ref 6))
    (7 (mv-ref 7))
    (8 (mv-ref 8))
    (9 (mv-ref 9))
    (10 (mv-ref 10))
    (11 (mv-ref 11))
    (12 (mv-ref 12))
    (13 (mv-ref 13))
    (14 (mv-ref 14))
    (15 (mv-ref 15))
    (16 (mv-ref 16))
    (17 (mv-ref 17))
    (18 (mv-ref 18))
    (19 (mv-ref 19))
    (20 (mv-ref 20))
    (21 (mv-ref 21))
    (22 (mv-ref 22))
    (23 (mv-ref 23))
    (24 (mv-ref 24))
    (25 (mv-ref 25))
    (26 (mv-ref 26))
    (27 (mv-ref 27))
    (28 (mv-ref 28))
    (29 (mv-ref 29))
    (30 (mv-ref 30))
    (31 (mv-ref 31))
    (otherwise (error "Illegal value for mv-ref!"))))

(defmacro add-raw-arity (name val)
  (declare (xargs :guard (and (symbolp name)
                              (or (and (integerp val) (<= 0 val))
                                  (eq val :last)))))

  ":Doc-Section Set-raw-mode

  add arity information for raw mode~/

  Technical note: This macro is a no-op, and is not necessary, when ACL2 is
  built with #-acl2-mv-as-values.

  Users of raw mode (~pl[set-raw-mode]) can use arbitrary raw Lisp functions
  that are not known inside the usual ACL2 loop.  In such cases, ACL2 may not
  know how to display a multiple value returned by ACL2's ~ilc[mv] macro.  The
  following example should make this clear.
  ~bv[]
  ACL2 P>(defun foo (x y) (mv y x))
  FOO
  ACL2 P>(foo 3 4)

  Note: Unable to compute number of values returned by this evaluation
  because function FOO is not known in the ACL2 logical world.  Presumably
  it was defined in raw Lisp or in raw mode.  Returning the first (perhaps
  only) value for calls of FOO.
  4
  ACL2 P>(add-raw-arity foo 2)
   RAW-ARITY-ALIST
  ACL2 P>(foo 3 4)
  (4 3)
  ACL2 P>
  ~ev[]
  The first argument of ~c[add-raw-arity] should be a symbol, representing the
  name of a function, macro, or special form, and the second argument should
  either be a non-negative integer (denoting the number of values returned by
  ACL2) or else the symbol ~c[:LAST], meaning that the number of values
  returned by the call is the number of values returned by the last
  argument.~/

  The current arity assignments can be seen by evaluating
  ~c[(@ raw-arity-alist)].  ~l[remove-raw-arity] for how to undo a call of
  ~c[add-raw-arity].~/"

  #+acl2-mv-as-values (declare (ignore name val))
  #+acl2-mv-as-values '(value nil)
  #-acl2-mv-as-values
  `(pprogn (f-put-global 'raw-arity-alist
                         (put-assoc-eq ',name
                                       ,val
                                       (f-get-global 'raw-arity-alist state))
                         state)
           (value 'raw-arity-alist)))

(defmacro remove-raw-arity (name)
  (declare (xargs :guard (symbolp name)))

  ":Doc-Section Set-raw-mode

  remove arity information for raw mode~/

  Technical note: This macro is a no-op, and is not necessary, when ACL2 is
  built with #-acl2-mv-as-values.

  The form ~c[(remove-raw-arity fn)] undoes the effect of an earlier
  ~c[(remove-raw-arity fn val)].  ~l[add-raw-arity].~/~/"

  #+acl2-mv-as-values (declare (ignore name))
  #+acl2-mv-as-values '(value nil)
  #-acl2-mv-as-values
  `(pprogn (f-put-global 'raw-arity-alist
                         (delete-assoc-eq ',name
                                          (f-get-global 'raw-arity-alist
                                                        state))
                         state)
           (value 'raw-arity-alist)))

#-(or acl2-loop-only acl2-mv-as-values)
(defun raw-arity (form wrld state)
  (cond
   ((atom form) 1)
   ((eq (car form) 'mv)
    (length (cdr form)))
   ((eq (car form) 'if)
    (let ((arity1 (raw-arity (caddr form) wrld state)))
      (if (cdddr form)
          (let ((arity2 (raw-arity (cadddr form) wrld state)))
            (if (eql arity1 arity2)
                arity1
              (let ((min-arity (min arity1 arity2)))
                (prog2$
                 (warning$ 'top-level "Raw"
                           "Unable to compute arity of the following ~
                            IF-expression in raw mode because the true branch ~
                            has arity ~x0 but the false branch has arity ~x1, ~
                            so we assume an arity of ~x2 ~
                            (see :DOC add-raw-arity):~%  ~x3."
                           arity1 arity2 min-arity form)
                 min-arity))))
        arity1)))
   ((eq (car form) 'return-last)
    (raw-arity (car (last form)) wrld state))
   (t (let ((arity (cdr (assoc-eq (car form)
                                  (f-get-global 'raw-arity-alist state)))))
        (cond
         ((eq arity :last)
          (raw-arity (car (last form)) wrld state))
         ((and (integerp arity)
               (<= 0 arity))
          arity)
         (arity
          (error "Ill-formed value of ~s."
                 '(@ raw-arity-alist)))
         (t
          (let ((stobjs-out
                 (getprop (car form) 'stobjs-out t 'current-acl2-world wrld)))
            (cond
             ((eq stobjs-out t)
              (multiple-value-bind
               (new-form flg)
               (macroexpand-1 form)
               (cond ((null flg)

; Remember that our notion of multiple value here is ACL2's notion, not Lisp's
; notion.  So the arity is 1 for calls of Common Lisp functions.

                      (when (not (member-eq
                                  (car form)
                                  *common-lisp-symbols-from-main-lisp-package*))
                        (fms "Note: Unable to compute number of values ~
                              returned by this evaluation because function ~x0 ~
                              is not known in the ACL2 logical world.  ~
                              Presumably it was defined in raw Lisp or in raw ~
                              mode.  Returning the first (perhaps only) value ~
                              for calls of ~x0.  See :DOC add-raw-arity.~|"
                             (list (cons #\0 (car form)))
                             *standard-co* state nil))
                      1)
                     (t (raw-arity new-form wrld state)))))
             (t (length stobjs-out))))))))))

(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))))

#-(or acl2-loop-only acl2-mv-as-values)
(defun acl2-raw-eval (form state)
  (or (eq state *the-live-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 ((val (eval (acl2-raw-eval-form-to-eval form)))
          (index-bound (raw-arity form (w state) state)))
      (if (<= index-bound 1)
          (mv nil (cons (list (stobj-out val)) val) state)
        (let ((ans nil)
              (stobjs-out nil))
          (do ((i (1- index-bound) (1- i)))
              ((eql i 0))
              (let ((x (mv-ref! i)))
                (push x ans)
                (push (stobj-out x)
                      stobjs-out)))
          (mv nil
              (cons (cons (stobj-out val) stobjs-out)
                    (cons val ans))
              state))))))

#+(and (not acl2-loop-only) acl2-mv-as-values)
(defun acl2-raw-eval (form state)
  (or (eq state *the-live-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* ((vals (multiple-value-list
                  (eval (acl2-raw-eval-form-to-eval form))))
           (arity (length vals)))
      (if (<= arity 1)
          (let ((val (car vals)))
            (mv nil (cons (list (stobj-out val)) val) state))
        (mv nil
            (loop for val in vals
                  collect (stobj-out val) into stobjs-out
                  finally (return (cons stobjs-out vals)))
            state)))))

#+acl2-loop-only
(defun acl2-raw-eval (form state)
  (trans-eval 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 ; portcullisp
                                 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)))

(mutual-recursion

(defun elide-locals-rec (form strongp)

; 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 eliding has taken place.  Note that we do
; not dive into encapsulate forms when strongp is nil, the assumption being
; that such forms are handled already in the construction of record-expansion
; calls in eval-event-lst.

  (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*))
        ((member-eq (car form) '(skip-proofs
                                 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 particulary 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)) strongp)
                 (cond (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) strongp)
                 (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) strongp)
                 (cond (changed-p (mv t (list* (car form) (cadr form) x)))
                       (t (mv nil form)))))
        ((and strongp
              (eq (car form) 'encapsulate))
         (mv-let (changed-p x)
                 (elide-locals-lst (cddr form) strongp)
                 (cond (changed-p (mv t (list* (car form) (cadr form) x)))
                       (t (mv nil form)))))
        (t (mv nil form))))

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

(defun elide-locals (form environment strongp)

; We do not elide locals if we are at the top level, as opposed to inside
; certify-book, because we don't want to lose potential information about local
; skip-proofs events.  (As of this writing, 3/15/09, it's not clear that such
; risk exists; but we will play it safe.)  Note that our redundancy test for
; encapsulates should work fine even if the same encapsulate form has a
; different expansion in some certification world and in some book, since for
; redundancy it suffices to compare the original make-event to the new one in
; each case.  Note that we track skip-proofs events in the certification world,
; even those under LOCAL; see the Essay on Skip-proofs.

  (cond ((member-eq 'certify-book environment)

; In this case, we know that certify-book has not been called only to write out
; a .acl2x file (as documented in eval-event-lst).  If we are writing a .acl2x
; file, then we need to keep local events to support certification.

         (mv-let (changed-p x)
                 (elide-locals-rec form strongp)
                 (declare (ignore changed-p))
                 x))
        (t form)))

(defun make-record-expansion (event expansion)
  (case-match event
    (('record-expansion a &) ; & is a partial expansion
     (list 'record-expansion a expansion))
    (&
     (list 'record-expansion event expansion))))

(defun eval-event-lst (index expansion-alist ev-lst quietp environment
                             in-local-flg last-val other-control kpa
                             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 expansion-alist-pkg-names.

; 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.

  (cond
   ((null ev-lst)
    (pprogn (f-put-global 'last-make-event-expansion nil state)
            (mv nil last-val (reverse expansion-alist) kpa state)))
   (t (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 "(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
                                          (primitive-event-macros)
                                          nil
                                          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
                          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)
                     (trans-eval 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 (primitive-event-macros))
                 (cond
                  (erp (pprogn (f-put-global 'last-make-event-expansion nil
                                             state)
                               (mv 'make-event-problem index nil nil state)))
                  (t
                   (eval-event-lst
                    (1+ index)
                    (cond
                     (expansion0
                      (acons index
                             (make-record-expansion
                              (car ev-lst)
                              (elide-locals
                               (mv-let (wrappers base-form)
                                       (destructure-expansion form)
                                       (declare (ignore base-form))
                                       (rebuild-expansion wrappers
                                                          expansion0))
                               environment

; We use strongp = nil here because sub-encapsulates are already taking care of
; eliding their own locals.

                               nil))
                             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))
                    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))))

;; RAG - 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 union-eq-cars (alist)
  (cond ((null alist) nil)
        (t (union-eq (caar alist) (union-eq-cars (cdr 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 (wrld3 proto-wrld3 seen acc)

; 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.

; 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.

  (cond ((equal wrld3 proto-wrld3)
         (reverse acc))
        ((let ((key-alist (assoc-eq (caar wrld3) seen)))
            (and key-alist ; optimization
                 (assoc-eq (cadar wrld3) (cdr key-alist))))
         (new-trips (cdr wrld3) proto-wrld3 seen acc))
        ((eq (cddr (car wrld3)) *acl2-property-unbound*)
         (new-trips (cdr wrld3) proto-wrld3
                    (put-assoc-eq (caar wrld3)
                                  (cons (cdar wrld3)
                                        (cdr (assoc-eq (caar wrld3) seen)))
                                  seen)
                    acc))
        (t
         (new-trips (cdr wrld3) proto-wrld3
                    (put-assoc-eq (caar wrld3)
                                  (cons (cdar wrld3)
                                        (cdr (assoc-eq (caar wrld3) seen)))
                                  seen)
                    (cons (car wrld3) acc)))))

(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 ((eq constraint-lst *unknown-constraints*)

; 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
                               dependent-clause-processor 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
     (dependent-clause-processor
      (putprop-x-lst1
       constrained-fns 'constrainedp dependent-clause-processor
       (putprop
        fn 'constrainedp dependent-clause-processor
        wrld3)))
     (t wrld3)))))

(deflabel local-incompatibility
  :doc
  ":Doc-Section Miscellaneous

  when non-local ~il[events] won't replay in isolation~/

  Sometimes a ``~ilc[local] incompatibility'' is reported while attempting
  to embed some ~il[events], as in an ~ilc[encapsulate] or ~ilc[include-book].  This is
  generally due to the use of a locally defined name in a non-local
  event or the failure to make a witnessing definition ~ilc[local].~/

  ~ilc[Local] incompatibilities may be detected while trying to execute the
  strictly non-local ~il[events] of an embedding.  For example, ~ilc[encapsulate]
  operates by first executing all the ~il[events] (~ilc[local] and non-local)
  with ~ilc[ld-skip-proofsp] ~c[nil], to confirm that they are all admissible.
  Then it attempts merely to assume the non-local ones to create the
  desired theory, by executing the ~il[events] with ~ilc[ld-skip-proofsp] set to
  ~c[']~ilc[include-book].  Similarly, ~ilc[include-book] assumes the non-local ones,
  with the understanding that a previously successful ~ilc[certify-book] has
  performed the admissiblity check.

  How can a sequence of ~il[events] admitted with ~ilc[ld-skip-proofsp] ~c[nil] fail
  when ~ilc[ld-skip-proofsp] is ~c[']~ilc[include-book]?  The key observation is that
  in the latter case only the non-local ~il[events] are processed.  The
  ~ilc[local] ones are skipped and so the non-local ones must not depend
  upon them.

  Two typical mistakes are suggested by the detection of a ~ilc[local]
  incompatibility: (1) a locally defined function or macro was used in
  a non-~ilc[local] event (and, in the case of ~ilc[encapsulate], was not included
  among the ~il[signature]s) and (2) the witnessing definition of a
  function that was included among the ~il[signature]s of an ~ilc[encapsulate]
  was not made ~ilc[local].

  An example of mistake (1) would be to include among your
  ~il[encapsulate]d ~il[events] both ~c[(local (defun fn ...))] and
  ~c[(defthm lemma (implies (fn ...) ...))].  Observe that ~c[fn] is
  defined locally but a formula involving ~c[fn] is defined
  non-locally.  In this case, either the ~ilc[defthm] should be made
  ~ilc[local] or the ~ilc[defun] should be made non-local.

  An example of mistake (2) would be to include ~c[(fn (x) t)] among your
  ~il[signature]s and then to write ~c[(defun fn (x) ...)] in your ~il[events],
  instead of ~c[(local (defun fn ...))].

  One subtle aspect of ~ilc[encapsulate] is that if you constrain any member
  of a mutually recursive clique you must define the entire clique
  locally and then you must constrain those members of it you want
  axiomatized non-locally.

  Errors due to ~ilc[local] incompatibility should never occur in the
  assumption of a fully certified book.  Certification ensures against
  it.  Therefore, if ~ilc[include-book] reports an incompatibility, we
  assert that earlier in the processing of the ~ilc[include-book] a warning
  was printed advising you that some book was uncertified.  If this is
  not the case ~-[] if ~ilc[include-book] reports an incompatibility and there
  has been no prior warning about lack of certification ~-[] please
  report it to us.

  When a ~ilc[local] incompatibility is detected, we roll-back to the ~il[world]
  in which we started the ~ilc[encapsulate] or ~ilc[include-book].  That is, we
  discard the intermediate ~il[world] created by trying to process the
  ~il[events] skipping proofs.  This is clean, but we realize it is very
  frustrating because the entire sequence of ~il[events] must be processed
  from scratch.  Assuming that the embedded ~il[events] were, once upon a
  time, processed as top-level ~il[command]s (after all, at some point you
  managed to create this sequence of ~il[command]s so that the ~ilc[local] and
  non-local ones together could survive a pass in which proofs were
  done), it stands to reason that we could define a predicate that
  would determine then, before you attempted to embed them, if ~ilc[local]
  incompatibilities exist.  We hope to do that, eventually.

  We conclude with a subtle example of ~ilc[local] incompatibility.  The problem
  is that in order for ~c[foo-type-prescription] to be admitted using the
  specified ~c[:typed-term] ~c[(foo x)], the conclusion ~c[(my-natp (foo x))]
  depends on ~c[my-natp] being a ~il[compound-recognizer].  This is fine on the
  first pass of the ~ilc[encapsulate], during which lemma ~c[my-natp-cr] is
  admitted.  But ~c[my-natp-cr] is skipped on the second pass because it is
  marked ~ilc[local], and this causes ~c[foo-type-prescription] to fail on the
  second pass.
  ~bv[]
  (defun my-natp (x)
    (declare (xargs :guard t))
    (and (integerp x)
         (<= 0 x)))

  (defun foo (x)
    (nfix x))

  (encapsulate
   ()
   (local (defthm my-natp-cr
            (equal (my-natp x)
                   (and (integerp x)
                        (<= 0 x)))
            :rule-classes :compound-recognizer))
   (defthm foo-type-prescription
     (my-natp (foo x))
     :hints ((\"Goal\" :in-theory (enable foo)))
     :rule-classes ((:type-prescription :typed-term (foo x)))))
  ~ev[]")

(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 agains 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 in-encapsulatep (embedded-event-lst non-trivp)

; This function determines if we are in the scope of an encapsulate.
; If non-trivp is t, we restrict the interpretation to mean ``in the
; scope of a non-trivial encapsulate'', i.e., in an encapsulate that
; introduces a constrained function symbol.

  (cond
   ((endp embedded-event-lst) nil)
   ((and (eq (car (car embedded-event-lst)) 'encapsulate)
         (if non-trivp
             (cadr (car embedded-event-lst))
           t))
    t)
   (t (in-encapsulatep (cdr embedded-event-lst) non-trivp))))

(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))

  ":Doc-Section Other

  redo on failure of a ~ilc[progn], ~ilc[encapsulate], or ~ilc[certify-book]~/

  When one submits an ~ilc[encapsulate], ~ilc[progn], or ~ilc[certify-book]
  command and there is a failure, ACL2 restores its logical ~il[world] as
  though the command had not been run.  But sometimes one would like to debug
  the failure by re-executing all sub-events that succeeded up to the point of
  failure, and then re-executing the failed sub-event.  Said differently,
  imagine that the ~il[events] under an ~c[encapsulate], ~c[progn], or
  ~c[certify-book] form were flattened into a list of events that were then
  submitted to ACL2 up to the point of failure.  This would put us in the state
  in which the original failed event had failed, so we could now replay that
  failed event and try modifying it, or first proving additional events, in
  order to get it admitted.

  ~c[Redo-flat] is provided for this purpose.  Consider the following (rather
  nonsensical) example, in which the ~ilc[defun] of ~c[f3] fails (the body is
  ~c[y] but the formal parameter list is ~c[(x)]).
  ~bv[]
  (encapsulate
   ()
   (defun f1 (x) x)
   (encapsulate ()
                (local (defthm hack (equal (car (cons x y)) x))))
   (encapsulate ()
                (local (defthm hack (equal (+ x y) (+ y x)))))
   (encapsulate ()
                (make-event '(defun f2 (x) x))
                (progn (defthm foo (equal x x) :rule-classes nil)
                       (defun f3 (x) y)))
   (defun f4 (x) x)
   (defun f5 (x) y))
  ~ev[]
  After this attempt fails, you can evaluate the following form.
  ~bv[]
  (redo-flat)
  ~ev[]
  This will first lay down a ~ilc[deflabel] event, ~c[(deflabel r)], so that
  you can eventually remove your debugging work with ~c[(:ubt! r)].  Then the
  successful sub-events that preceded the failure will be executed with proofs
  skipped (so that this execution is fast).  Then, the failed event will be
  executed.  Finally, a ~c[:]~ilc[pbt] command is executed so that you can see
  a summary of the events that executed successfully.

  You can eliminate some of the steps above by supplying keyword values, as
  follows.
  ~bv[]
  (redo-flat
   :succ  succ ; Skip the successful sub-events if val is nil.
   :fail  fail ; Skip the failed sub-event if val is nil.
   :label lab  ; Skip deflabel if lab or succ is nil, else use (deflabel lab).
   :pbt   val  ; Skip the final :pbt if val, lab, or succ is nil.
   )
  ~ev[]
  Also, you can avoid skipping proofs for the successful sub-events by
  supplying keyword ~c[:succ-ld-skip-proofsp] with a valid value for
  ~c[ld-skip-proofsp]; ~pl[ld-skip-proofsp].  For example, you might want to
  execute ~c[(redo-flat :succ-ld-skip-proofsp nil)] if you use the
  ~c[must-fail] utility from community book ~c[make-event/eval.lisp], since
  for example ~c[(must-fail (thm (equal x y)))] normally succeeds but would
  cause an error if proofs are skipped.

  If you prefer only to see the successful and failed sub-events, without any
  events being re-executed, you may evaluate the following form instead.
  ~bv[]
  (redo-flat :show t)
  ~ev[]
  For the example above, this command produces the following output.
  ~bv[]

  List of events preceding the failure:

  ((DEFUN F1 (X) X)
   (ENCAPSULATE NIL
                (LOCAL (DEFTHM HACK (EQUAL (CAR (CONS X Y)) X))))
   (ENCAPSULATE NIL
                (LOCAL (DEFTHM HACK (EQUAL (+ X Y) (+ Y X)))))
   (MAKE-EVENT '(DEFUN F2 (X) X))
   (DEFTHM FOO (EQUAL X X)
           :RULE-CLASSES NIL))

  Failed event:

  (DEFUN F3 (X) Y)
  ACL2 !>
  ~ev[]

  ~c[Redo-flat] uses a scheme that should not cause spurious name conflicts for
  ~ilc[local] events.  Above, it is mentioned that events are ``flattened'';
  now we clarify this notion.  Each sub-event that succeeds and is an
  ~ilc[encapsulate] or ~ilc[progn] is left intact.  Only such events that fail
  are replaced by their component events.  Thus, in the example above, there is
  no conflict between the two ~ilc[local] sub-events named ``~c[hack],''
  because these are contained in successful ~c[encapsulate] sub-events, which
  are therefore not flattened.  The ~ilc[progn] and two ~ilc[encapsulate]
  events surrounding the definition of ~c[f3] are, however, flattened, because
  that definition failed to be admitted.

  Normally, ~c[redo-flat] will have the desired effect even if you interrupted
  a proof (with control-c).  However, ~c[redo-flat] will not produce the
  desired result after an interrupt if you have enabled the debugger using
  ~c[(set-debugger-enable t)],~/~/"

  `(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)))))))))))

(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 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 :do-not-install.  If the former, then that alist is installed as the
; acl2-defaults-table (if it is not already there) after executing the events
; in ev-lst.

; 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, so the
; value returned for 'encapsulate-pass-2 is the cons of that expansion-alist
; with 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))

; 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) wrld1))
                       (t wrld1)))))
    (let ((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 expansion-alist-and-final-kpa state)
               (state-global-let*
                ((current-package pkg)
                 (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))
                (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 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)
                                   (f-get-global 'in-local-flg state)
                                   nil make-event-chk
                                   (cond ((eq caller 'certify-book) kpa)
                                         (t nil))
                                   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 (eq acl2-defaults-table :do-not-install)
                                (value nil)
                              (maybe-install-acl2-defaults-table
                               acl2-defaults-table state))
                            (value (cons 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 (cons (car expansion-alist-and-final-kpa)
                                       proto-wrld3)))
                         ((eq caller 'certify-book)
                          (value expansion-alist-and-final-kpa))
                         (t (value
                             (car expansion-alist-and-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)
        ((logicalp (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 (getprop (car fns) 'justification nil 'current-acl2-world
                             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 constraints-list (fns wrld acc seen)
  (cond ((endp fns) acc)
        (t (mv-let
            (name x)
            (constraint-info (car fns) wrld)
            (cond ((eq x *unknown-constraints*)
                   *unknown-constraints*)
                  (name (cond ((member-eq name seen)
                               (constraints-list (cdr fns) wrld acc seen))
                              (t (constraints-list (cdr fns)
                                                   wrld
                                                   (union-equal x acc)
                                                   (cons name seen)))))
                  (t (constraints-list (cdr fns) wrld (cons x acc) seen)))))))

(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 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

; (getprop 'foo-witness 'constraint-lst nil 'current-acl2-world (w state))

; you'll see a much simpler result, with return-last calls removed, than if we
; did not apply remove-guard-holders-lst here.

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

(defun new-dependent-clause-processors (new-tbl old-tbl)

; New-tbl and old-tbl are values of the trusted-clause-processor-table.  We
; return a list of all dependent clause-processors from new-tbl that are not
; identically specified in old-tbl.

  (cond ((endp new-tbl)
         nil)
        ((and (cddr (car new-tbl)) ; dependent case
              (not (equal (car new-tbl)
                          (assoc-eq (caar new-tbl) old-tbl))))
         (cons (caar new-tbl)
               (new-dependent-clause-processors (cdr new-tbl)
                                                old-tbl)))
        (t (new-dependent-clause-processors (cdr new-tbl)
                                            old-tbl))))

(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 (getprop (car names) 'constrainedp nil
                            'current-acl2-world 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 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

; * 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 the value returned is an expansion-alist
; mapping, 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 five values, but we would
; rather use the standard state and error primitives and so it returns three.

  (let* ((wrld1 (w state))
         (saved-trusted-clause-processor-table
          (table-alist 'trusted-clause-processor-table wrld1)))
    (er-let* ((expansion-alist-and-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.

; (make-event '(encapsulate ()
;               (make-event '(defun test3 (x) (cons x x))))
;             :check-expansion t)

; This event has the following expansion (eliding uninteresting parts with #).

; (record-expansion #
;  (make-event '(encapsulate ()
;                (make-event '(defun test3 (x) (cons x x))))
;              :check-expansion
;              (encapsulate ()
;               (record-expansion #
;                (defun test3 (x) (cons x x))))))

; The outermost make-event will initially expand the value of the quoted
; expression after it, yielding this expansion.

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

; When this encapsulate skips its first pass, it will encounter the indicated
; make-event, which has no expansion.

                                         (not only-pass-p) ; make-event-chk
                                         ctx state))))
             (let* ((expansion-alist (car expansion-alist-and-proto-wrld3))
                    (proto-wrld3 (cdr expansion-alist-and-proto-wrld3))
                    (wrld (w state))
                    (new-trips (new-trips wrld proto-wrld3 nil nil))
                    (exported-names (exported-function-names new-trips))
                    (trusted-clause-processor-table
                     (table-alist 'trusted-clause-processor-table (w state)))
                    (new-dependent-cl-procs
                     (and insigs ; else cl-procs belong to a parent encapsulate
                          (not (equal ; optimization
                                trusted-clause-processor-table
                                saved-trusted-clause-processor-table))
                          (new-dependent-clause-processors
                           trusted-clause-processor-table
                           saved-trusted-clause-processor-table))))
               (cond
                ((and new-dependent-cl-procs
                      exported-names)
                 (er soft ctx
                     "A dependent clause-processor that has a promised ~
                      encapsulate (partial theory) must introduce only the ~
                      functions listed in that encapsulate's signature.  ~
                      However, the dependent clause-processor ~x0 is ~
                      introduced with an encapsulate whose signature's list ~
                      of names, ~x1, is missing the function name~#2~[~/s~] ~
                      ~&2 that is also introduced by that encapsulate.  See ~
                      :DOC define-trusted-clause-processor."
                     (car new-dependent-cl-procs)
                     (strip-cars insigs)
                     exported-names))
                ((and expansion-alist (not only-pass-p))
                 (value (er hard ctx
                            "Implementation error: Unexpected expansion-alist ~
                             ~x0 for second pass of encapsulate.  Please ~
                             contact the ACL2 implementors."
                            expansion-alist)))
                ((null insigs)
                 (value (if only-pass-p
                            expansion-alist
                          (list nil nil exported-names))))
                (new-dependent-cl-procs ; so (not exported-names) by test above
                 (let* ((sig-fns (strip-cars insigs))
                        (state
                         (set-w 'extension
                                (putprop-constraints
                                 (car sig-fns)
                                 (cdr sig-fns)
                                 *unknown-constraints*
                                 (car new-dependent-cl-procs)
                                 wrld)
                                state)))
                   (value (if only-pass-p
                              expansion-alist
                            (list sig-fns
                                  *unknown-constraints*
                                  new-dependent-cl-procs
                                  nil
                                  nil)))))
                (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 nil nil))
                        (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* ((wrld2 (putprop-constraints
                                   (car sig-fns)
                                   (remove1-eq (car sig-fns)
                                               constrained-fns)
                                   constraints
                                   nil
                                   (if constrained-fns
                                       (assert$
                                        (subsetp-eq subversive-fns
                                                    constrained-fns)
                                        (assert$
                                         (subsetp-eq infectious-fns
                                                     constrained-fns)
                                         (putprop-x-lst1 constrained-fns
                                                         'siblings
                                                         constrained-fns
                                                         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 that encapsulate event: ~&0."
                            bogus-exported-compliants))
                       (t (value (if only-pass-p
                                     expansion-alist
                                   (list constrained-fns
                                         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
;   (getprop 'p 'constraint-lst nil 'current-acl2-world (w state))
;   '((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
;   (getprop 'p 'constraint-lst nil 'current-acl2-world (w state))
;   '((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 (getprop 'p 'constraint-lst nil 'current-acl2-world (w state))
;              '((integerp (p x))))
;       (equal (getprop 'mapp 'constraint-lst nil 'current-acl2-world (w state))
;              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 (getprop 'p 'constraint-lst nil 'current-acl2-world (w state))
; ; 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 (getprop 'bad 'constraint-lst nil 'current-acl2-world (w state))
;              '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 (getprop 'p 'constraint-lst nil 'current-acl2-world (w state))
;         '((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 (getprop 'p 'constraint-lst nil 'current-acl2-world (w state))
;              '((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 (getprop 'mapp 'constraint-lst nil 'current-acl2-world (w state))
;              '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 (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 'bad2 'induction-machine nil
;                       'current-acl2-world (w state))
;              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
                                                           clause-processors
                                                           wrld)

; The clause-processors argument is ignored unless constraints is
; *unknown-constraints*.

  (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 "An unknown constraint is associated with ~#0~[the function~/both ~
           of the functions~/every one of the functions~] ~&1.  Note that ~
           this encapsulate introduces dependent clause processor~#2~[~/s~] ~
           ~&2.~|~%"
          (let ((n (length constrained-fns)))
            (case n
              (1 0)
              (2 1)
              (otherwise 2)))
          constrained-fns
          clause-processors)))
   (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.

; In the case that constrained-fns is *unknown-constraints*, exported-names is
; actually the list of dependent clause-processors designated by the
; encapsulate.

  (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
                              exported-names 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 definitional equation~#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 definition~/these ~
                         definitions~] out of the encapsulation.  A ~
                         constraint containing a definitional equation is ~
                         often hard to use in subsequent functional ~
                         instantiations.  See :DOC subversive-recursions for ~
                         a discussion of related issues."
                        infectious-fns)
            state))))))

(mutual-recursion

(defun find-first-non-local-name (x)

; 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.

           (('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))
           (('mutual-recursion ('defun name . &) . &) name)
           (('progn . ev-lst)
            (find-first-non-local-name-lst ev-lst))

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

           ((sym . lst)
            (and (member-eq sym '(skip-proofs
                                  with-output
                                  with-prover-step-limit
                                  with-prover-time-limit))
                 (find-first-non-local-name (car (last lst)))))

           (& nil))))
    (and (symbolp val)
         val)))

(defun find-first-non-local-name-lst (lst)

; 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) nil)
        (t (or (find-first-non-local-name (car lst))
               (find-first-non-local-name-lst (cdr lst))))))

)

(defun corresponding-encap-events (old-evs new-evs ans)
  (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) ans))
              ((and (eq (car old-ev) 'record-expansion)
                    (equal (cadr old-ev) new-ev))
               (corresponding-encap-events (cdr old-evs) (cdr new-evs)
                                           :expanded))
              ((equal (mv-let (changedp x)
                              (elide-locals-rec old-ev t)
                              (declare (ignore changedp))
                              x)
                      (mv-let (changedp y)
                              (elide-locals-rec new-ev t)
                              (declare (ignore changedp))
                              y))
               (corresponding-encap-events (cdr old-evs) (cdr new-evs)
                                           :expanded))
              (t nil))))))

(defun corresponding-encaps (old new)
  (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) t))))

(defun redundant-encapsulate-tuplep (event-form mode ruler-extenders vge
                                                event-number wrld)

; 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.

  (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))))
                (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)
                        (if (eq equal? :expanded)
                            old-event-form
                          t)))))))
        (t (redundant-encapsulate-tuplep event-form mode ruler-extenders vge
                                         event-number (cdr wrld)))))

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

; We wish to know if is there an event-tuple in wrld that has event-form as its
; form.  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 equals
; the corresponding form of the old encapsulate or else, roughly speaking, does
; so before expansion of the old form -- see corresponding-encaps), then the
; event is redundant.  Otherwise, if this correspondence test fails or if we
; can't even find a name -- e.g., because signatures is nil and all the events
; in ev-lst are user macros -- then we suffer the search through wrld.  How bad
; is this?  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
                              (getprop name 'absolute-event-number 0
                                       'current-acl2-world 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)))
             (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))
                 (if (eq equal? :expanded)
                     old-event-form
                   t))))))))
   (t (let ((name (find-first-non-local-name-lst ev-lst)))
        (and (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
                     (getprop name 'absolute-event-number nil
                              'current-acl2-world wrld))
                wrld)))))))

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

; A1 and a2 are known-package-alists.  Return the result of marking each
; package-entry in a1 that is missing in a2 with hidden-p equal to t.

  (cond ((endp a1) nil)
        ((or (find-package-entry (package-entry-name (car a1)) a2)
             (package-entry-hidden-p (car a1)))
         (cons (car a1)
               (mark-missing-as-hidden-p (cdr a1) a2)))
        (t (cons (change-package-entry-hidden-p (car a1) t)
                 (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 moveover, 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 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.  The known-package-alist of wrld may be missing some
; package-entries from pass1-k-p-alist 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.

; 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 moveover 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.

  (let ((pass2-k-p-alist (global-val 'known-package-alist wrld)))
    (cond ((equal pass1-k-p-alist pass2-k-p-alist) ; optimize for a common case
           wrld)
          (t (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)
         (cond ((endp alist) nil)
               (t
                (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 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-x nil stobjs-in))
              (stobj-terms (stobj-recognizer-terms stobjs wrld)))
         (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
                                                          (list tguard))))
                                 (t (conjoin stobj-terms)))
                           *t* wrld-acc)
           wrld ctx state)))))))

(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))
        ((getprop (car names) 'absolute-event-number nil 'current-acl2-world
                  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)
        ((getprop (car names) 'absolute-event-number nil 'current-acl2-world
                  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 ((getprop (if (symbolp namex) namex (car namex))
                     'absolute-event-number
                     nil 'current-acl2-world 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 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
     (if (output-in-infixp state) event-form ctx)
     (let* ((wrld1 (w state))
            (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)))
          (cond
           (r
            (pprogn
             (if (eq r t)
                 state
               (f-put-global 'last-make-event-expansion r state))
             (stop-redundant-event
              ctx state
              (and (not (eq r t))
                   "(This event is redundant with a previous encapsulate ~
                    event even though the two are not 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))
                   (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 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)))
                   (pprogn
                    (print-encapsulate-msg2 insigs ev-lst state)
                    (er-progn
                     (chk-acceptable-encapsulate2 insigs kwd-value-list-lst
                                                  wrld2 ctx state)
                     (let* ((pass1-known-package-alist
                             (global-val 'known-package-alist wrld2))
                            (new-ev-lst
                             (subst-by-position expansion-alist ev-lst 0))
                            (state (set-w 'retraction wrld1 state)))
                       (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)))
                        (let ((wrld3 (w state))
                              (constrained-fns (nth 0 temp))
                              (constraints-introduced (nth 1 temp))
                              (exports (nth 2 temp))
                              (subversive-fns (nth 3 temp))
                              (infectious-fns (nth 4 temp))
                              (new-event-form
                               (and expansion-alist
                                    (list* 'encapsulate signatures
                                           new-ev-lst))))
                          (pprogn
                           (print-encapsulate-msg3
                            ctx insigs new-ev-lst exports
                            constrained-fns constraints-introduced
                            subversive-fns infectious-fns wrld3 state)
                           (f-put-global 'last-make-event-expansion
                                         new-event-form
                                         state)
                           (er-let*
                            ((wrld3a (intro-udf-guards 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
                             t
                             (or new-event-form event-form)
                             'encapsulate
                             (strip-cars insigs)
                             nil nil
                             t
                             ctx
                             (let* ((wrld4 (encapsulate-fix-known-package-alist
                                            pass1-known-package-alist
                                            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))))
                               wrld9)
                             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))
                   (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-alist
                   (encapsulate-pass-2
                    insigs kwd-value-list-lst ev-lst saved-acl2-defaults-table
                    t ctx state)))
                 (let ((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)
                    (er-let*
                     ((wrld3a (intro-udf-guards 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 t
                                    (if expansion-alist
                                        new-event-form
                                      event-form)
                                    'encapsulate
                                    (strip-cars insigs)
                                    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))))))))))))))))

(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
      (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
         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 (er soft ctx
                       "~x0 failed!~@1"
                       (if progn!p 'progn! 'progn)
                       (if (and progn!p
                                (consp erp))
                           (msg "  Note that the ~n0 form evaluated to a ~
                                 multiple value (mv erp ...) with non-nil ~
                                 erp, ~x1; see :DOC progn!."
                                (list (1+ val))
                                (car erp))
                         "")))
              (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)))))))))))

(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)))

(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)

; We assume that this is executed under a revert-world-on-error, so that we do
; not have to protect the world here.  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 (cons val new-kpa)), where new-kpa is the
; known-package-alist immediately after form is evaluated; and if not, we
; return a soft error.

  (let ((original-wrld (w state)))
    (protect-system-state-globals
     (er-let*
      ((result

; 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.

        (trans-eval 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 expansion of a make-event form must either return a ~
                    single ordinary value or else should return a tuple (mv ~
                    erp val state stobj1 stobj2 ... stobjk) for some k >= 0.  ~
                    But the shape of ~x0 is ~x1."
                   form
                   (prettyify-stobjs-out stobjs-out)))
              ((stringp (car vals))
               (er soft ctx
                   (car vals)))
              ((tilde-@p (car vals)) ; a message
               (er soft ctx
                   "~@0"
                   (car vals)))
              ((car vals)
               (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 (form on-behalf-of state)
  (cond
   ((null (f-get-global 'make-event-debug state))
    (value nil))
   (t
    (let ((depth (f-get-global 'make-event-debug-depth state)))
      (pprogn (fms "~x0> Expanding for MAKE-EVENT~@1~|  ~y2~|"
                   (list (cons #\0 depth)
                         (cons #\1 (if on-behalf-of
                                       (msg " on behalf of~|  ~Y01:"
                                            on-behalf-of
                                            (term-evisc-tuple nil state))
                                     ":"))
                         (cons #\2 form))
                   (proofs-co state) state nil)
              (value depth))))))

(defun make-event-debug-post (debug-depth expansion0 state)
  (cond ((null debug-depth) state)
        (t
         (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))))

(defmacro do-proofs? (do-proofsp form)
  `(if ,do-proofsp
       (state-global-let*
        ((ld-skip-proofsp nil))
        ,form)
     ,form))

(table acl2-system-table nil nil

; 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))

(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
               (chk-embedded-event-form
                expansion0 whole-form wrld ctx state (primitive-event-macros)
                nil ; portcullisp
                (f-get-global 'in-local-flg state)
                in-encapsulatep
                nil))) 
             (expansion1
              (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
               (trans-eval

; Note that expansion1 is guaranteed to be an embedded event form, which (as
; checked just below) must evaluate to an error triple.

                expansion1
                ctx state t))))
     (let ((raw-result (cdr stobjs-out-and-raw-result)))
       (cond ((car raw-result)
              (silent-error state))
             (t (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 wrld ctx state)
  (cond ((atom expansion-lst)
         (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 wrld ctx state))
                   (t (value val))))))))

(defun make-event-fn1 (expansion0 whole-form in-encapsulatep check-expansion
                                  wrld ctx state)
  (cond ((and (consp expansion0)
              (eq (car expansion0) :OR))
         (make-event-fn2-lst (cdr expansion0)
                             whole-form in-encapsulatep check-expansion
                             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 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))

; 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).  ~
            Expansion for make-event of the form ~x0 is thus not allowed.  ~
            The use of a .acl2x file can sometimes solve this problem.  See ~
            :DOC provisional-certification."
           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
        (state-global-let*
         ((make-event-debug-depth (1+ (f-get-global 'make-event-debug-depth
                                                    state))))
         (let ((wrld (w state)))
           (er-let*
               ((debug-depth (make-event-debug-pre form on-behalf-of state))
                (expansion0/new-kpa/new-ttags-seen
                 (cond
                  ((and expansion?
                        (eq (ld-skip-proofsp state) 'include-book)

; 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))
                    (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)))
                (new-ttags-p
                 (pprogn
                  (make-event-debug-post debug-depth expansion0 state)
                  (cond ((equal new-ttags-seen
                                (global-val 'ttags-seen wrld))
                         (value nil))
                        (t (pprogn
                            (set-w! (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 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 appropropriate, 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 portullis 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)))
                           (pprogn
                            (f-put-global 'last-make-event-expansion
                                          actual-expansion
                                          state)
                            (cond
                             ((f-get-global 'make-event-debug state)
                              (fms "Saving make-event replacement into state ~
                                    global 'last-make-event-expansion (debug ~
                                    level ~x0):~|~Y12"
                                   (list (cons #\0 debug-depth)
                                         (cons #\1 actual-expansion)
                                         (cons #\2 (abbrev-evisc-tuple state)))
                                   (proofs-co state)
                                   state
                                   nil))
                             (t state))
                            (er-progn
                             (cond ((and new-ttags-p ; optimization
                                         (let ((wrld1 (w state)))
                                           (not (and (eq (caar wrld1)
                                                         'event-landmark)
                                                     (eq (cadar wrld1)
                                                         'global-value)))))

; We lay down an event landmark.  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))))

; A cheap way to get an event landmark is with a table event, so that's what we
; do.  The table-fn call below is the macroexpansion of:

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

                                    (state-global-let*
                                     ((inhibit-output-lst
                                       (add-to-set-eq
                                        'summary
                                        (f-get-global 'inhibit-output-lst
                                                      state))))
                                     (TABLE-FN
                                      'ACL2-SYSTEM-TABLE
                                      '('EMPTY-EVENT-KEY
                                        (NOT (CDR (ASSOC-EQ 'EMPTY-EVENT-KEY
                                                            (TABLE-ALIST
                                                             'ACL2-SYSTEM-TABLE
                                                             WORLD)))))
                                      STATE
                                      '(TABLE ACL2-SYSTEM-TABLE 'EMPTY-EVENT-KEY
                                              (NOT (CDR (ASSOC-EQ
                                                         'EMPTY-EVENT-KEY
                                                         (TABLE-ALIST
                                                          'ACL2-SYSTEM-TABLE
                                                          WORLD))))))))
                                   (t (value nil)))
                             (value result))))))))))))))))))

; 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
; onesself.  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: 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.)

; 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 *directory-separator*
;    #+apple #\:
;    #-apple #\/)

; because then we could certify a book in one ACL2 that contains a theorem
; (equal *directory-separator* #\/), 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.

(deflabel books
  :doc
  ":Doc-Section  Books

  files of ACL2 event forms~/

  This ~il[documentation] topic is about ACL2 input files.  However, there are
  two traditional (paper) books published about ACL2: a textbook and a case
  studies book.  Further information on those two paper books is available by
  following links from the ACL2 home page,
  ~url[http://www.cs.utexas.edu/users/moore/acl2/].

  A ``book'' is a file of ACL2 ~il[events] that have been certified as
  admissible.  Using ~ilc[include-book] you can construct a new logical
  ~il[world] by assuming the ~il[events] in any number of mutually compatible
  books.  Relevant documented topics are listed below.  Following this list
  is a ``guided tour'' through the topics.
  ~terminal[You may start the guided tour by typing :more.]

  You can contribute books to the ACL2 community and obtain updates inbetween
  ACL2 releases by visiting the ~c[acl2-books] project web page,
  ~url[http://acl2-books.googlecode.com/].  Also ~pl[community-books].~/

  ~em[Introduction.]

  A ``book'' is a file of ACL2 forms.  Books are prepared entirely by
  the user of the system, i.e., they are ``source'' files not
  ``object'' files.  Some of the forms in a book are marked ~ilc[local]
  and the others are considered ``non-local.''

  ~ilc[Include-book] lets you load a book into any ACL2 ~il[world].  If
  completed without error, the inclusion of a book extends the logic
  of the host ~il[world] by the addition of just the non-local ~il[events] in
  the book.  You may extend the ~il[world] by successively including a
  variety of books to obtain the desired collection of definitions and
  rules.  Unless name conflicts occur (which are detected and
  signalled) inclusion of a book is consistency preserving provided
  the book itself is consistent as discussed later.  However,
  ~ilc[include-book] merely assumes the validity of the ~il[events] in a book;
  if you include a book that contains an inconsistency (e.g., an
  inadmissible definition) then the resulting theory is inconsistent.

  It is possible to ``certify'' a book, with ~ilc[certify-book],
  guaranteeing that the error-free inclusion of the certified forms
  will produce a consistent extension of a consistent logic.
  Certification processes both the ~ilc[local] and non-local forms, so
  you can mark as ~ilc[local] those ~il[events] you need for certification
  that you want to hide from users of the book (e.g., hacks, crocks,
  and kludges on the way to a good set of ~c[:]~ilc[rewrite] rules).
  Certification can also ``compile'' a book, thereby speeding up the
  execution of the functions defined within it.  The desire to compile
  books is largely responsible for the restrictions we put on the
  forms allowed in books.

  Extensive ~il[documentation] is available on the various aspects of
  books.  We recommend that you read it all before using books.  It
  has been written so as to make sense when read in a certain linear
  sequence, called the ``guided tour'', though in general you may
  browse through it randomly.  If you are on the guided tour, you
  should next read the ~il[documentation] on book-example
  (~pl[book-example]~terminal[ and use :more to read through it]).~/

  :cite include-book")

(link-doc-to certifying-books books books-certification)
(link-doc-to book-makefiles books books-certification)

(deflabel community-books
  :doc
  ":Doc-Section  Books

  ~il[books] contributed by the ACL2 community~/

  For background on ACL2 books, which can contain useful definitions and
  theorems, ~pl[books].

  The ACL2 ``community books'' is a collection of books developed since the
  early 1990s by members of the ACL2 community.  The installation instructions
  suggest installing these books in the ~c[books/] subdirectory of your local
  ACL2 installation.  You can contribute books to the ACL2 community and obtain
  updates inbetween ACL2 releases by visiting the ~c[acl2-books] project web
  page, ~url[http://acl2-books.googlecode.com/].

  To certify the community books, ~pl[regression].~/~/")

(defun chk-book-name (book-name full-book-name ctx state)

; Book-name is something submitted by the user as a book name.
; Full-book-name is the first result of calling parse-book-name on
; book-name and state.  We check that full-book-name is a string
; ending in ".lisp" or cause an error.  But the error reports
; book-name as the offender.

; This check is important because to form the certification extension we strip
; off the "lisp" and replace it by "cert".  So if this is changed, change
; convert-book-name-to-cert-name and convert-book-name-to-compiled-name.

; Note: Because it is our own code, namely parse-book-name, that tacks on the
; ".lisp" extension, this check is now redundant.  Once upon a time, the user
; was expected to supply the .lisp extension, but that made the execution of
; (include-book "arith.lisp") in raw lisp load the .lisp file rather than the
; .o file.  We've left the redundant check in because we are not sure that
; parse-book-name will be kept in its current form; it has changed a lot
; lately.

  (cond
   ((and (stringp full-book-name)
         (let ((n (length full-book-name)))
           (and (> n 5)
                (eql (char full-book-name (- n 5)) #\.)
                (eql (char full-book-name (- n 4)) #\l)
                (eql (char full-book-name (- n 3)) #\i)
                (eql (char full-book-name (- n 2)) #\s)
                (eql (char full-book-name (- n 1)) #\p))))
    (value nil))
   ((null full-book-name)
    (er soft ctx
        "~x0 is not a legal book name.  See :DOC book-name."
        book-name))
   (t (er soft ctx
          "~x0 is not a legal book name because it does not specify the ~
           ``.lisp'' extension.  See :DOC book-name."
          book-name))))

; 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"
;  user-book-name     ; "project/arith.lisp"
;  familiar-name      ; "arith"
;  cert-annotations   ; ((:SKIPPED-PROOFSP . sp)
;                        (:AXIOMSP . axp)
;                        (:TTAGS . ttag-alistp))
;  . ev-lst-chk-sum)  ; 12345678

; 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 chk-sum entry is nil.

; 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 . chk-sum) 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 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 ((form
           (or (access-command-tuple-last-make-event-expansion (cddar wrld))
               (access-command-tuple-form (cddar wrld))))
          (cbd (access-command-tuple-cbd (cddar wrld))))
      (cond ((equal form '(exit-boot-strap-mode))
             (mv nil cmds cbds state))
            (t (mv-let
                (erp val state)
                (chk-embedded-event-form form nil
                                         wrld ctx state names t nil nil t)
                (declare (ignore val))
                (cond
                 (erp (mv erp nil nil state))
                 (t
                  (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))))

(defun remove-after-last-directory-separator (p)
  (let* ((p-rev (reverse p))
         (posn (position *directory-separator* p-rev)))
    (if posn
        (subseq p 0 (1- (- (length p) posn)))
      (er hard 'remove-after-last-directory-separator
          "Implementation error!  Unable to handle a directory string."))))

(defun merge-using-dot-dot (p s)

; P is a directory pathname without the final "/".  S is a pathname (for a file
; or a directory) that may start with any number of sequences "../" and "./".
; We want to "cancel" the leading "../"s in s against directories at the end of
; p, and eliminate leading "./"s from s (including leading "." if that is all
; of s).  The result should syntactically represent a directory (end with a "/"
; or "."  or be "") if and only if s syntactically represents a directory.

; This code is intended to be simple, not necessarily efficient.

  (cond
   ((equal p "") s)
   ((equal s "..")
    (concatenate 'string
                 (remove-after-last-directory-separator p)
                 *directory-separator-string*))
   ((equal s ".")
    (concatenate 'string
                 p
                 *directory-separator-string*))
   ((and (>= (length s) 3)
         (eql (char s 0) #\.)
         (eql (char s 1) #\.)
         (eql (char s 2) #\/))
    (merge-using-dot-dot (remove-after-last-directory-separator p)
                         (subseq s 3 (length s))))
   ((and (>= (length s) 2)
         (eql (char s 0) #\.)
         (eql (char s 1) #\/))
    (merge-using-dot-dot p (subseq s 2 (length s))))
   (t
    (concatenate 'string p *directory-separator-string* s))))

(defun our-merge-pathnames (p s)

; This is something like the Common Lisp function merge-pathnames.  P and s are
; (Unix-style) pathname strings, where s is a relative pathname.  (If s may be
; an absolute pathname, use extend-pathname instead.)  We allow p to be nil,
; which is a case that arises when p is (f-get-global 'connected-book-directory
; state) during boot-strapping; otherwise p should be an absolute directory
; pathname (though we allow "" as well).

  (cond
   ((and (not (equal s ""))
         (eql (char s 0) *directory-separator*))
    (er hard 'our-merge-pathnames
        "Attempt to merge with an absolute filename, ~p0.  Please contact the ~
         ACL2 implementors."
        s))
   ((or (null p) (equal p ""))
    s)
   ((stringp p) ; checked because of structured pathnames before Version_2.5
    (merge-using-dot-dot
     (if (eql (char p (1- (length p)))
              *directory-separator*)
         (subseq p 0 (1- (length p)))
       p)
     s))
   (t
    (er hard 'our-merge-pathnames
        "The first argument of our-merge-pathnames must be a string, ~
         but the following is not:  ~p0."
        p))))

(defun expand-tilde-to-user-home-dir (str os ctx state)

; Note that character `~' need not get special treatment by Windows.  See
; comment just above error message below, and see absolute-pathname-string-p.

  (cond ((or (equal str "~")
             (and (< 1 (length str))
                  (eql (char str 0) #\~)
                  (eql (char str 1) #\/)))
         (let ((user-home-dir (f-get-global 'user-home-dir state)))
           (cond
            (user-home-dir
             (concatenate 'string
                          user-home-dir
                          (subseq str 1 (length str))))
            (t

; On Linux or Mac OS, it is surprising to find that user-home-dir is nil.  (See
; the definition of lp to see how it is set.)  But on Windows, it seems that
; this could be the case, say outside an environment like Cygwin, MSYS, or
; MinGW.

             (let ((certify-book-info (f-get-global 'certify-book-info state)))
               (prog2$ (and (or certify-book-info
                                (not (eq os :mswindows)))
                            (er hard ctx
                                "The use of ~~/ for the user home directory ~
                                 in filenames is not supported ~@0."
                                (if certify-book-info
                                    "inside books being certified"
                                  "for this host Common Lisp")))
                       str))))))
        (t str)))

#-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)

; 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)))
    (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)
                              (eq (car dir)
                                  #+gcl :ROOT
                                  #-gcl :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)))))))))))

(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))

(defun acl2-magic-canonical-pathname (x)

; This function is a sort of placeholder, used in a
; define-trusted-clause-processor event for noting that canonical-pathname has
; unknown constraints.

  (declare (xargs :guard t))
  (list x))

#+acl2-loop-only
(encapsulate
 ()
 (define-trusted-clause-processor
   acl2-magic-canonical-pathname
   (canonical-pathname)
   :partial-theory
   (encapsulate
    (((canonical-pathname * * state) => *))
    (logic)
    (local (defun canonical-pathname (x dir-p state)
             (declare (xargs :mode :logic))
             (declare (ignore dir-p state))
             (if (stringp x) x nil)))
    (defthm canonical-pathname-is-idempotent
      (equal (canonical-pathname (canonical-pathname x dir-p state) dir-p state)
             (canonical-pathname x dir-p state)))
    (defthm canonical-pathname-type
      (or (equal (canonical-pathname x dir-p state) nil)
          (stringp (canonical-pathname x dir-p state)))
      :rule-classes :type-prescription))))

(defdoc canonical-pathname
  ":Doc-Section ACL2::ACL2-built-ins

  the true absolute filename, with soft links resolved~/

  For the name ~c[fname] of a file, the form
  ~c[(Canonical-pathname fname nil state)] evaluates to a Unix-style absolute
  filename representing the same file as ~c[fname], but generally without any
  use of soft links in the name.  (Below, we explain the qualifier
  ``generally''.)  If however the file indicated by ~c[fname] does not exist,
  ~c[(canonical-pathname fname nil state)] is ~c[nil].  Thus,
  ~c[canonical-pathname] can be used as one would use the raw Lisp function
  ~c[probe-file].

  The specification of ~c[(Canonical-pathname fname dir-p state)] when
  ~c[dir-p] is not ~c[nil] is simlar, except that if the specified file exists
  but is not a directory, then the result is ~c[nil].~/

  The function ~c[canonical-pathname] has a guard of ~c[t], though the second
  argument must be the ACL2 ~ilc[state].  This function is introduced with the
  following properties.
  ~bv[]
  (defthm canonical-pathname-is-idempotent
    (equal (canonical-pathname (canonical-pathname x dir-p state) dir-p state)
           (canonical-pathname x dir-p state)))
  (defthm canonical-pathname-type
    (or (equal (canonical-pathname x dir-p state) nil)
        (stringp (canonical-pathname x dir-p state)))
    :rule-classes :type-prescription)
  ~ev[]

  We use the qualifier ``generally'', above, because there is no guarantee that
  the filename will be canonical without soft links, though we expect this to
  be true in practice.  ACL2 attempts to compute the desired result and then
  checks that the input and result have the same Common Lisp ``~c[truename]''.
  This check is expected to succeed, but if it fails then the input string is
  returned unchanged, and to be conservative, the value returned is ~c[nil] in
  this case if ~c[dir-p] is true.")

(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 (dir file-name state)

; Dir is a string representing an absolute directory name, and file-name is a
; string representing a file or directory name.  We want to extend dir by
; file-name if subdir is relative, and otherwise return file-name.  Except, we
; return something canonical, if possible.

  (let* ((os (os (w state)))
         (file-name1 (expand-tilde-to-user-home-dir
                      file-name os 'extend-pathname state))
         (abs-filename (cond
                        ((absolute-pathname-string-p file-name1 nil os)
                         file-name1)
                        (t
                         (our-merge-pathnames dir file-name1))))
         (canonical-filename (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.

        (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 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-fn (str state)
  (let ((os (os (w state)))
        (ctx (cons 'set-cbd str)))
    (cond
     ((not (stringp str))
      (er soft ctx
          "The argument of set-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)
            (assign connected-book-directory
                    (canonical-dirname! (maybe-add-separator str)
                                        ctx
                                        state)))
           ((not (absolute-pathname-string-p
                  (f-get-global 'connected-book-directory state)
                  t
                  os))
            (er soft ctx
                "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
            (assign connected-book-directory
                    (canonical-dirname!
                     (maybe-add-separator
                      (our-merge-pathnames
                       (f-get-global 'connected-book-directory state)
                       str))
                     ctx
                     state)))))))))

(defmacro set-cbd (str)

  ":Doc-Section books

  to set the connected book directory~/
  ~bv[]
  Example Forms:
  ACL2 !>:set-cbd \"/usr/home/smith/\"
  ACL2 !>:set-cbd \"my-acl2/books\"
  ~ev[]
  ~l[cbd] for a description of the connected book directory.~/
  ~bv[]
  General Form:
  (set-cbd str)
  ~ev[]

  where ~c[str] is a nonempty string that represents the desired
  directory (~pl[pathname]).  This command sets the connected book
  directory (~pl[cbd]) to the string representing the indicated
  directory.  Thus, this command may determine which files are
  processed by ~ilc[include-book] and ~ilc[certify-book] ~il[command]s typed at the
  top-level.  However, the ~ilc[cbd] is also temporarily set by those two
  book processing ~il[command]s.

  ~sc[Important]:  Pathnames in ACL2 are in the Unix (trademark of AT&T)
  style.  That is, the character ``~c[/]'' separates directory components
  of a pathname, and pathnames are absolute when they start with this
  character, and relative otherwise.  ~l[pathname]."

  `(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)))

(defun parse-book-name (dir x extension ctx state)

; This function takes a directory name, dir, and a user supplied book name, x,
; which is a string, and returns (mv full dir familiar), where full is the full
; book name string, dir is the directory name, and familiar is the familiar
; name string.  Extension is either nil or a string such as ".lisp" and the
; full book name is given the extension if it is non-nil.

; Given dir                and x with extension=".lisp"
; "/usr/home/moore/"           "nasa-t3/arith"       ; user name
; this function produces
; (mv "/usr/home/moore/nasa-t3/arith.lisp"           ; full name
;     "/usr/home/moore/nasa-t3/"                     ; directory name
;     "arith")                                       ; familiar name

; On the other hand, if x is "/usr/home/kaufmann/arith" then the result is
; (mv "/usr/home/kaufmann/arith.lisp"
;     "/usr/home/kaufmann/"
;     "arith")

; 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 and not well-formed as a structured pathname, the result
; is (mv nil nil x).  Thus, if the full name returned is nil, we know something
; is wrong and the short name returned is whatever junk the user supplied.

  (cond
   ((stringp x)
    (let* ((lst (coerce x 'list))
           (rlst (reverse lst))
           (temp (member *directory-separator* rlst)))

; If x is "project/task3/arith.lisp" then temp is "project/task3/" except is a
; list of chars and is in reverse order (!).

      (let ((familiar (coerce (reverse (first-n-ac
                                        (- (length x) (length temp))
                                        rlst nil))
                              'string))
            (dir1 (extend-pathname dir
                                   (coerce (reverse temp) 'string)
                                   state)))
        (mv (if extension
                (concatenate 'string dir1 familiar extension)
              (concatenate 'string dir1 familiar))
            dir1
            familiar))))
   (t (mv (er hard ctx
              "A book name must be a string, but ~x0 is not a string."
              x)
          nil x))))

(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
  ":Doc-Section Books

  connected book directory string~/
  ~bv[]
  Example:
  ACL2 !>:cbd
  \"/usr/home/smith/\"
  ~ev[]
  The connected book directory is a nonempty string that specifies a
  directory as an absolute pathname.  (~l[pathname] for a
  discussion of file naming conventions.)  When ~ilc[include-book] is given
  a relative book name it elaborates it into a full book name,
  essentially by appending the connected book directory string to the
  left and ~c[\".lisp\"] to the right.  (For details,
  ~pl[book-name] and also ~pl[full-book-name].)  Furthermore,
  ~ilc[include-book] temporarily sets the connected book directory to the
  directory string of the resulting full book name so that references
  to inferior ~il[books] in the same directory may omit the directory.
  ~l[set-cbd] for how to set the connected book directory string.~/
  ~bv[]
  General Form:
  (cbd)
  ~ev[]
  This is a macro that expands into a term involving the single free
  variable ~ilc[state].  It returns the connected book directory string.

  The connected book directory (henceforth called the ``~c[cbd]'') is
  used by ~ilc[include-book] to elaborate the supplied book name into a
  full book name (~pl[full-book-name]).  For example, if the ~c[cbd]
  is ~c[\"/usr/home/smith/\"] then the elaboration of the ~il[book-name]
  ~c[\"project/task-1/arith\"] (to the ~c[\".lisp\"] extension) is
  ~c[\"/usr/home/smith/project/task-1/arith.lisp\"].  That
  ~il[full-book-name] is what ~il[include-book] opens to read the
  source text for the book.

  The ~c[cbd] may be changed using ~ilc[set-cbd] (~pl[set-cbd]).
  Furthermore, during the processing of the ~il[events] in a book,
  ~ilc[include-book] sets the ~c[cbd] to be the directory string of the
  ~il[full-book-name] of the book.  Thus, if the ~c[cbd] is
  ~c[\"/usr/home/smith/\"] then during the processing of ~il[events] by
  ~bv[]
  (include-book \"project/task-1/arith\")
  ~ev[]
  the ~c[cbd] will be set to ~c[\"/usr/home/smith/project/task-1/\"].
  Note that if ~c[\"arith\"] recursively includes a subbook, say
  ~c[\"naturals\"], that resides on the same directory, the
  ~ilc[include-book] event for it may omit the specification of that
  directory.  For example, ~c[\"arith\"] might contain the event
  ~bv[]
    (include-book \"naturals\").
  ~ev[]
  In general, suppose we have a superior book and several inferior
  ~il[books] which are included by ~il[events] in the superior book.  Any
  inferior book residing on the same directory as the superior book
  may be referenced in the superior without specification of the
  directory.

  We call this a ``relative'' as opposed to ``absolute'' naming.  The
  use of relative naming is preferred because it permits ~il[books]
  (and their accompanying inferiors) to be moved between directories
  while maintaining their ~il[certificate]s and utility.  Certified
  ~il[books] that reference inferiors by absolute file names are unusable
  (and rendered uncertified) if the inferiors are moved to new
  directories.

  ~em[Technical Note and a Challenge to Users:]

  After elaborating the book name to a full book name, ~ilc[include-book]
  opens a channel to the file to process the ~il[events] in it.  In some
  host Common Lisps, the actual file opened depends upon a notion of
  ``connected directory'' similar to our connected book directory.
  Our intention in always elaborating book names into absolute
  filename strings (~pl[pathname] for terminology) is to
  circumvent the sensitivity to the connected directory.  But we may
  have insufficient control over this since the ultimate file naming
  conventions are determined by the host operating system rather than
  Common Lisp (though, we do check that the operating system
  ``appears'' to be one that we ``know'' about).  Here is a question,
  which we'll pose assuming that we have an operating system that
  calls itself ``Unix.''  Suppose we have a file name, filename, that
  begins with a slash, e.g., ~c[\"/usr/home/smith/...\"].  Consider two
  successive invocations of CLTL's
  ~bv[]
  (open filename :direction :input)
  ~ev[]
  separated only by a change to the operating system's notion of
  connected directory.  Must these two invocations produce streams to
  the same file?  A candidate string might be something like
  ~c[\"/usr/home/smith/*/usr/local/src/foo.lisp\"] which includes some
  operating system-specific special character to mean ``here insert
  the connected directory'' or, more generally, ``here make the name
  dependent on some non-ACL2 aspect of the host's state.''  If such
  ``tricky'' name strings beginning with a slash exist, then we have
  failed to isolate ACL2 adequately from the operating system's file
  naming conventions.  Once upon a time, ACL2 did not insist that the
  ~c[cbd] begin with a slash and that allowed the string
  ~c[\"foo.lisp\"] to be tricky because if one were connected to
  ~c[\"/usr/home/smith/\"] then with the empty ~c[cbd] ~c[\"foo.lisp\"]
  is a full book name that names the same file as
  ~c[\"/usr/home/smith/foo.lisp\"].  If the actual file one reads is
  determined by the operating system's state then it is possible for
  ACL2 to have two distinct ``full book names'' for the same file, the
  ``real'' name and the ``tricky'' name.  This can cause ACL2 to
  include the same book twice, not recognizing the second one as
  redundant."

  `(cbd-fn state))

; 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.

(mutual-recursion

(defun make-include-books-absolute (form cbd dir names make-event-parent os ctx
                                         state)

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

; See the comment in fix-portcullis-cmds for a discussion.  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 avoids a failure to certify community book
; books/fix-cert/test-fix-cert1.lisp that initially occurred when we started
; including portcullis commands in the check-sum (with the introduction of
; function check-sum-cert, caused by the renaming of an absolute pathname in an
; include-book portcullis command.

; Form is a command from the current ACL2 world that is known to be an embedded
; event form with respect to names.  Keep this function in sync with
; chk-embedded-event-form.

; Cbd is either nil (arising from an argument of t for certify-book; see the
; corresponding call of chk-acceptable-certify-book1 in
; chk-acceptable-certify-book) or is the connected-book-directory at the
; conclusion of form, and hence (since form is an embedded event form) at the
; beginning of form.  Dir is the directory of the book being certified.  See
; the include-book case below for how these are used.

; If make-event-parent is non-nil, then it is a make-event form whose expansion
; is being considered, and we cause an error rather than converting.

  (cond
   ((atom form) (value form)) ; This should never happen.
   ((eq (car form) 'skip-proofs)
    (er-let* ((x (make-include-books-absolute
                  (cadr form) cbd dir names make-event-parent os ctx state)))
             (value (list (car form) x))))
   ((eq (car form) 'local)

; 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 here.

    (value form))
   ((eq (car form) 'progn)
    (er-let* ((rest (make-include-books-absolute-lst
                     (cdr form) cbd dir names make-event-parent os ctx state)))
             (value (cons (car form)
                          rest))))
   ((eq (car form) 'value)
    (value form))
   ((and (eq (car form) 'include-book)

; Recall that we are processing the portcullis commands for a book, bk, that is
; in the process of being certified.  We may want to ensure that form, an
; include-book form, uses an absolute pathname, so that form refers to the same
; book as when originally processed as it does when later being processed as a
; portcullis command of bk.

; Consider the normal case, where cbd is not nil.  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).

; 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.

; To summarize: 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.  We thus consider pathname conversion when both
; of those conditions fail.

         (and cbd
              (not (equal cbd dir)))

; 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.

         (assert$ (keyword-value-listp (cddr form)) ; as form is a legal event
                  (not (assoc-keyword :dir form)))
         (assert$ (stringp (cadr form)) ; as form is a legal event
                  (not (absolute-pathname-string-p
                        (cadr form)
                        nil ; no directory check necessary here
                        os))))
    (cond
     (make-event-parent

; It would be a mistake to create an absolute pathname in a case like
; (make-event '(include-book "foo") :check-expansion t), because the expansion
; check would later fail.  Instead, in such a (presumably rare) case, the user
; needs to modify the make-event form to create an absolute pathname.

      (er soft ctx
          "Each include-book form in the certification world must be given ~
           absolute pathname before it is saved in the certificate as a ~
           portcullis command.  ACL2 generally figures out a suitable ~
           absolute pathname when the pathname is relative.  But the present ~
           form, ~x0, comes from the expansion of a make-event form with ~
           (first) argument ~x1 and non-nil :check-expansion argument. ~ ~
           Consider changing this make-event form to produce an include-book ~
           with an absolute pathname instead."
          form (cadr make-event-parent)))
     (t (mv-let (full-book-name directory-name familiar-name)
                (parse-book-name cbd (cadr form) nil ctx state)
                (declare (ignore directory-name familiar-name))
                (value (list* 'include-book
                              full-book-name
                              (cddr form)))))))
   ((and (eq (car form) '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, because

; ACL2 Error in ( INCLUDE-BOOK "foo" ...):  There is no file named
; "D/SUB/foo.lisp" that can be opened for input.


         (and cbd
              (not (equal cbd dir)))
         (assert$ (stringp (caddr form)) ; as form is a legal event
                  (not (absolute-pathname-string-p
                        (caddr form)
                        nil ; no directory check necessary here
                        os))))
    (cond
     (make-event-parent
      (er soft ctx
          "Each add-include-book-dir form in the certification world must be ~
           given absolute pathname before it is saved in the certificate as a ~
           portcullis command.  ACL2 generally figures out a suitable ~
           absolute pathname when the pathname is relative.  But the present ~
           form, ~x0, comes from the expansion of a make-event form with ~
           (first) argument ~x1 and non-nil :check-expansion argument. ~ ~
           Consider changing this make-event form to produce an ~
           add-include-book-dir with an absolute pathname instead."
          form (cadr make-event-parent)))
     (t (value (list 'add-include-book-dir
                     (cadr form)
                     (extend-pathname cbd (caddr form) state))))))
   ((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.

    (value form))
   ((eq (car form) 'make-event)
    (let ((expansion (cadr (assoc-keyword :check-expansion (cddr form)))))
      (cond ((not (consp expansion))
             (er soft ctx
                 "Implementation error: we had thought that every make-event ~
                  form in the certification world would have a consp ~
                  :check-expansion field, yet we found the following.  Please ~
                  contact the ACL2 implementors.~|~x0"
                 form))
            (t (er-progn (make-include-books-absolute
                          expansion cbd dir names form os ctx state)
                         (value form))))))
   ((and (member-eq (car form) '(with-output
                                 with-prover-step-limit
                                 with-prover-time-limit))
         (consp (cdr form)))
    (er-let* ((form1 (make-include-books-absolute
                      (car (last form)) cbd dir names make-event-parent os ctx
                      state)))
             (value (append (butlast form 1) (list form1)))))
   ((getprop (car form) 'macro-body nil 'current-acl2-world (w state))
    (er-let*
     ((form1 (macroexpand1 form ctx state)))
     (make-include-books-absolute
      form1 cbd dir names make-event-parent os ctx state)))
   (t (value (er hard ctx
                 "Implementation error in make-include-books-absolute:  ~
                  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 make-event-parent
                                              os ctx state)
  (if (endp forms)
      (value nil)
    (er-let* ((first (make-include-books-absolute
                      (car forms) cbd dir names make-event-parent os ctx
                      state))
              (rest (make-include-books-absolute-lst
                     (cdr forms) cbd dir names make-event-parent os ctx
                     state)))
             (value (cons first rest)))))
)

(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)))))

(defmacro string-prefixp (root string)

; We return a result propositionally equivalent to
;   (and (<= (length root) (length string))
;        (equal root (subseq string 0 (length root))))
; but, unlike subseq, without allocating memory.

  `(search ,root ,string :start2 0))

(defun relativize-book-path (filename root)

; If the given filename is an absolute pathname extending the absolute
; directory name root, then return (:system . suffix), where suffix is a
; relative pathname that points to the same file with respect to root.

; To admit this in :logic mode with guards verified, first prove:

; (defthm coerce-to-list-is-positive-linear
;   (implies (and (not (equal filename ""))
;                 (stringp filename))
;            (< 0 (len (coerce filename 'list))))
;   :hints (("Goal"
;            :use ((:instance coerce-inverse-2
;                             (x filename)))
;            :expand ((len (coerce filename 'list)))))
;   :rule-classes :linear)

  (declare (xargs :guard (and (stringp filename)
                              (stringp root))))
  (cond ((and (stringp filename) ; could already be (:system . fname)
              (string-prefixp root filename))
         (cons :system (subseq filename (length root) nil)))
        (t filename)))

(defun relativize-book-path-lst1 (lst root)
  (declare (xargs :guard (and (string-listp lst)
                              (stringp root))))
  (cond ((endp lst) nil)
        (t (cons (relativize-book-path (car lst) root)
                 (relativize-book-path-lst1 (cdr lst) root)))))

(defun relativize-book-path-lst (lst root current)
  (declare (xargs :guard (and (string-listp lst)
                              (stringp root)
                              (stringp current))))
  (cond ((string-prefixp root current)
         (relativize-book-path-lst1 lst root))
        (t lst)))

(defun defpkg-items-rec (new-kpa old-kpa system-books-dir
                                 connected-book-directory 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 system-books-dir
            connected-book-directory 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

; We use relative pathnames when possible, to support relocation of .cert files
; (as is done as of August 2010 by Debian ACL2 release and ACL2s).

                  (relativize-book-path-lst (package-entry-book-path e)
                                            system-books-dir
                                            connected-book-directory)))
            (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 system-books-dir
                connected-book-directory 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 defpkg-items (new-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.

  (state-global-let*
   ((inhibit-output-lst (cons 'error
                              (f-get-global 'inhibit-output-lst state))))
   (defpkg-items-rec new-kpa (global-val 'known-package-alist w)
     (f-get-global 'system-books-dir state)
     (f-get-global 'connected-book-directory state)
     ctx w state 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.

  (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 system-books-dir
                                  connected-book-directory w ctx state acc)

; Warning: Keep this in sync with hidden-depkg-events-simple.

  (cond
   ((endp kpa) (value (reverse acc)))
   ((not (package-entry-hidden-p (car kpa)))
    (hidden-defpkg-events1 (cdr kpa) system-books-dir
                           connected-book-directory 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 (relativize-book-path-lst
                       (package-entry-book-path e)
                       system-books-dir
                       connected-book-directory)))
      (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)
        system-books-dir connected-book-directory 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
                          (f-get-global 'system-books-dir state)
                          (f-get-global 'connected-book-directory state)
                          w ctx state nil)))

(defun fix-portcullis-cmds1 (dir cmds cbds ans names os ctx state)
  (cond
   ((null cmds) (value ans))
   (t (er-let* ((cmd (make-include-books-absolute (car cmds) (car cbds) dir
                                                  names nil os ctx state)))
               (fix-portcullis-cmds1 dir
                                     (cdr cmds)
                                     (cdr cbds)
                                     (cons cmd ans)
                                     names os ctx state)))))

(defun fix-portcullis-cmds (dir cmds cbds names os 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.  Note that "prelude" does not represent an absolute
; pathname.  If it did represent an absolute pathname, then it would have to be
; the full book name because parse-book-name returns x when x represents an
; absolute pathname.

; 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
; of 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 added 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.

  (er-let* ((new-cmds (fix-portcullis-cmds1 dir cmds cbds nil names
                                            os ctx state))
            (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
; . ev-lst-chk-sum) and ev-lst-chk-sum is nil if the book has not been
; certified.

  (cond ((null alist) nil)
        ((null (cddddr (car alist)))  ; ev-lst-chk-sum
         (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"
                     (cadr val)
                     file
                     (tilde-*-&v-strings
                      '&
                      (strip-non-hidden-package-names
                       (known-package-alist state))
                      #\.)))))
            (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)
  (cond
   ((null warning-summary)
    (er soft ctx "~@2" file1 file2 msg))
   ((symbolp warning-summary) ; keyword
    (er soft ctx "~@0  This is illegal because we are currently attempting ~
                  certify-book or include-book with ~x1 set to NIL.  You can ~
                  avoid this error by using a value of T for ~x1; see :DOC ~
                  certify-book and see :DOC include-book."
        (list "~@2" (cons #\0 file1) (cons #\1 file2) (cons #\2 msg))
        warning-summary))
   (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)

; 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)

; We assume that all necessary packages exist so that we can read the
; certificate file for full-book-name, without errors caused by unknown package
; names in symbols occurring in the porcullis commands or make-event
; expansions.  If that assumption may not hold, consider using
; post-alist-from-pcert1 instead.

  (mv-let (eofp obj state)
          (cond ((eq y ; last object read
                     ':EXPANSION-ALIST)

; 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-name cert-op state)
  (let ((cert-name
         (convert-book-name-to-cert-name full-book-name 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)))

(defun certificate-file-and-input-channel (full-book-name old-cert-op state)

; 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.)

  (cond
   (old-cert-op
    (mv-let (ch cert-name state)
            (certificate-file-and-input-channel1 full-book-name old-cert-op
                                                 state)
            (mv ch
                cert-name
                (if (pcert-op-p old-cert-op)
                    old-cert-op
                  nil)
                state)))
   (t
    (mv-let ; try .cert first
     (ch cert-name state)
     (certificate-file-and-input-channel1 full-book-name t state)
     (cond (ch (mv ch cert-name nil state))
           (t (mv-let ; try .pcert0 next
               (ch cert-name state)
               (certificate-file-and-input-channel1 full-book-name
                                                    :create-pcert
                                                    state)
               (cond (ch (mv ch cert-name :create-pcert state))
                     (t (mv-let ; finally try .pcert1
                         (ch cert-name state)
                         (certificate-file-and-input-channel1 full-book-name
                                                              :convert-pcert
                                                              state)
                         (mv ch cert-name :convert-pcert state)))))))))))

(defun cert-annotations-and-checksum-from-cert-file (full-book-name state)

; See the requirement in post-alist-from-channel, regarding necessary packages
; existing.

  (mv-let
   (ch cert-name pcert-op state)
   (certificate-file-and-input-channel full-book-name
                                       (if (eq (cert-op state)
                                               :convert-pcert)
                                           :create-pcert
                                         nil)
                                       state)
   (declare (ignore cert-name pcert-op))
   (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-name 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-name 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
; the scary "BUT 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 the 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 tilde-*-book-check-sums-phrase1 (reqd-alist actual-alist-cddrs state)

; The two alists are strip-cddrs of include-book-alists.  Thus, each
; entry in each is of the form (familiar-name cert-annotations
; . ev-lst-chk-sum).  For each entry in reqd-alist we either find an
; identical entry in actual-alist-cddrs or else we print a message.

  (cond
   ((null reqd-alist) (mv nil state))
   (t (let* ((reqd-entry (cddr (car reqd-alist)))
             (full-book-name (car (car reqd-alist)))
             (familiar-name (car reqd-entry))
             (actual-entry (assoc-equal familiar-name actual-alist-cddrs)))

; We know there is an entry for familiar-name because otherwise we would have
; caused an error.  The question is only whether we found a cert file
; for it, etc.

        (cond
         ((equal reqd-entry actual-entry)
          (tilde-*-book-check-sums-phrase1 (cdr reqd-alist)
                                           actual-alist-cddrs
                                           state))
         (t
          (mv-let
           (msgs state)
           (tilde-*-book-check-sums-phrase1 (cdr reqd-alist)
                                            actual-alist-cddrs
                                            state)
           (mv-let
            (phrase state)
            (tilde-@-cert-post-alist-phrase full-book-name
                                            familiar-name
                                            (cdr reqd-entry)
                                            (cdr actual-entry)
                                            state)
            (mv (cons
                 (msg "-- its certificate requires the book \"~s0\" with ~
                      certificate annotations~|  ~x1~|and check sum ~x2, but ~
                      we have included ~@3~@4"
                      full-book-name
                      (cadr reqd-entry)  ;;; cert-annotations
                      (cddr reqd-entry) ;;; ev-lst-chk-sum
                      (cond
                       ((null (cddr actual-entry))
                        (msg "an uncertified version of ~x0 with certificate ~
                             annotations~|  ~x1,"
                             familiar-name
                             (cadr actual-entry) ; cert-annotations
                             ))
                       (t (msg "a version of ~x0 with certificate ~
                               annotations~|  ~x1~|and check sum ~x2,"
                               familiar-name
                               (cadr actual-entry) ; cert-annotations
                               (cddr actual-entry))))
                      phrase)
                 msgs)
                state)))))))))

(defun tilde-*-book-check-sums-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 . ev-lst-chk-sum).  Reqd-alist shows what is
; required and actual-alist shows that is actual (presumably, present in the
; world's include-book-alist).  We know reqd-alist ought to be a `include-book
; alist subset' of actual-alist but it is not.

  (mv-let (phrase1 state)
          (tilde-*-book-check-sums-phrase1 reqd-alist
                                           (strip-cddrs 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)
          (state-global-let*
           ((infixp nil))
           (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 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-depkg-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 (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-name-to-port-name (x)

; X is assumed to satisfy chk-book-name.  We generate the corresponding
; .port file name.  See the related function, convert-book-name-to-cert-name.

  (coerce (append (reverse (cddddr (reverse (coerce x 'list))))
                  '(#\p #\o #\r #\t))
          'string))

(defun chk-raise-portcullis2 (file1 file2 ch port-file-p ctx state ans)

; Keep this in sync with get-cmds-from-portcullis1.

; We read successive forms from ch and trans-eval them.  We stop when we get to
; end of file or, in the common case that port-file-p is false,
; :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 state)
          (state-global-let*
           ((infixp nil))
           (read-object ch state))
          (cond
           (eofp
            (cond (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))
            (value (reverse ans)))
           (t (mv-let
               (error-flg trans-ans state)
               (trans-eval 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-name-to-port-name 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 port-file-p
                                            ctx state
                                            (cons form ans))))))))))

(defun chk-raise-portcullis1 (file1 file2 ch port-file-p ctx state)

; After resetting the acl2-defaults-table, we read and eval each of the forms
; in ch until we get to :END-PORTCULLIS-CMDS.  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 ch 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 . ev-lst-chk-sum).  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 decimal-string-to-number (s bound expo)

; Returns 10^expo times the integer represented by the digits of string s from
; 0 up through bound-1 (most significant digit at position 0), but returns a
; hard error if any of those "digits" are not digits.

  (declare (xargs :guard (and (stringp s)
                              (natp expo)
                              (<= bound (length s)))))
  (cond ((zp bound) 0)
        (t (let* ((pos (1- bound))
                  (ch (char s pos)))
             (cond ((member ch '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
                    (let ((digit (case ch
                                   (#\0 0)
                                   (#\1 1)
                                   (#\2 2)
                                   (#\3 3)
                                   (#\4 4)
                                   (#\5 5)
                                   (#\6 6)
                                   (#\7 7)
                                   (#\8 8)
                                   (otherwise 9))))
                      (+ (* (expt 10 expo) digit)
                         (decimal-string-to-number s pos (1+ expo)))))
                   (t (er hard 'decimal-string-to-number
                          "Found non-decimal digit in position ~x0 of string ~
                           \"~s1\"."
                          pos s)))))))

(defun parse-version (version)

; Version is an ACL2 version string, as in state global 'acl2-version.  We
; return (mv major minor incrl rest), where either major is nil, indicating an
; ill-formed version; or else major, minor, and incrl are natural numbers
; indicating the major, minor, and incrl version, and rest is the part of the
; string starting with #\(, if any.  For example,
; (parse-version "ACL2 Version 2.10") is (mv 2 10 0 "") and
; (parse-version "ACL2 Version 2.10.1(r)") is (mv 2 10 1 "(r)").

  (let* ((root "ACL2 Version")
         (pos0 (if (and (stringp version)
                        (<= 13 (length version))
                        (equal (subseq version 0 12) root)
                        (or (eql (char version 12) #\Space)
                            (eql (char version 12) #\_)))
                   13
                 nil))
         (pos-lparen (position #\( version))
         (end0 (or pos-lparen
                   (length version)))
         (rest (subseq version end0 (length version)))
         (from-pos0 (and pos0 (subseq version pos0 end0)))
         (pos1-from-pos0 (and pos0 (position #\. from-pos0)))
         (pos1 (and pos1-from-pos0 (+ pos0 pos1-from-pos0)))
         (major (and pos1 (decimal-string-to-number
                           (subseq version pos0 pos1)
                           (- pos1 pos0) 0)))
         (from-pos1 (and pos1 (subseq version (1+ pos1) end0)))
         (pos2-from-pos1 (and pos1 (position #\. from-pos1)))
         (pos2 (if pos2-from-pos1
                   (+ (1+ pos1) pos2-from-pos1)
                 (and pos1 end0)))
         (minor (and pos2 (decimal-string-to-number
                           (subseq version (1+ pos1) pos2)
                           (1- (- pos2 pos1)) 0)))
         (incrl (if (and pos2 (< pos2 end0))
                    (decimal-string-to-number
                     (subseq version (1+ pos2) end0)
                     (1- (- end0 pos2))
                     0)
                  0)))
    (mv major minor incrl rest)))

#-acl2-loop-only
(defun-one-output latest-release-note-string ()
  (mv-let (major minor incrl rest)
    (parse-version (f-get-global 'acl2-version *the-live-state*))
    (declare (ignore rest))
    (if (zerop incrl)
        (format nil "note-~s-~s" major minor)
      (format nil "note-~s-~s-~s" major minor incrl))))

(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))
                (string-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)))

(defun include-book-alist-entryp (entry)
  (and (consp entry)
       (stringp (car entry)) ;;; full-book-name
       (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
       (or (integerp (cddddr entry))      ;;; ev-lst-chk-sum
           (eq (cddddr entry) nil))))

(defun include-book-alistp1 (x local-markers-allowedp)
  (cond
   ((atom x) (equal x nil))
   ((and local-markers-allowedp
         (consp (car x))
         (eq (car (car x)) 'local)
         (consp (cdr (car x)))
         (equal (cddr (car x)) nil))
    (and (include-book-alist-entryp (cadr (car x)))
         (include-book-alistp1 (cdr x)
                               local-markers-allowedp)))
   (t (and (include-book-alist-entryp (car x))
           (include-book-alistp1 (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-alistp1 x local-markers-allowedp))

(defrec cert-obj

; 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.

  ((cmds . pre-alist)
   post-alist expansion-alist . pcert-info)
  t)

(defun check-sum-cert-obj (cmds pre-alist post-alist expansion-alist)

; 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)
                       (cons post-alist expansion-alist))))

(defun chk-raise-portcullis (file1 file2 ch light-chkp caller
                                   ctx state
                                   suspect-book-action-alist evalp)

; File1 is a book and file2 is its certificate file.  The version string
; recorded with the file is version.  Ch is an open object input channel to 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, the pre- and post- check
; sum alists, and the final check sum.  If these objects are (except the
; optional :expansion-alist) not present or are of the wrong type, or there is
; additional text in the file, or the final check sum is inaccurate, we 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 nil ctx state)
           (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 ctx state))))
     (state-global-let*
      ((infixp nil))
      (mv-let
       (eofp pre-alist state)
       (read-object ch state)
       (er-let*
           ((expansion-alist
             (cond
              (eofp (ill-formed-certificate-er
                     ctx
                     'chk-raise-portcullis{expansion-alist-1}
                     file1 file2))
              ((eq pre-alist :expansion-alist)
               (mv-let
                (eofp expansion-alist state)
                (read-object ch state)
                (cond
                 (eofp
                  (ill-formed-certificate-er
                   ctx
                   'chk-raise-portcullis{expansion-alist-2}
                   file1 file2))
                 (t (value expansion-alist)))))
              (t (value nil))))
            (pre-alist
             (cond
              ((eq pre-alist :expansion-alist)
               (mv-let
                (eofp pre-alist state)
                (read-object ch state)
                (cond
                 (eofp (ill-formed-certificate-er
                        ctx
                        'chk-raise-portcullis{expansion-alist-3}
                        file1 file2))
                 (t (value pre-alist)))))
              (t (value pre-alist))))
            (pre-alist
             (cond ((include-book-alistp pre-alist nil)
                    (value pre-alist))
                   (t (ill-formed-certificate-er
                       ctx
                       'chk-raise-portcullis{pre-alist}
                       file1 file2 pre-alist)))))
         (let ((actual-alist (global-val 'include-book-alist (w state))))
           (mv-let
            (eofp post-alist3 state)
            (read-object ch state)
            (er-let*
                ((post-alist3
                  (cond
                   ((include-book-alistp post-alist3 t)
                    (value post-alist3))
                   (t (ill-formed-certificate-er
                       ctx
                       'chk-raise-portcullis{post-alist-1}
                       file1 file2 post-alist3)))))
              (cond
               (eofp
                (ill-formed-certificate-er
                 ctx
                 'chk-raise-portcullis{post-alist-2}
                 file1 file2))
               (t
                (mv-let
                 (eofp chk-sum1 state)
                 (read-object ch state)
                 (cond
                  (eofp
                   (ill-formed-certificate-er
                    ctx 'chk-raise-portcullis{chk-sum-1}
                    file1 file2))
                  ((not (integerp chk-sum1))
                   (ill-formed-certificate-er
                    ctx 'chk-raise-portcullis{chk-sum-2}
                    file1 file2 chk-sum1))
                  (t
                   (mv-let
                    (eofp temp state)
                    (read-object ch state)
                    (cond
                     ((not (or eofp
                               (eq temp :pcert-info)))
                      (ill-formed-certificate-er
                       ctx
                       'chk-raise-portcullis{pcert-info-1}
                       file1 file2 temp))
                     (t
                      (er-let*
                          ((pcert-info
                            (cond ((or eofp
                                       (not (eq caller 'convert-pcert)))
                                   (value nil))
                                  (t (mv-let
                                      (eofp1 temp1 state)
                                      (read-object ch state)
                                      (cond
                                       (eofp1
                                        (ill-formed-certificate-er
                                         ctx
                                         'chk-raise-portcullis{pcert-info-2}
                                         file1 file2))
                                       (t (value temp1))))))))
                        (let ((chk-sum2
                               (and (not light-chkp) ; optimization
                                    (check-sum-cert-obj
                                     portcullis-cmds ; :cmds
                                     pre-alist       ; :pre-alist
                                     post-alist3     ; :post-alist
                                     expansion-alist ; :expansion-alist
                                     ))))
                          (cond
                           ((and (not light-chkp)
                                 (or (not (integerp chk-sum2))
                                     (not (int= chk-sum1 chk-sum2))))
                            (ill-formed-certificate-er
                             ctx
                             'chk-raise-portcullis{pcert-info-3}
                             file1 file2
                             (list :chk-sum1 chk-sum1 :chk-sum2 chk-sum2

; Developer debug:
;                                  :portcullis-cmds portcullis-cmds
;                                  :pre-alist pre-alist
;                                  :post-alist3 post-alist3
;                                  :expansion-alist expansion-alist
                                   )))
                           ((and (not light-chkp)
                                 (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 because we prohibit local
; events in the portcullis commands.

; 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-check-sums-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
                                           :pre-alist pre-alist
                                           :post-alist post-alist3
                                           :expansion-alist expansion-alist
                                           :pcert-info
                                           pcert-info)))))))))))))))))))))))

(defun chk-certificate-file1 (file1 file2 ch light-chkp caller
                                    ctx state suspect-book-action-alist
                                    evalp)

; File1 is a book name and file2 is its associated certificate file name.  Ch
; is a channel to file2.  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 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.

; The code below is tedious and we here document it.  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.

  (mv-let
   (eofp version state)
   (state-global-let* ((infixp nil)) (read-object ch state))
   (cond
    (eofp (ill-formed-certificate-er
           ctx 'chk-certificate-file1{empty}
           file1 file2))
    (t (let* ((version-okp (equal version (f-get-global 'acl2-version state))))
         (cond
          (version-okp
           (mv-let
            (eofp key state)
            (state-global-let* ((infixp nil)) (read-object ch state))
            (cond
             (eofp
              (ill-formed-certificate-er
               ctx
               'chk-certificate-file1{begin-portcullis-cmds-1}
               file1 file2))
             ((not (eq key :begin-portcullis-cmds))
              (ill-formed-certificate-er
               ctx
               'chk-certificate-file1{begin-portcullis-cmds-2}
               file1 file2 key))
             (t (chk-raise-portcullis file1 file2 ch light-chkp caller ctx
                                      state suspect-book-action-alist
                                      evalp)))))
          ((not (equal (acl2-version-r-p (f-get-global 'acl2-version state))
                       (acl2-version-r-p version)))
           (er soft ctx
               "We do not permit ACL2 books to be processed by ACL2(r) or vice ~
                versa.  The book ~x0 was last certified with ~s1 but this is ~
                ~s2."
               file1
               version
               (f-get-global 'acl2-version state)))
          (t
           (mv-let
            (erp val state)
            (include-book-er
             file1 file2
             (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 (f-get-global 'acl2-version state))))
             :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)
               (state-global-let* ((infixp nil)) (read-object ch 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 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-name state)
  (mv-let (ch cert-name pcert-op state)
          (certificate-file-and-input-channel full-book-name nil state)
          (declare (ignore pcert-op))
          (pprogn (cond (ch (close-input-channel ch state))
                        (t state))
                  (mv (and ch cert-name) state))))

(defun chk-certificate-file (file1 dir caller ctx state
                                   suspect-book-action-alist evalp)

; File1 is a full book name.  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.

; Dir is either nil or the directory of file1.

; 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 check sums, and (for efficiency)
; we do not check the check-sum of 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 pronouce this book
; uncertified, we return nil.

  (let ((dir (or dir
                 (directory-of-absolute-pathname file1))))
    (mv-let
     (ch file2 pcert-op state)
     (certificate-file-and-input-channel file1
                                         (if (eq caller 'convert-pcert)
                                             :create-pcert
                                           nil)
                                         state)
     (cond
      ((null ch)
       (include-book-er file1 file2
                        "There is no certificate on file for ~x0."
                        :uncertified-okp
                        suspect-book-action-alist
                        ctx state))
      (t (er-let* ((pkg (state-global-let*
                         ((infixp nil))
                         (chk-in-package ch file2 nil ctx state))))
           (cond
            ((not (equal pkg "ACL2"))
             (ill-formed-certificate-er
              ctx 'chk-certificate-file{pkg} file1 file2 pkg))
            (t
             (state-global-let*
              ((current-package "ACL2")
               (connected-book-directory dir set-cbd-state))
              (mv-let (error-flg val state)
                      (chk-certificate-file1 file1 file2 ch
                                             (case caller ; light-chkp
                                               (convert-pcert nil)
                                               (certify-book t) ; k=t
                                               (include-book nil)
                                               (puff t)
                                               (otherwise
                                                (er hard ctx
                                                    "Implementation error in ~
                                                     chk-certificate-file: ~
                                                     Unexpected case!")))
                                             caller ctx state
                                             suspect-book-action-alist evalp)
                      (let ((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 (close-input-channel ch state)
                                (mv error-flg val state)))))))))))))

; 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-name 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-name dir '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-name ,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 symbol-name-equal (x str)
  (declare (xargs :guard (stringp str)))
  (and (symbolp x)
       (equal (symbol-name x) str)))

(defun chk-acceptable-certify-book1 (file dir k cmds cert-obj 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.

; File is a full-book-name.  If certify-book is called with k=t, then here k is
; '?, cert-obj is a cert-obj constructed from an existing certificate, and cmds
; is nil.  Otherwise (in the more usual case), this subroutine is called after
; we have the k proposed portcullis commands and wrld; cmds and cbds are
; returned by (get-portcullis-cmds wrld nil nil names ctx state); and cert-obj
; is nil.

; 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 pcert-info) from the existing .pcert0 file.  But in all
; other cases, we do not keep an existing expansion-alist, even if the original
; argument k for certify-book is t (or any symbol with name "T").

  (let ((pre-alist (global-val 'include-book-alist wrld))
        (cmds (or cmds
                  (and cert-obj
                       (access cert-obj cert-obj :cmds))))
        (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 one of the symbols T ~
           or ? (in any package), or an integer.  You supplied ~x0.  See :DOC ~
           certify-book."
          k))
     ((and (not (symbol-name-equal k "?"))
           (not (eql k (length cmds))))
      (er soft ctx
          "You indicated that the portcullis for ~x0 would be of length ~x1 ~
           but it is actually of length ~x2.  Perhaps you had better inspect ~
           the world and call certify-book again."
          file k (length cmds)))
     ((assoc-equal file pre-alist)

; Why do we do this?  By insuring 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."
          file))
     (uncert-books
      (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-books #\,)
          uncert-books))
     (cert-obj (value cert-obj))
     (t (er-let* ((fixed-cmds
                   (cond ((and (eq cert-op :convert-pcert)
                               cert-obj)

; This case comes from handling the case of argument k = t from certify-book.
; We do not use fixed-cmds below in this case, so we avoid the expense of
; computing it here.

                          (value 'irrelevant))
                         (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
                                               (os wrld) wrld ctx
                                               state)))))
                 (cond
                  ((eq cert-op :convert-pcert)
                   (cert-obj-for-convert file dir pre-alist fixed-cmds
                                         suspect-book-action-alist
                                         ctx state))
                  (t
                   (value (make cert-obj
                                :cmds fixed-cmds
                                :pre-alist
                                (cond (cert-obj (access cert-obj cert-obj
                                                        :pre-alist))
                                      (t pre-alist))
                                :post-alist nil    ; to be filled in later
                                :expansion-alist nil ; explained above
                                )))))))))

(defun translate-book-names (filenames cbd state acc)
  (declare (xargs :guard (true-listp filenames))) ; one member can be nil
  (cond ((endp filenames)
         (value (reverse acc)))
        ((null (car filenames))
         (translate-book-names (cdr filenames) cbd state (cons nil acc)))
        (t (translate-book-names
            (cdr filenames) cbd state
            (cons (extend-pathname cbd
                                   (possibly-add-lisp-extension
                                    (car filenames))
                                   state)
                  acc)))))

(defun fix-ttags (ttags ctx cbd 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))
                  (sym (if (consp ttag) (car ttag) ttag)))
             (cond
              ((not (and (symbolp sym)
                         sym
                         (or (atom ttag)
                             (string-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 mention the same ttag symbol more ~
                    than once, but the proposed list mentions ~x0 more than ~
                    once."
                   sym))
              ((symbolp ttag)
               (fix-ttags (cdr ttags) ctx cbd state (cons sym seen)
                          (cons sym acc)))
              (t
               (er-let* ((full-book-names
                          (translate-book-names (cdr ttag) cbd state nil)))
                        (fix-ttags (cdr ttags) ctx cbd state (cons sym seen)
                                   (cons (cons sym full-book-names)
                                         acc)))))))))

(defun chk-well-formed-ttags (ttags cbd ctx state)
  (cond ((or (null ttags) ; optimization
             (eq ttags :all))
         (value ttags))
        ((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 (fix-ttags ttags ctx cbd state nil nil))))

(defun check-certificate-file-exists (full-book-name 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-name
                                               (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-name))
           (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-name)))))

(defun chk-acceptable-certify-book (book-name 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,
; 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.  Otherwise, if k is t it means that the existing certificate file
; specifies the intended portcullis.  It also means that there must be such a
; file and that we are in the ground zero state.  If all those things check
; out, we will actually carry out the portcullis (extending the world with it)
; to get into the right state by the time we return.

; Dir is either nil or the directory of full-book-name.

  (let ((names (cons 'defpkg (primitive-event-macros)))
        (wrld (w state))
        (dir (or dir
                 (directory-of-absolute-pathname full-book-name))))
    (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.  ~
                 Such an event was:~|~%  ~y1~%(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
                (global-val 'skip-proofs-seen wrld)))
           ((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."
                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)))
           ((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 in this session.  To see the message again, ~
                 evaluate the following form:~|~x0"
                '(fmx "~@0~%~%" (@ illegal-to-certify-message))))
           (t (value nil)))
     (chk-book-name book-name full-book-name ctx state)
     (cond ((or (eq cert-op :convert-pcert)
                (symbol-name-equal k "T"))
; Cause early error now if certificate file is missing.
            (check-certificate-file-exists full-book-name 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))
       ((symbol-name-equal k "T")
        (cond
         (cmds
          (er soft ctx
              (cond
               ((eq cert-op :convert-pcert)
                "When you carry out the Convert procedure of provisional ~
                 certification using the certification world from the ~
                 provisional (.pcert0) certificate, you must call ~
                 certify-book in the initial ACL2 logical world.  Use :pbt 1 ~
                 to see the current ACL2 logical world.")
               (t "When you tell certify-book to recover the certification ~
                   world from the old certificate, you must call certify-book ~
                   in the initial ACL2 logical world -- so we don't have to ~
                   worry about the certification world clashing with the ~
                   existing logical world.  But you are not in the initial ~
                   logical world.  Use :pbt 1 to see the current ACL2 logical ~
                   world."))))
         (t

; So k is t, we are in the initial world, and there is a certificate file
; from which we can recover the portcullis.  Do it.

          (er-let*
              ((cert-obj
                (chk-certificate-file full-book-name dir 'certify-book ctx
                                      state
                                      (cons '(:uncertified-okp . nil)
                                            suspect-book-action-alist)
                                      t)) ; evalp = t, so world can change
               (cert-obj-cmds (value (and cert-obj
                                          (access cert-obj cert-obj :cmds)))))
            (chk-acceptable-certify-book1 full-book-name
                                          dir
                                          '? ; no check needed for k = t
                                          nil
                                          cert-obj
                                          nil ; no cbds should be needed
                                          names
                                          cert-op
                                          suspect-book-action-alist
                                          (w state) ; see evalp comment above
                                          ctx state)))))
       (t (chk-acceptable-certify-book1 full-book-name dir k cmds nil 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)))))
; Commented out upon addition of serialize:
;       #+hons (when (null ,chan0) (setq *compact-print-file-n* 0))
        ,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 (hence strongp=t in the call below of
; elide-locals-rec).  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) t)
                      (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 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))
    (let ((chk-sum (check-sum-cert-obj (car portcullis) ; :cmds
                                       (cdr portcullis) ; :pre-alist
                                       post-alist3      ; :post-alist
                                       expansion-alist  ; :expansion-alist
                                       )))
      (cond
       ((not (integerp chk-sum))
        (value (er hard ctx
                   "Check-sum-obj returned a non-integerp value on the ~
                    portcullis and post-alist3!")))
       (t
        (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)))
              (pprogn
               (print-object$ '(in-package "ACL2") ch state)
               (print-object$ (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))
               (print-object$ (cdr portcullis) ch state)
               (print-object$ post-alist3 ch state)
               (print-object$ chk-sum 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-relocated (file portcullis certification-file
                                             post-alist3 expansion-alist
                                             pcert-info old-dir
                                             new-dir cert-op ctx state)

; This function supports the creation of relocated .cert files for Debian GCL
; distributions.  See make-certificate-file.

; Warning: It is tempting to replace strings in (car portcullis), which is the
; list of portcullis commands, and the expansion-alist.  However, that will
; result in an uncertified book after moving the .cert.final file to the .cert
; file, because post-alist3 contains a checksum for the book as computed by
; function check-sum-cert, using the portcullis commands and the
; expansion-alist.

  (make-certificate-file1
   file
   (cons (car portcullis)
         (replace-string-prefix-in-tree
          (cdr portcullis) old-dir (length old-dir) new-dir))
   certification-file
   (replace-string-prefix-in-tree
    post-alist3 old-dir (length old-dir) new-dir)
   expansion-alist pcert-info cert-op ctx state))

(defun make-certificate-file (file portcullis post-alist1 post-alist2
                                   expansion-alist pcert-info
                                   cert-op ctx state)

; This function writes out, and returns, a certificate file.  We first give
; that file a temporary name.  Our original motivation was 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 satisfies chk-book-name.  The portcullis is a pair (cmds
; . pre-alist), where cmds is the list of portcullis commands that created the
; world in which the certification was done, and pre-alist is the
; include-book-alist just before certification was done.  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.

; For efficiency, we pass in a check-sum, chk-sum, already computed for:
; (make cert-obj
;       :cmds (car portcullis)
;       :pre-alist (cdr portcullis)
;       :post-alist post-alist3
;       :expansion-alist expansion-alist)

; 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 . chk-sum1)
;  ...
;  (LOCAL (fulli useri familiari cert-annotationsi . chk-sumi))
;  ...
;  (fullk userk familiark cert-annotationsk . chk-sumk))

; 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
; chk-sum

; where chk-sum is the check sum of ((cmds . pre-alist) . post-alist3).

; 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.

; Optionally, create .cert.final file as well; see comment below.

  (let ((certification-file (convert-book-name-to-cert-name file cert-op))
        (post-alist3 (mark-local-included-books post-alist1 post-alist2)))
    (er-progn

; For Debian release:

; Warning: The following mechanism should work well in most cases, but it is
; not guaranteed to be sound.  For example, function fix-path will ignore
; macros that expand (non-trivially) to event forms that should be handled by
; fix-path.  With some effort, we could use macroexpand to deal with this
; issue, by storing the macroexpanded forms in the portcullis in such cases.
; Even then, however, there would be problems with progn! (albeit only with
; active trust tags), since we can't really control what's in such forms.  And
; we would have to be careful to handle make-event forms properly, if we wanted
; an ironclad correctness guarantee for this mechanism.  End of Warning.

; A .cert.final file is created if state globals 'old-certification-dir and
; 'new-certification-dir are set to strings.  For example, in your
; ACL2 customization file you might put:

; (f-put-global 'old-certification-dir "/fix/debian/acl2/acl2-xx/books" state)
; (f-put-global 'new-certification-dir "/usr/share/acl2-xx/books" state)

; This will create a second certificate file, .cert.final (in addition to the
; .cert file), with post-alist3 fixed up so that for each string with prefix
; equal to the value of state global 'old-certification-dir, that prefix is
; replaced by the value of state global 'new-certification-dir.  The books in
; defpkg forms of the portcullis are similarly fixed as well.

; Warning: This .cert.final process works as described above, without
; modification in the case that we are doing provisional certification.  If we
; want to use this process with provisional certification, some additional work
; may be required.

     (let ((old-dir
            (and (f-boundp-global 'old-certification-dir state)
                 (f-get-global 'old-certification-dir state)))
           (new-dir
            (and (f-boundp-global 'new-certification-dir state)
                 (f-get-global 'new-certification-dir state))))
       (cond (old-dir
              (cond ((and (stringp old-dir)
                          (stringp new-dir)
                          (not (equal old-dir ""))
                          (not (equal new-dir ""))
                          (not (equal (char old-dir (1- (length old-dir)))
                                      *directory-separator*))
                          (not (equal (char new-dir (1- (length new-dir)))
                                      *directory-separator*)))
                     (make-certificate-file-relocated
                      file portcullis
                      (concatenate 'string certification-file ".final")
                      post-alist3 expansion-alist pcert-info
                      old-dir new-dir cert-op ctx
                      state))
                    (t (er soft ctx
                           "Attempted to create ~x0 because state global ~
                            'old-certification-dir is bound to a non-nil ~
                            value, ~x1.  However, in this case we require that ~
                            both this variable and 'new-certification-dir are ~
                            bound to non-empty strings not terminating in ~s2; ~
                            but this is not the case."
                           (concatenate 'string certification-file ".final")
                           old-dir
                           *directory-separator-string*))))
             (t (value :irrelevant-value))))
     (make-certificate-file1 file portcullis
                             (concatenate 'string certification-file ".temp")
                             post-alist3 expansion-alist
                             pcert-info cert-op ctx state))))

(defun make-certificate-files (full-book-name portcullis post-alist1
                                              post-alist2 expansion-alist
                                              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-name portcullis
                                      post-alist1 post-alist2
                                      expansion-alist pcert-info
                                      :create-pcert ctx state)))
      (er-let* ((pcert1-file
                 (make-certificate-file full-book-name portcullis
                                        post-alist1 post-alist2
                                        expansion-alist
                                        nil ; pcert-info for .pcert1 file
                                        :convert-pcert ctx state)))
        (value (list (cons pcert0-file
                           (convert-book-name-to-cert-name
                            full-book-name
                            :create-pcert))
                     (cons pcert1-file
                           (convert-book-name-to-cert-name
                            full-book-name
                            :convert-pcert)))))))
   (t (er-let* ((cert-file
                 (make-certificate-file full-book-name portcullis
                                        post-alist1 post-alist2
                                        expansion-alist pcert-info
                                        cert-op ctx state)))
        (value (list (cons cert-file
                           (convert-book-name-to-cert-name
                            full-book-name
                            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-name
                    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-name 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-name 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-name 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-name 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-name 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-name 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 full-book-name.  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-name 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-name 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-name 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-name 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-name
                                          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 changes the state --
; because it opens and closes 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 (open-input-object-file file ctx state)))
           (let ((state (close-input-channel ch state)))
             (value t))))

(defun include-book-dir (dir state)
  (cond ((eq dir :system)
         (f-get-global 'system-books-dir state))
        (t (let* ((alist0 (f-get-global 'raw-include-book-dir-alist state))
                  (alist (cond
                          ((eq alist0 :ignore)
                           (cdr (assoc-eq :include-book-dir-alist
                                          (table-alist 'acl2-defaults-table
                                                       (w state)))))
                          (t alist0))))
             (cdr (assoc-eq dir alist))))))

(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 :SYSTEM as well as those added by a call of ~
                   add-include-book-dir.  However, that argument is ~x0, which ~
                   is not among the list of those legal values, ~x1."
                  dir
                  (cons :system
                        (strip-cars
                         (cdr (assoc-eq :include-book-dir-alist
                                        (table-alist 'acl2-defaults-table
                                                     (w state))))))))
             (t ,(if (eq soft-or-hard 'soft) '(value dir-value)
                   'dir-value))))))

(defun newly-defined-top-level-fns-rec (trips collect-p full-book-name acc)

; Trips is a world segment in reverse order, i.e., with oldest events first.
; Initially trips corresponds to the part of the world added by an include-book
; event for full-book-name.  We accumulate into acc (which is eventually
; returned) the list of function symbols defined in trips whose definition
; comes from the top level of the book with path full-book-name, rather than
; some sub-book; or, if full-book-name is nil, then we accumulate events not
; inside any book.  Collect-p is true only when we are to collect up such
; function symbols.

  (cond ((endp trips)
         acc)
        ((and (eq (caar trips) 'include-book-path)
              (eq (cadar trips) 'global-value))
         (newly-defined-top-level-fns-rec (cdr trips)
                                          (equal (car (cddar trips))
                                                 full-book-name)
                                          full-book-name
                                          acc))
        ((not collect-p)
         (newly-defined-top-level-fns-rec (cdr trips) nil full-book-name acc))
        ((and (eq (caar trips) 'cltl-command)
              (eq (cadar trips) 'global-value)
              (equal (caddar trips) 'defuns))
         (newly-defined-top-level-fns-rec
          (cdr trips)
          collect-p
          full-book-name
          (union-eq (strip-cars (cdddr (cddar trips))) acc)))
        (t
         (newly-defined-top-level-fns-rec (cdr trips) collect-p full-book-name
                                          acc))))

(defun newly-defined-top-level-fns (old-wrld new-wrld full-book-name)

; New-wrld is the installed world, an extension of old-wrld.

  (let ((old-len (length old-wrld))
        (new-len (length new-wrld)))
    (assert$
     (<= old-len new-len)
     (let* ((len-old-past-boot-strap
             (cond
              ((equal (access-command-tuple-form (cddar old-wrld))
                      '(exit-boot-strap-mode)) ; optimization for common case
               0)
              (t (- old-len
                    (length (lookup-world-index
                             'command
                             (access command-number-baseline-info
                                     (global-val 'command-number-baseline-info
                                                 new-wrld) ; installed world
                                     :original)
                             new-wrld)))))))
       (newly-defined-top-level-fns-rec
        (first-n-ac-rev (- new-len old-len) new-wrld nil)
        t
        full-book-name
        (newly-defined-top-level-fns-rec
         (first-n-ac-rev len-old-past-boot-strap old-wrld nil)
         t
         nil
         nil))))))

(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 check-sum-cert (portcullis-cmds expansion-alist book-ev-lst)

; This function computes a check-sum 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.

  (check-sum-obj (list* portcullis-cmds expansion-alist book-ev-lst)))

; 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))
       ,@(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)

; 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* ((stack-rev (reverse (strip-cars load-compiled-stack)))
         (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-name-to-acl2x-name (x)

; X is assumed to satisfy chk-book-name.  We generate the corresponding
; acl2x file name, in analogy to how convert-book-name-to-cert-name generates
; certificate file.

; See the Essay on .acl2x Files (Double Certification).

  (coerce (append (reverse (cddddr (reverse (coerce x 'list))))
                  '(#\a #\c #\l #\2 #\x))
          'string))

(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-name 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-name))
                   (t state))
             (value nil)))
    (t (mv-let
        (book-date state)
        (file-write-date$ full-book-name 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-name))))
         (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-name ctx state)
  (let ((port-file (convert-book-name-to-port-name full-book-name))
        (dir (directory-of-absolute-pathname full-book-name)))
    (pprogn
     (mv-let
      (ch state)
      (open-input-channel port-file :object state)
      (cond
       ((null ch)
        (value nil))
       (t
        (er-let* ((pkg (state-global-let*
                        ((infixp nil))
                        (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
            (pprogn
             (io? event nil state
                  (port-file)
                  (fms "Note: Reading .port file, ~s0.~|"
                       (list (cons #\0 port-file))
                       (proofs-co state) state nil))
             (state-global-let*
              ((current-package "ACL2")
               (connected-book-directory dir set-cbd-state))
              (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-name 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)))

(defun convert-non-nil-symbols-to-keywords (x)
  (cond ((null x) nil)
        ((symbolp x)
         (intern (symbol-name x) "KEYWORD"))
        ((atom x) x)
        (t (cons (convert-non-nil-symbols-to-keywords (car x))
                 (convert-non-nil-symbols-to-keywords (cdr x))))))

(defun include-book-fn1 (user-book-name state
                                        load-compiled-file
                                        expansion-alist
                                        uncertified-okp
                                        defaxioms-okp
                                        skip-proofs-okp
                                        ttags
                                        doc
; Bound above and used below:
                                        ctx
                                        full-book-name
                                        directory-name
                                        familiar-name
                                        behalf-of-certify-flg
                                        cddr-event-form)
  #+acl2-loop-only (declare (ignore load-compiled-file))
  (let* ((wrld0 (w state))
         (old-skip-proofs-seen (global-val 'skip-proofs-seen wrld0))
         (active-book-name (active-book-name wrld0 state))
         (old-ttags-seen (global-val 'ttags-seen wrld0))
         #-(or acl2-loop-only hons)
         (*fchecksum-symbol-memo*
          (if *inside-include-book-fn*
              *fchecksum-symbol-memo*
            (make-hash-table :test 'eq)))
         #-acl2-loop-only
         (*inside-include-book-fn* (if behalf-of-certify-flg
                                       'hcomp-build
                                     t))
         (old-include-book-path
          (global-val 'include-book-path wrld0))
         (saved-acl2-defaults-table
          (table-alist 'acl2-defaults-table wrld0))

; 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.

         (suspect-book-action-alist
          (list (cons :uncertified-okp
                      (if (member-eq (cert-op state)
                                     '(nil :write-acl2xu))
                          uncertified-okp
                        nil))
                (cons :defaxioms-okp defaxioms-okp)
                (cons :skip-proofs-okp skip-proofs-okp)))
         (include-book-alist0 (global-val 'include-book-alist wrld0)))
    (er-progn
     (chk-book-name user-book-name full-book-name ctx state)
     (chk-input-object-file full-book-name ctx state)
     (revert-world-on-error
      (cond
       ((and (not (global-val 'boot-strap-flg wrld0))
             full-book-name
             (assoc-equal full-book-name include-book-alist0))
        (stop-redundant-event ctx state))
       (t
        (let* ((wrld1 (global-set
                       'include-book-path
                       (cons full-book-name old-include-book-path)
                       wrld0)))
          (pprogn
           (set-w 'extension wrld1 state)
           (er-let*
            ((redef (chk-new-stringp-name 'include-book full-book-name
                                          ctx wrld1 state))
             (doc-pair (translate-doc full-book-name doc ctx state))
             (cert-obj (if behalf-of-certify-flg
                           (value nil)
                         (with-hcomp-ht-bindings
                          (chk-certificate-file full-book-name
                                                directory-name
                                                'include-book ctx state
                                                suspect-book-action-alist
                                                t))))
             (wrld2 (er-progn
                     (cond ((or cert-obj
                                behalf-of-certify-flg)
                            (value nil))
                           (t (eval-port-file full-book-name ctx state)))
                     (value (w state))))
             (post-alist (value (and cert-obj
                                     (access cert-obj cert-obj :post-alist))))
             (cert-full-book-name (value (car (car post-alist)))))
            (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).

             ((and (not (equal full-book-name cert-full-book-name))
                   (not (global-val 'boot-strap-flg wrld2))
                   cert-full-book-name
                   (assoc-equal cert-full-book-name 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.

              (pprogn (set-w 'retraction wrld0 state)
                      (stop-redundant-event ctx state)))
             (t
              (er-let*
               ((ev-lst (read-object-file full-book-name ctx state)))

; Cert-obj above is either nil, indicating that the file is uncertified, or is
; a cert-obj record, which contains the now raised portcullis and the check sum
; alist of the files that should be brought in by this inclusion.  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
; . ev-lst-chk-sum), 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
; ev-lst-chk-sum ought to be those for the current book.

               (let ((ev-lst-chk-sum
                      (and cert-obj ; hence not behalf-of-certify-flg
                           (check-sum-cert (access cert-obj cert-obj
                                                   :cmds)
                                           (access cert-obj cert-obj
                                                   :expansion-alist)
                                           ev-lst))))
                 (cond
                  ((and cert-obj
                        (not (integerp ev-lst-chk-sum)))

; This error should never arise because check-sum-obj (called by
; check-sum-cert) is only called on something produced by read-object, which
; checks that the object is ACL2 compatible, and perhaps make-event expansion.
; The next form causes a soft error, assigning proper blame.

                   (er soft ctx
                       "ACL2 has enountered an object, ~x0, which check ~
                        sum was unable to handle."
                       ev-lst-chk-sum))
                  (t
                   (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
; . ev-lst-chk-sum).


                      (cond
                       ((and cert-obj
                             (not (equal (caddr (car post-alist))
                                         familiar-name)))
                        (include-book-er
                         full-book-name 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 we allow a ~
                           certified book to be moved 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 ~
                           check sum of the file at cer~-ti~-fi~-ca~-tion was ~
                           ~x5.  Its check sum now is ~x6."
                          (list (cons #\3 (caddr (car post-alist)))
                                (cons #\4 familiar-name)
                                (cons #\5 (cddddr (car post-alist)))
                                (cons #\6 ev-lst-chk-sum)))
                         :uncertified-okp
                         suspect-book-action-alist
                         ctx state))
                       (t (value t))))
                     (no-errp-2
                      (cond
                       ((and cert-obj
                             (not (equal (cddddr (car post-alist))
                                         ev-lst-chk-sum)))
                        (include-book-er
                         full-book-name nil
                         (cons
                          "The certificate on file for ~x0 lists the check ~
                           sum of the certified book as ~x3.  But the check ~
                           sum computed for that book is now ~x4. This ~
                           generally indicates that the file has been ~
                           modified since it was last certified (though it ~
                           could be the portcullis commands or the make-event ~
                           expansions that have changed)."

; Developer debug:
;                          ~|~%Developer note: ~
;                          the latter was computed as:~|~%~X56"
                          (list (cons #\3 (cddddr (car post-alist)))
                                (cons #\4 ev-lst-chk-sum)

; Developer debug:
;                               (cons #\5
;                                     `(check-sum-cert
;                                       ',(access cert-obj cert-obj
;                                                 :cmds)
;                                       ',(access cert-obj cert-obj
;                                                 :expansion-alist)
;                                       ',ev-lst))
;                               (cons #\6 nil)
                                ))
                         :uncertified-okp
                         suspect-book-action-alist
                         ctx state))
                       (t (value t))))
                     (certified-p
                      (value (and cert-obj no-errp-1 no-errp-2)))
                     (acl2x-file (value (convert-book-name-to-acl2x-name
                                         full-book-name)))
                     (expansion-alist
                      (cond (behalf-of-certify-flg (value expansion-alist))
                            (certified-p (value (access cert-obj cert-obj
                                                        :expansion-alist)))
                            (t (value nil)))))
                    (let* ((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
                                    (convert-non-nil-symbols-to-keywords
                                     ttags))))

                      #-acl2-loop-only
                      (when (and (not certified-p)
                                 (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-name
                            suspect-book-action-alist
                            ctx state))
                          (t (value nil))))
                        (ttags-info ; this value is ignored if not certified-p
                         (cond
                          ((not certified-p)
                           (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-name)
                               t)
                             ctx state)))))
                        (skip-proofsp

; At one time we bound this variable to 'initialize-acl2 if (or cert-obj
; behalf-of-certify-flg) is false.  But cert-obj is non-nil even if the
; check-sum is wrong, so we were distinguishing between two kinds of
; uncertified books: those with bad certificates and those with no
; certificates.  And inclusion of either sort of uncertified book is an "all
; bets are off" situation.  So it seems fine to use 'include-book here in all
; cases.  But why do we want to do so?  Eric Smith sent a nice example of a
; book with 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" prevent 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))

; The following process-embedded-events is protected by the revert-world-
; on-error above.  See the Essay on Guard Checking for a discussion of the
; binding of guard-checking-on below.

                        (ttags-allowed1
                         (state-global-let*
                          ((axiomsp nil)
                           (ttags-allowed
                            (if certified-p
                                cert-ttags
                              (f-get-global 'ttags-allowed state)))
                           (skip-notify-on-defttag
                            (and ttags-info ; hence certified-p
                                 full-book-name))
                           (connected-book-directory directory-name)
                           (match-free-error nil)
                           (guard-checking-on nil)
                           (in-local-flg
                            (and (f-get-global 'in-local-flg state)
                                 'local-include-book)))
                          (er-progn
                           (with-hcomp-ht-bindings
                            (process-embedded-events
                             'include-book

; We do not allow 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 above to include 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 directory for the install-event call below.

                             :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 an uncertified book.

                                  (or certified-p
                                      behalf-of-certify-flg))
                             ctx state))
                           (value (if ttags-info ; hence certified-p
                                      (car ttags-info)
                                    (f-get-global 'ttags-allowed
                                                  state)))))))

; The above process-embedded-events call returns what might be called
; proto-wrld3, which is equivalent to the current world of state before the
; process-embedded-events (since the insigs argument is nil), but it has an
; incremented embedded-event-depth.  We don't care about this world.  The
; interesting world is the one current in the state returned by
; process-embedded-events.  It has all the embedded events in it and we are
; done except for certification issues.

                       (let* ((wrld3 (w state))
                              (actual-alist
                               (global-val 'include-book-alist wrld3)))
                         (er-let*
                          ((certified-p
                            (cond
                             ((and
                               certified-p
                               (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-check-sums-phrase
                                    (unmark-and-delete-local-included-books
                                     (cdr post-alist))
                                    actual-alist
                                    state)
                                   (include-book-er1
                                    full-book-name nil
                                    (cons "After including the book ~x0:~|~*3."
                                          (list (cons #\3 msgs)))
                                    warning-summary ctx state))))))
                             (t (value certified-p)))))
                          (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)
                            (and cert-obj
                                 (access cert-obj cert-obj :cmds))
                            full-book-name
                            suspect-book-action-alist
                            ctx state)
                           (let* ((cert-annotations
                                   (cadddr (car post-alist)))

; If cert-obj is nil, then cert-annotations is nil.  If cert-obj is
; non-nil, then cert-annotations is non-nil.  Cert-annotations came
; from a .cert file, and they are always non-nil.  But in the
; following, cert-annotations may be nil.

                                  (certification-tuple
                                   (cond
                                    (certified-p

; Below we use the full book name from the certificate, 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.

;;;   % 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 . chk-sum).  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,
;;;   chk-sum is either an integer check sum on the contents of the file
;;;   at the time it was certified or else chk-sum is nil indicating that
;;;   the file is not certified.  Note that if the chk-sum 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-chk-sum))
                                    (t

; The certification tuple below is marked as uncertified because the
; ev-lst-chk-sum is nil.  What about cert-annotations?  It may or may
; not correctly characterize the file, it may even be nil.  Is that
; bad?  No, the check sum will always save us.

                                     (list* full-book-name
                                            user-book-name
                                            familiar-name
                                            cert-annotations
                                            nil)))))
                             (er-progn
                              #-acl2-loop-only
                              (cond
                               ((eq load-compiled-file :comp)
                                (compile-for-include-book full-book-name
                                                          certified-p
                                                          ctx
                                                          state))
                               (t (value nil)))
                              (pprogn
                               (redefined-warning redef ctx state)
                               (f-put-global 'ttags-allowed
                                             ttags-allowed1
                                             state)
                               (er-let*
                                ((declaim-list (get-declaim-list state))
                                 (pcert-p
                                  (cond
                                   ((and cert-obj
                                         (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-name
                                            (if (eq (access cert-obj
                                                            cert-obj
                                                            :pcert-info)
                                                    :proved)
                                                "completed"
                                              "skipped"))))))))
                                     (value t)))
                                   (t (value nil)))))
                                (install-event
                                 (if behalf-of-certify-flg
                                     declaim-list
                                   (or cert-full-book-name
                                       full-book-name))
                                 (list* 'include-book

; We use the the unique representative of the full book name 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-name
; parsed from what the user supplied.  Either way, we have an absolute path
; name, 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.

                                        (or cert-full-book-name
                                            full-book-name)
                                        cddr-event-form)
                                 'include-book
                                 full-book-name
                                 nil nil t ctx
                                 (let* ((wrld4
                                         (update-pcert-books
                                          full-book-name
                                          pcert-p
                                          (global-set
                                           'include-book-path
                                           old-include-book-path
                                           (update-doc-database
                                            full-book-name doc doc-pair
                                            (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
                                               (null cert-obj))
                                           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)
                                               wrld6))))))
                                   wrld7)
                                 state))))))))))))))))))))))))))

(defun include-book-fn (user-book-name state
                                       load-compiled-file
                                       expansion-alist
                                       uncertified-okp
                                       defaxioms-okp
                                       skip-proofs-okp
                                       ttags
                                       doc
                                       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.

; Expansion-alist is an expansion-alist generated from make-event calls if is
; called by certify-book-fn.  Otherwise, it is :none.

  (with-ctx-summarized
   (if (output-in-infixp state) event-form (cons 'include-book user-book-name))
   (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-name directory-name familiar-name)
      (parse-book-name dir-value user-book-name ".lisp" ctx state)
      (let* ((behalf-of-certify-flg (not (eq expansion-alist :none)))
             (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)
                 (if doc
                     (list :doc doc)
                   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
                uncertified-okp defaxioms-okp skip-proofs-okp ttags doc
; The following were bound above:
                ctx full-book-name directory-name familiar-name
                behalf-of-certify-flg cddr-event-form))
              (t
               (let #+acl2-loop-only ()
                    #-acl2-loop-only
                    ((*hcomp-book-ht* (make-hash-table :test 'equal)))

; Populate appropriate hash tables; see the Essay on Hash Table Support for
; Compilation.

                    #-acl2-loop-only
                    (include-book-raw-top full-book-name directory-name
                                          load-compiled-file dir ctx state)
                    (include-book-fn1
                     user-book-name state load-compiled-file expansion-alist
                     uncertified-okp defaxioms-okp skip-proofs-okp ttags doc
; The following were bound above:
                     ctx full-book-name directory-name familiar-name
                     behalf-of-certify-flg 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
; . ev-lst-chk-sum), while an entry in alist is (familiar-name
; cert-annotations . ev-lst-chk-sum).  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 . ev-lst-chk-sum) tuples.  We
; determine whether each such entry fails only because the chk-sum 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)))
                  (ev-lst-chk-sum1 (cddddr (car ibalist)))
                  (temp (assoc-equal familiar-name1 alist))
                  (cert-annotations2 (cadr temp))
                  (ev-lst-chk-sum2 (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 ev-lst-chk-sum1 nil)
                      ev-lst-chk-sum2)

; 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 nil in certify-book-fn
; and in include-book-fn (using state-global-let*), and also in
; pc-single-step-primitive.  We bind guard-checking-on to t in prove,
; translate-in-theory-hint, and value-triple.  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 if we bind
; guard-checking-on to nil in certify-book, then we should also bind it to nil
; in include-book.

; We argue now for binding guard-checking-on to nil in certify-book-fn (and
; hence, as argued above, in include-book-fn as well).  Note that we already
; allow book certification without requiring guard verification, which drives
; home the position that guards are extra-logical.  Thus, a high-level argument
; for binding guard-checking-on to nil during certification is that if we bind
; instead to t, then that position is diluted.  Now we give a more practical
; argument for binding guard-checking-on to nil during certification.  Suppose
; someone writes a macro with a guard, where that guard enforces some
; intention.  Do we want to enforce that guard, and when?  We already have
; safe-mode to enforce the guard as necessary for Common Lisp.  If a user
; executes :set-guard-checking nil in the interactive loop, then function
; guards are not checked, and thus it is reasonable not to check macro guards
; either.  Now suppose the same user attempts to certify a book that contains a
; top-level guard-violating macro call.  What a rude surprise it would be if
; certification fails due to a guard violation during expansion of that macro
; call, when the interactive evaluation of that same call had just succeeded!
; (One might argue that it is a sophisticated act to turn off guard checking in
; the interactive loop, hence a user who does that should be able to handle
; that rude surprise.  But that argument seems weak; even a beginner could find
; out how to turn off guard checking after seeing a guard violation.)

; We have argued for turning off guard checking during certify-book.  But a
; concern remains.  Suppose one user has written a macro with a guard, and now
; suppose a second user creates a book containing a top-level call of that
; macro with a guard violation.  Safe-mode will catch any Common Lisp guard
; violation.  But the macro writer may have attached the guard in order to
; enforce some intention that is not related to Common Lisp.  In the case of
; functions, one can ensure one's compliance with existing guards by verifying
; all guards, for example with (set-verify-guards-eagerness 2) at the top of
; the file.  A similar "complete guard checking" mechanism could enforce one's
; compliance with macro guards as well, say, (set-verify-guards-eagerness 3).
; The same concern applies to defconst, not only for macro expansion but also
; for function calls, and could be handled in the case of complete guard
; checking in the same way as for top-level macro expansion, by binding
; guard-checking-on to t with state-global-let*.  In practice, users may not
; demand the capability for complete guard checking, so it might not be
; important to provide this capability.

; Having decided to bind guard-checking-on to nil in certify-book-fn and
; (therefore) include-book-fn, let us turn to the other cases in which we bind
; guard-checking-on.

; We discussed defconst briefly above.  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, not only during certify-book but in the interactive loop.  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
; translate-in-theory-hint, 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 (full-book-name convert-to-os-p state)

; We use a .lsp suffix instead of .lisp for benefit of the makefile system,
; which by default looks for .lisp files to certify.

; Full-book-name is expected to be a Unix-style filename.  We return an OS
; filename.

  (let* ((file (if convert-to-os-p
                   (pathname-unix-to-os full-book-name state)
                 full-book-name))
         (len (length file)))
    (assert$ (equal (subseq file (- len 5) len) ".lisp")
             (concatenate 'string
                          (subseq file 0 (- len 5))
                          "@expansion.lsp"))))

(defun write-expansion-file (portcullis-cmds declaim-list new-fns-exec
                                             expansion-filename expansion-alist
                                             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.

  #+acl2-loop-only
  (declare (ignore new-fns-exec expansion-alist-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)))
      (pprogn
       (io? event nil state
            (expansion-filename)
            (fms "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"
                           "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 expansion-alist-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)))

; We print a single progn for all top-level events in order to get maximum
; sharing with compact printing.  This trick isn't necessary of course for the
; non-hons version, but it seems simplest to do this the same way for both the
; hons and non-hons versions.

       (mv-let
        (erp val state)
        (state-global-let*
         ((fmt-hard-right-margin 10000 set-fmt-hard-right-margin)
          (fmt-soft-right-margin 10000 set-fmt-soft-right-margin))
         (pprogn
          (fms ";;; Printing ~x0 portcullis command~#1~[~/s~] followed by ~
                book contents,~%;;; with make-event expansions."
               (list (cons #\0 (length portcullis-cmds))
                     (cons #\1 portcullis-cmds))
               ch state nil)
          (value nil)))
        (declare (ignore erp val))
        state)
       (print-object$ (cons 'progn
                            (append portcullis-cmds
                                    (subst-by-position 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:" ch state)

; 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))))
                    (compile-uncompiled-*1*-defuns "" ; irrelevant filename
                                                   new-fns-exec nil ch))
                  (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 expansion-alist-pkg-names0 (x base-kpa acc)
  (cond ((consp x)
         (expansion-alist-pkg-names0
          (cdr x) base-kpa
          (expansion-alist-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)))

#+(and hons (not acl2-loop-only))
(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))))))

#+(and hons (not acl2-loop-only))
(save-def
(defun expansion-alist-pkg-names-memoize (x)
  (cond ((consp x)
         (hons-union-ordered-string-lists
          (expansion-alist-pkg-names-memoize (car x))
          (expansion-alist-pkg-names-memoize (cdr x))))
        ((and x (symbolp x))
         (hons (symbol-package-name x) nil))
        (t nil)))
)

(defun expansion-alist-pkg-names (x base-kpa)

; For an explanation of the point of this function, see the comment at the call
; of expansion-alist-pkg-names in certify-book-fn.

; X is an expansion-alist 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.)

  #+(and hons (not acl2-loop-only))

; Here we use a more efficient but equivalent version of this function that
; memoizes, contributed initially by Sol Swords.  This version is only more
; efficient when fast alists are available; otherwise the memo table will be a
; linear list ultimately containing every cons visited, resulting in quadratic
; behavior because of the membership tests against it.

  (return-from
   expansion-alist-pkg-names
   (loop for name in (expansion-alist-pkg-names-memoize x)
         when (not (find-package-entry name base-kpa))
         collect name))
  (merge-sort-lexorder ; sort this small list, to agree with hons result above
   (expansion-alist-pkg-names0 x base-kpa nil)))

(defun delete-names-from-kpa (names kpa)
  (cond ((endp kpa)
         nil)
        ((member-equal (package-entry-name (car kpa)) names)
         (delete-names-from-kpa names (cdr kpa)))
        (t
         (cons (car kpa)
               (delete-names-from-kpa names (cdr 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 (state)
  (io? event nil state
       nil
       (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 initial world and try to include the book.  ~
             This may expose local incompatibilities.~%"
            nil
            (proofs-co state) state nil)))

(defun print-certify-book-guards-warning
  (full-book-name 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-name
              (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 . chk-sum). 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, chk-sum is ~
             either an integer check sum based on the contents of the file at ~
             the time it was certified or else chk-sum is nil indicating that ~
             the file is not certified.  Note that if the chk-sum is nil, the ~
             entry prints as (name1 name2 name3 alist).  Go figure."
            '(:full-book-name
              :user-book-name
              :familiar-name
              :cert-annotations
              . :chk-sum-for-events)
            (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-name expansion-filename cert-op
                                                 state)
  (io? event nil state
       (full-book-name expansion-filename cert-op)
       (fms "* Step 4:  Write the certificate for ~x0 in ~x1~@2.~%"
            (list
             (cons #\0 full-book-name)
             (cons #\1
                   (convert-book-name-to-cert-name full-book-name cert-op))
             (cons #\2
                   (if expansion-filename
                       (msg ", and compile the expansion file, ~s0"
                            expansion-filename)
                     "")))
            (proofs-co state) state nil)))

(defun print-certify-book-step-5 (full-book-name state)
  (io? event nil state
       (full-book-name)
       (fms "* Step 5:  Compile the functions defined in ~x0.~%"
            (list (cons #\0 full-book-name))
            (proofs-co state) state nil)))

(defun hcomp-build-from-portcullis (trips state)
  #+acl2-loop-only
  (declare (ignore trips))
  #+acl2-loop-only
  (read-acl2-oracle state)
  #-acl2-loop-only
  (hcomp-build-from-portcullis-raw trips 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.  (Even when an
;   event is ultimately local and hence is modified by elide-locals, a
;   record-expansion form is put into the 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.

(defstub acl2x-expansion-alist (expansion-alist state)

; 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.

  t)

(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 in the #+hons version.  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)))
        (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)

; Call this function on an expansion-alist that was not created by provisional
; certification, and hence has already had elide-locals applied to encapsulate
; events (hence strongp=nil in the call below of elide-locals-rec).

  (cond ((endp alist) (reverse acc))
        (t (elide-locals-from-expansion-alist
            (cdr alist)
            (cons (cons (caar alist)
                        (mv-let (changedp form)
                                (elide-locals-rec (cdar alist) nil)
                                (declare (ignore changedp))
                                form))
                  acc)))))

(defun write-port-file (full-book-name cmds ctx state)
  (let ((port-file (convert-book-name-to-port-name full-book-name)))
    (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)))
           (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)))
                     (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)

; If old-filename is present, then filename must exist and be at least as
; recent as old-filename in order to 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.

  (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-name-to-compiled-name (full-book-name state)

; The given full-book-name can either be a Unix-style or an OS-style pathname.

  (let ((rev-filename-list (reverse (coerce full-book-name 'list))))
    (coerce (append (reverse (cddddr rev-filename-list))
                    (coerce (f-get-global 'compiled-file-extension state)
                            'list))
            'string)))

(defun certify-book-finish-convert (new-post-alist old-post-alist
                                                   full-book-name 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-name-to-cert-name full-book-name
                                                            :create-pcert))
               (pcert1-name (convert-book-name-to-cert-name full-book-name
                                                            :convert-pcert))
               (compiled-name (convert-book-name-to-compiled-name
                               full-book-name 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-name)
  (loop for cert-op in '(:create-pcert :convert-pcert t)
        do
        (let ((cert-file
               (pathname-unix-to-os
                (convert-book-name-to-cert-name full-book-name cert-op)
                *the-live-state*)))
          (when (probe-file cert-file)
            (delete-file cert-file)))))

(defun include-book-alist-uncertified-books (alist acc 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-name (car entry))
                  (cert-name (convert-book-name-to-cert-name full-book-name
                                                             t)))
             (mv-let
              (book-date state)
              (file-write-date$ full-book-name 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-name acc)))
                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)
                     (value 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-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-name-to-cert-name full-book-name :create-pcert))
        (pcert1-file
         (convert-book-name-to-cert-name full-book-name :convert-pcert))
        (cert-file
         (convert-book-name-to-cert-name full-book-name t))
        (compiled-file
         (convert-book-name-to-compiled-name full-book-name state))
        (expansion-file
         (expansion-filename full-book-name
                             nil ; don't convert to OS, since we didn't above
                             state)))
    (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
                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 (mv-let (changedp val)
                               (elide-locals-rec (cdar acl2x-expansion-alist)
                                                 t)
                               (declare (ignore changedp))
                               val)
                       (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 chk-absstobj-invariants (extra-msg state)
  (declare (xargs :stobjs state

; If this were in :logic mode:
;                 :guard-hints (("Goal" :in-theory (enable read-acl2-oracle)))

                  ))
  (er-let* ((msg
             #+acl2-loop-only
             (read-acl2-oracle state)
             #-acl2-loop-only
             (let ((temp (svref *inside-absstobj-update* 0)))
               (cond
                ((or (null temp)
                     (eql temp 0))
                 (value nil))
                (t
                 (let ((msg
                        (msg "Possible invariance violation for an abstract ~
                              stobj!  See :DOC set-absstobj-debug, and ~
                              PROCEED AT YOUR OWN RISK.~@0"
                             (cond
                              ((natp temp) "")
                              (t
                               (msg "  Evaluation was aborted under a call of ~
                                     abstract stobj export ~x0.~@1"
                                    (cond ((symbolp temp) temp)
                                          (t (cdr (last temp))))
                                    (cond
                                     ((symbolp temp) "")
                                     (t
                                      (msg "  Moreover, it appears that ~
                                            evaluation was aborted within the ~
                                            following stack of stobj updater ~
                                            calls (innermost call appearing ~
                                            first): ~x0."
                                           (let ((y nil))
                                             (loop
                                              (if (atom temp)
                                                  (return (nreverse
                                                           (cons temp y)))
                                                (push (pop temp) y)))))))))))))
                   (pprogn
                    (f-put-global 'illegal-to-certify-message msg state)
                    (progn (setf (svref *inside-absstobj-update* 0)
                                 (if (natp temp) 0 nil))
                           (value msg)))))))))
    (cond (msg (er soft 'chk-absstobj-invariants
                   "~@0~@1"
                   msg
                   (if extra-msg
                       (msg "  ~@0" extra-msg)
                     "")))
          (t (value nil)))))

(defun certify-book-fn (user-book-name k compile-flg defaxioms-okp
                                       skip-proofs-okp ttags ttagsx ttagsxp
                                       acl2x write-port pcert state)
  (with-ctx-summarized
   (if (output-in-infixp state)
       (list* 'certify-book user-book-name
              (if (and (equal k 0) (eq compile-flg :default))
                  nil
                '(irrelevant)))
     (cons 'certify-book user-book-name))
   (save-parallelism-settings
    (let ((wrld0 (w state)))
      (cond
       ((not (eq (caar wrld0) '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 names 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))
       (t
        (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"))))))
          (mv-let
           (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-name ctx state))
            (t
             (er-let* ((write-port
                        (cond ((member-eq write-port '(t nil))
                               (value write-port))
                              ((eq write-port :default)
                               (getenv! "ACL2_WRITE_PORT" state))
                              (t (er soft ctx
                                     "Illegal :write-port argument, ~x0.  See ~
                                      :DOC certify-book."))))
                       (write-acl2x
                        (cond (acl2x (value (f-get-global 'write-acl2x state)))
                              ((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))))
                       (cert-op (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 ""))))))))
                       (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 (convert-non-nil-symbols-to-keywords
                                       (if ttagsxp ttagsx ttags))))
                       (ttags (cond ((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."))
                                    (t (chk-well-formed-ttags
                                        (convert-non-nil-symbols-to-keywords
                                         (cond (write-acl2x ttagsx)
                                               (t ttags)))
                                        (cbd) ctx state))))
                       (pair0 (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.

                               (global-val 'ttags-seen wrld0)
                               nil ; correct active-book-name, but irrelevant
                               ttags
                               nil ; irrelevant value for ttags-seen
                               :quiet ; ttags in certif. world were already reported
                               ctx state)))
               (state-global-let*
                ((certify-book-info
                  (make certify-book-info
                        :full-book-name full-book-name
                        :cert-op cert-op))
                 (match-free-error nil)
                 (defaxioms-okp-cert defaxioms-okp)
                 (skip-proofs-okp-cert skip-proofs-okp)
                 (guard-checking-on ; see Essay on Guard Checking
                  nil))
                (er-let* ((env-compile-flg
                           (getenv! "ACL2_COMPILE_FLG" state))
                          (compile-flg
                           (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))))
                          (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-name directory-name
                            suspect-book-action-alist cert-op k ctx state))
                          (portcullis-cmds0 (value (access cert-obj cert-obj
                                                           :cmds)))
                          (ignore (cond (write-port
                                         (write-port-file full-book-name
                                                          portcullis-cmds0
                                                          ctx state))
                                        (t (value nil)))))
                  (let* ((wrld1 ; from chk-acceptable-certify-book
                          (w state))
                         (wrld1-known-package-alist
                          (global-val 'known-package-alist wrld1))
                         (acl2x-file
                          (convert-book-name-to-acl2x-name full-book-name))
                         (bad-chksum-str ; too wide to use in place
                          "The file ~x0 is not a legal list of embedded event ~
                           forms because it contains an object, ~x1, that ~
                           check sum was unable to handle.  This may be an ~
                           implementation error; feel free to contact the ~
                           ACL2 implementors."))
                    (pprogn
                     (io? event nil state
                          (full-book-name cert-op)
                          (fms "CERTIFICATION ATTEMPT~@0 FOR ~x1~%~s2~%~%*~ ~
                                Step 1:  Read ~x1 and compute its check sum.~%"
                               (list (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-name)
                                     (cons #\2 (f-get-global 'acl2-version
                                                             state)))
                               (proofs-co state) state nil))
                     (er-let* ((ev-lst (read-object-file full-book-name 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-name
                                                          (length ev-lst)
                                                          acl2x ctx state))))
                               (expansion-alist0
                                (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-name-to-cert-name
                                                   full-book-name
                                                   :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)))))
                       (pprogn
                        (print-certify-book-step-2
                         ev-lst expansion-alist0
                         (and (eq cert-op :convert-pcert)
                              (convert-book-name-to-cert-name full-book-name
                                                              :create-pcert))
                         acl2x-file
                         state)
                        (er-let* ((pass1-result
                                   (state-global-let*
                                    ((ttags-allowed (car pair0))
                                     (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 ; axioms now
                                         'nonconstructive-axiom-names
                                         wrld1))))
                                     (ld-redefinition-action nil)
                                     (connected-book-directory
                                      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 'certify-book state))
                                               (ignore
                                                (chk-absstobj-invariants
                                                 "Your certify-book command ~
                                                  is therefore aborted."
                                                 state))
                                               (expansion-alist
                                                (value
                                                 (cond
                                                  (write-acl2x
                                                   (assert$ ; disallowed pcert
                                                    (null expansion-alist0)
                                                    (car expansion-alist-and-index)))
                                                  ((eq cert-op :convert-pcert)
                                                   :irrelevant) ; not used
                                                  (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
; expansion-alist-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 ; pass1-result:
                                            (list (or

; We are computing whether proofs may have been skipped.  If k is a symbol with
; name "T", then we are using an existing certificate.  If proofs were skipped
; during that previous certification, then perhaps they were skipped during
; evaluation of a portcullis command after setting ld-skip-proofsp to a non-nil
; value.  So we are conservative here, being sure that in such a case, we set
; :SKIPPED-PROOFSP to T in the annotations for the present book.  See the
; example in a comment in the deflabel note-5-0 pertaining to "Fixed a
; soundness bug based on the use of ~ilc[skip-proofs] ...."

                                                   (and
                                                    (symbol-name-equal k "T")
                                                    cert-obj ; always true?
                                                    (let ((cert-ann
                                                           (cadddr
                                                            (car
                                                             (access cert-obj
                                                                     cert-obj
                                                                     :post-alist)))))
                                                      (cdr (assoc-eq
                                                            :SKIPPED-PROOFSP
                                                            cert-ann))))
                                                   (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
; expansion-alist-pkg-names.

                                                  (let ((index
                                                         (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 index)
                                                      (restrict-expansion-alist
                                                       index
                                                       expansion-alist))
                                                     (t
                                                      expansion-alist)))))))))))))
                          (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))
                                   (expansion-alist-pkg-names

; Warning: If the following comment is modified or deleted, visit its reference
; in expansion-alist-pkg-names.  Also see the comments at the top of :doc
; note-3-2 for a discussion of this issue.

; We may need to create a defpkg in the certification world in order to read
; the expansion-alist from the certificate before evaluating events from the
; book.  As long as there have been no new defpkg events 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.)  But once we get a new package, 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 those packages.

                                    (expansion-alist-pkg-names
                                     expansion-alist-to-check
                                     wrld1-known-package-alist))
                                   (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 new-include-book-alist-all))
                              (er-progn
                               (chk-cert-annotations
                                cert-annotations portcullis-skipped-proofsp
                                portcullis-cmds0 full-book-name
                                suspect-book-action-alist ctx state)
                               (cond
                                ((eq cert-op :convert-pcert)
                                 (let* ((chk-sum
                                         (check-sum-cert portcullis-cmds0
                                                         (access cert-obj cert-obj
                                                                 :expansion-alist)
                                                         ev-lst))
                                        (extra-entry
                                         (list* full-book-name
                                                user-book-name
                                                familiar-name
                                                cert-annotations
                                                chk-sum)))
                                   (certify-book-finish-convert
                                    (cons extra-entry post-alist1)
                                    (access cert-obj cert-obj :post-alist)
                                    full-book-name ctx state)))
                                (t
                                 (pprogn
; Start include-book.
                                  (print-certify-book-step-3 state)
                                  (set-w 'retraction wrld1 state)
                                  #+(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 (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* ((defpkg-items
                                                (defpkg-items
                                                  pass1-known-package-alist
                                                  ctx wrld1
                                                  state))
                                              (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-portcullis
                                                  (reverse
                                                   (global-val
                                                    'top-level-cltl-command-stack
                                                    wrld1))
                                                  state)
                                                 (include-book-fn
                                                  user-book-name
                                                  state
                                                  nil
                                                  expansion-alist
                                                  uncertified-okp
                                                  defaxioms-okp
                                                  skip-proofs-okp
                                                  ttags-seen
                                                  nil nil
                                                  nil)))))
                                      (let* ((wrld2 (w state))
                                             (new-defpkg-list
                                              (new-defpkg-list
                                               defpkg-items
                                               (delete-names-from-kpa
                                                expansion-alist-pkg-names
                                                (global-val
                                                 'known-package-alist
                                                 wrld2))
                                               wrld1-known-package-alist))
                                             (new-fns
                                              (and (or (not (warning-disabled-p
                                                             "Guards"))
                                                       compile-flg)

; The test above is an optimization; we only need new-fns if the test holds.

                                                   (newly-defined-top-level-fns
                                                    wrld1 wrld2 full-book-name)))
                                             (os-expansion-filename
                                              (and compile-flg
                                                   (expansion-filename
                                                    full-book-name t state)))
                                             (post-alist2
                                              (cdr (global-val 'include-book-alist
                                                               wrld2))))

; The cdr above 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.

                                        (pprogn
                                         (mv-let
                                          (new-bad-fns all-bad-fns)
                                          (cond
                                           ((not (warning-disabled-p "Guards"))
                                            (mv (collect-ideals new-fns wrld2
                                                                nil)
                                                (collect-ideal-user-defuns
                                                 wrld2)))
                                           (t (mv nil nil)))
                                          (cond
                                           ((or new-bad-fns all-bad-fns)
                                            (print-certify-book-guards-warning
                                             full-book-name new-bad-fns
                                             all-bad-fns k ctx state))
                                           (t state)))
                                         (er-progn
                                          (chk-certify-book-step-3
                                           post-alist2 post-alist1 ctx state)
                                          (state-global-let*
                                           ((connected-book-directory

; 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-name
                                             os-expansion-filename
                                             cert-op
                                             state)
                                            (let* ((portcullis-cmds
                                                    (append? portcullis-cmds0
                                                             new-defpkg-list))
                                                   (chk-sum
                                                    (check-sum-cert portcullis-cmds
                                                                    expansion-alist
                                                                    ev-lst))
                                                   (extra-entry
                                                    (list* full-book-name
                                                           user-book-name
                                                           familiar-name
                                                           cert-annotations
                                                           chk-sum)))
                                              (cond
                                               ((not (integerp chk-sum))

; This really shouldn't happen!  After all, we already called read-object-file
; above, which calls read-object, which calls chk-bad-lisp-object.

                                                (er soft ctx bad-chksum-str
                                                    full-book-name chk-sum))
                                               (t

; 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.

                                                (er-let*
                                                    ((temp-alist
                                                      (make-certificate-files
                                                       full-book-name
                                                       (cons portcullis-cmds
                                                             (access cert-obj
                                                                     cert-obj
                                                                     :pre-alist))
                                                       (cons extra-entry post-alist1)
                                                       (cons extra-entry post-alist2)
                                                       expansion-alist
                                                       pcert-info
                                                       cert-op
                                                       ctx
                                                       state)))
                                                  (er-progn
                                                   (cond
                                                    (compile-flg
                                                     (pprogn
                                                      (print-certify-book-step-5
                                                       full-book-name state)
                                                      (er-progn
                                                       (write-expansion-file
                                                        portcullis-cmds
                                                        declaim-list
                                                        new-fns
                                                        (expansion-filename
                                                         full-book-name nil state)
                                                        expansion-alist
                                                        expansion-alist-pkg-names
                                                        ev-lst
                                                        pass1-known-package-alist
                                                        ctx state)
                                                       #-acl2-loop-only
                                                       (progn
                                                         (compile-certified-file
                                                          os-expansion-filename
                                                          full-book-name
                                                          state)
                                                         (when (not (f-get-global
                                                                     'save-expansion-file
                                                                     state))
                                                           (delete-expansion-file
                                                            os-expansion-filename state))
                                                         (value nil))
                                                       (value nil))))
                                                    (t
                                                     #-acl2-loop-only
                                                     (delete-auxiliary-book-files
                                                      full-book-name)
                                                     (value nil)))
                                                   #-acl2-loop-only
                                                   (progn
; Install temporary certificate file(s).
                                                     (delete-cert-files
                                                      full-book-name)
                                                     (loop for pair in
                                                           temp-alist
                                                           do
                                                           (rename-file
                                                            (pathname-unix-to-os
                                                             (car pair)
                                                             state)
                                                            (pathname-unix-to-os
                                                             (cdr pair)
                                                             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-name))))))))))))))))))))))))))))))))))))))))

#+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))

  ":Doc-Section Books

  how to produce a ~il[certificate] for a book~/
  ~bv[]
  Examples:
  (certify-book \"my-arith\")          ; certify in a world with 0 commands
  (certify-book \"my-arith\" 3)        ; ... in a world with 3 commands
  (certify-book \"my-arith\" ?)        ; ... in a world without checking the
                                       ;     number of commands
  (certify-book \"my-arith\" 0 nil)    ; ... without compilation
  (certify-book \"my-arith\" 0 t)      ; ... with compilation (default)
  (certify-book \"my-arith\" 0 t :ttags (foo))
                                       ; ... allowing trust tag (ttag) foo
  (certify-book \"my-arith\" 0 t :ttags :all)
                                       ; ... allowing all trust tags (ttags)
  (certify-book \"my-arith\" t)        ; ... from world of old certificate
  (certify-book \"my-arith\" 0 nil :acl2x t)
                                       ; ... writing or reading a .acl2x file~/

  General Form:
  (certify-book book-name
                k                           ; [default 0]
                compile-flg                 ; [default t]
                :defaxioms-okp t/nil        ; [default nil]
                :skip-proofs-okp t/nil      ; [default nil]
                :ttags ttags                ; [default nil]
                :acl2x t/nil                ; [default nil]
                :ttagsx ttags               ; [default nil]
                :write-port t/nil           ; [default t]
                :pcert pcert                ; [default nil]
                )
  ~ev[]
  where ~c[book-name] is a book name (~pl[book-name]), ~c[k] is used to
  indicate your approval of the ``certification ~il[world],'' and
  ~c[compile-flg] can control whether the book is to be compiled.  The defaults
  for ~c[compile-flg], ~c[skip-proofs-okp], ~c[acl2x], ~c[write-port], and
  ~c[pcert] can be affected by environment variables.  All of these arguments
  are described in detail below, except for ~c[:pcert].  (We assume below that
  the value of ~c[:pcert] is ~c[nil] (and environment variable
  ~c[ACL2_PCERT_ARG] is unset or the empty string).  For a discussion of this
  argument, ~pl[provisional-certification].)

  Certification occurs in some logical ~il[world], called the ``certification
  ~il[world].''  That ~il[world] must contain the ~ilc[defpkg]s needed to read
  and execute the forms in the book.  The ~il[command]s necessary to recreate
  that ~il[world] from the ACL2 initial ~il[world] are called the
  ``~il[portcullis] commands,'' and will be copied into the ~il[certificate]
  created for the book.  Those ~il[command]s will be re-executed whenever the
  book is included, to ensure that the appropriate packages (and all other
  names used in the certification ~il[world]) are correctly defined.  The
  certified book will be more often usable if the certification ~il[world] is
  kept to a minimal extension of the ACL2 initial ~il[world] (for example, to
  prevent name clashes with functions defined in other books).  Thus, before
  you call ~c[certify-book] for the first time on a book, you may wish to get
  into the initial ACL2 ~il[world] (e.g., with ~c[:ubt 1] or just starting a
  new version of ACL2), ~ilc[defpkg] the desired packages, and then invoke
  ~c[certify-book].

  The ~c[k] argument to ~c[certify-book] must be either a nonnegative integer
  or else one of the symbols ~c[t] or ~c[?] in any package.  If ~c[k] is an
  integer, then it must be the number of ~il[command]s that have been executed
  after the initial ACL2 ~il[world] to create the ~il[world] in which
  ~c[certify-book] was called.  One way to obtain this number is by doing
  ~c[:pbt :start] to see all the ~il[command]s back to the first one.

  If ~c[k] is ~c[t] (or any symbol whose ~ilc[symbol-name] is ~c[\"T\"]), it
  means that ~c[certify-book] should use the same ~il[world] used in the last
  certification of this book.  ~c[K] may have such a value only if you call
  ~c[certify-book] in the initial ACL2 ~il[world] and there is a
  ~il[certificate] on file for the book being certified.  (Of course, the
  ~il[certificate] is probably invalid.)  In this case, ~c[certify-book] reads
  the old ~il[certificate] to obtain the ~il[portcullis] ~il[command]s and
  executes them to recreate the certification ~il[world].

  Finally, ~c[k] may be ~c[?] (or any symbol whose ~ilc[symbol-name] is
  ~c[\"?\"]), in which case there is no check made on the certification world.
  That is, if ~c[k] is such a value then no action related to the preceding two
  paragraphs is performed, which can be a nice convenience but at the cost of
  eliminating a potentially valuable check that the certification ~il[world]
  may be as expected.

  We next describe the meaning of ~c[compile-flg] and how it defaults.  If
  explicit compilation has been suppressed by
  ~c[(set-compiler-enabled nil state)], then ~c[compile-flg] is coerced to
  ~c[nil]; ~pl[compilation].  Otherwise ~c[compile-flg] may be given the value
  of ~c[t] (or ~c[:all], which is equivalent to ~c[t] except during provisional
  certification; ~pl[provisional-certification]), indicating that the book is
  to be compiled, or else ~c[nil].  (Note that compilation initially creates a
  compiled file with a temporary file name, and then moves that temporary file
  to the final compiled file name obtained by adding a suitable extension to
  the book name.  Thus, a compiled file will appear atomically in its intended
  location.)  Finally, suppose that ~c[compile-flg] is not supplied (or is
  ~c[:default]).  If environment variable ~c[ACL2_COMPILE_FLG] is defined and
  not the empty string, then its value should be ~c[T], ~c[NIL], or ~c[ALL]
  after converting to upper case, in which case ~c[compile-flg] is considered
  to have value ~c[t], ~c[nil], or ~c[:all] (respectively).  Otherwise
  ~c[compile-flg] defaults to ~c[t].  Note that the value ~c[:all] is
  equivalent to ~c[t] except for during the Convert procedure of provisional
  certification; ~pl[provisional-certification].

  Two keyword arguments, ~c[:defaxioms-okp] and ~c[:skip-proofs-okp], determine
  how the system handles the inclusion of ~ilc[defaxiom] events and
  ~ilc[skip-proofs] events, respectively, in the book.  The value ~c[t] allows
  such events, but prints a warning message.  The value ~c[nil] causes an error
  if such an event is found.  ~c[Nil] is the default unless keyword argument
  ~c[:acl2x t] is provided and state global ~c['write-acl2x] is a cons
  (~pl[set-write-acl2x]), in which case the default is ~c[t].

  The keyword argument ~c[:ttags] may normally be omitted.  A few constructs,
  used for example if you are building your own system based on ACL2, may
  require it.  ~l[defttag] for an explanation of this argument.

  When book ~c[B] is certified with value ~c[t] (the default) for keyword
  argument ~c[:write-port], a file ~c[B.port] is written by certification
  process.  This file contains all of the ~il[portcullis] ~il[command]s for
  ~c[B], i.e., all user commands present in the ACL2 logical ~il[world] at the
  time ~c[certify-book] is called.  if ~c[B.lisp] later becomes uncertified,
  say because ~il[events] from that file or an included book have been edited,
  then ~c[(include-book \"B\")] will consult ~c[B.port] to evaluate forms in
  that file before evaluating the events in ~c[B.lisp].  On the other hand,
  ~c[B.port] is ignored when including ~c[B] if ~c[B] is certified.

  If you use ~il[guard]s, please note ~c[certify-book] is executed as though
  ~c[(set-guard-checking nil)] has been evaluated; ~pl[set-guard-checking].  If
  you want guards checked, consider using ~c[ld] instead, or in addition;
  ~pl[ld].

  For a general discussion of books, ~pl[books].  ~c[Certify-book] is akin to
  what we have historically called a ``proveall'': all the forms in the book
  are ``proved'' to guarantee their admissibility.  More precisely,
  ~c[certify-book] (1) reads the forms in the book, confirming that the
  appropriate packages are defined in the certification ~il[world]; (2) does
  the full admissibility checks on each form (proving termination of recursive
  functions, proving theorems, etc.), checking as it goes that each form is an
  embedded event form (~pl[embedded-event-form]); (3) rolls the ~il[world] back
  to the initial certification ~il[world] and does an ~ilc[include-book] of the
  book to check for ~ilc[local] incompatibilities (~pl[local-incompatibility]);
  (4) writes a ~il[certificate] recording not only that the book was certified
  but also recording the ~il[command]s necessary to recreate the certification
  ~il[world] (so the appropriate packages can be defined when the book is
  included in other ~il[world]s) and the check sums of all the ~il[books]
  involved (~pl[certificate]); (5) compiles the book if so directed (and then
  loads the object file in that case).  The result of executing a
  ~c[certify-book] ~il[command] is the creation of a single new event, which is
  actually an ~ilc[include-book] event.  If you don't want its included
  ~il[events] in your present ~il[world], simply execute ~c[:]~ilc[ubt]
  ~c[:here] afterwards.

  A utility is provided to assist in debugging failures of ~c[certify-book];
  ~pl[redo-flat].)

  ~c[Certify-book] requires that the default ~il[defun-mode]
  (~pl[default-defun-mode]) be ~c[:]~ilc[logic] when certification is
  attempted.  If the mode is not ~c[:]~ilc[logic], an error is signalled.

  An error will occur if ~c[certify-book] has to deal with any uncertified book
  other than the one on which it was called.  For example, if the book being
  certified includes another book, that subbook must already have been
  certified.

  If you have a certified book that has remained unchanged for some time you
  might well not remember the appropriate ~ilc[defpkg]s for it, though they are
  stored in the ~il[certificate] file and (by default) also in the ~c[.port]
  file.  If you begin to change the book, don't throw away its ~il[certificate]
  file just because it has become invalid!  It is an important historical
  document until the book is re-certified.  More important, don't throw away
  the ~c[.port] file, as it will provide the ~il[portcullis] commands when
  including the book as an uncertified book; ~pl[include-book].

  When ~c[certify-book] is directed to produce a compiled file, it calls the
  Common Lisp function ~c[compile-file] on the original source file.  This
  creates a compiled file with an extension known to ACL2, e.g., if the book is
  named ~c[\"my-book\"] then the source file is ~c[\"my-book.lisp\"] and the
  compiled file under GCL will be ~c[\"my-book.o\"] while under SBCL it will be
  ~c[\"my-book.fasl\"].  The compiled file is then loaded.  When
  ~ilc[include-book] is used later on ~c[\"my-book\"] it will automatically
  load the compiled file, provided the compiled file has a later write date
  than the source file.  The only effect of such ~il[compilation] and loading
  is that the functions defined in the book execute faster.  ~l[guard] for a
  discussion of the issues, and if you want more details about ~il[books] and
  compilation, ~pl[book-compiled-file].

  When ~c[certify-book] is directed not to produce a compiled file, it will
  delete any existing compiled file for the book, so as not to mislead
  ~ilc[include-book] into loading the now outdated compiled file.  Otherwise,
  ~c[certify-book] will create a temporary ``expansion file'' to compile,
  obtained by appending the string \"@expansion.lsp\" to the end of the book
  name.  Remark: Users may ignore that file, which is automatically deleted
  unless ~il[state] global variable ~c['save-expansion-file] has been set,
  presumably by a system developer, to a non-~c[nil] value;
  ~pl[book-compiled-file] for more information about hit issue, including the
  role of environment variable ~c[ACL2_SAVE_EXPANSION].

  After execution of a ~c[certify-book] form, the value of
  ~ilc[acl2-defaults-table] is restored to what it was immediately before that
  ~c[certify-book] form was executed.  ~l[acl2-defaults-table].

  Those who use the relatively advanced features of trust tags (~pl[defttag])
  and ~ilc[make-event] may wish to know how to create a ~il[certificate] file
  that avoids dependence on trust tags that are used only during
  ~ilc[make-event] expansion.  For this, including documentation of the
  ~c[:acl2x] and ~c[:ttagsx] keyword arguments for ~c[certify-book],
  ~pl[set-write-acl2x].

  This completes the tour through the ~il[documentation] of ~il[books].~/

  :cited-by other
  :cited-by Programming"

  (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)
        '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))))

  ":Doc-Section Other

  a variant of ~ilc[certify-book]~/
  ~bv[]
  Examples:
  (certify-book! \"my-arith\" 3)     ;Certify in a world with 3
                                     ; commands, starting in a world
                                     ; with at least 3 commands.
  (certify-book! \"my-arith\")       ;Certify in the initial world.~/

  General Form:
  (certify-book! book-name k compile-flg)
  ~ev[]
  where ~c[book-name] is a book name (~pl[book-name]), ~c[k] is a
  nonnegative integer used to indicate the ``certification ~il[world],''
  and ~c[compile-flg] indicates whether you wish to compile the
  (functions in the) book.

  This ~il[command] is identical to ~ilc[certify-book], except that the second
  argument ~c[k] may not be ~c[t] in ~c[certify-book!] and if ~c[k]
  exceeds the current ~il[command] number, then an appropriate ~ilc[ubt!] will
  be executed first.  ~l[certify-book] and ~pl[ubt!].~/"

  `(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))))

(defdoc provisional-certification

; Here we put random remarks about provisional certification that are not fully
; covered in the :doc topic (which serves as a prerequisite for these remarks).

; Let us consider the :pcert-info field of a cert-obj, which comes from the
; :pcert-info field of a .pcert0 file.  The value is :PROVED when the .pcert0
; file was created by the Pcertify+ procedure, but now we consider the value
; when the .pcert0 file was created by the Pcertify procedure.  The value is an
; expansion-alist that associates indices with full expansions, before applying
; elide-locals or elide-locals-rec.  When there is no such elision in the
; regular :expansion-alist, no entry is made in the :pcert-info field.  We do
; not elide locals during the Pcertify procedure; then when writing out the
; .pcert0 file, we use a strong version of
; elide-locals-and-split-expansion-alist (essentially, a strong version of
; elide-locals-from-expansion-alist) that dives inside encapsulates to elide
; locals.  Note that the :pcert-info field does not contribute to the checksum
; of a cert-obj (see check-sum-cert-obj and check-sum-cert), the reason being
; that we want the computed checksums not to change between a .pcert0 file and
; the .pcert1 file derived from it.

; Next, we discuss issues related to include-book and provisionally certified
; books.

; ACL2 users sometimes arrange to include books to build a certification world,
; as a precursor to a call of certify-book.  When using provisional
; certification, the .cert files might not exist for those books.  Of course,
; we allow .pcert0 and .pcert1 files to serve as certificate files when inside
; a call of certify-book with a :pcert argument of :create or :convert.  But
; the include-book forms mentioned above are executed before calling
; certify-book.  How can we support the use of .pcert0 and .pcert1 files in
; such cases?

; Our solution is to allow .pcert0 and .pcert1 files to serve as certificate
; files in all circumstances, with the following two kinds of special handling.
; First, and most important, we do the following two things: (a) we make a note
; in the world (in world global pcert-books) when cert-op is not :create-pcert,
; :create+convert-pcert or :convert-pcert, and an include-book has taken place
; that uses a .pcert0 or .pcert1 file as a certificate, and (b) we disallow
; certify-book in any such world unless the :pcert argument has value :create,
; t, or :convert (where this argument might, of course, come from environment
; variable ACL2_PCERT_ARG).  Second, we print a warning when using a .pcert0 or
; .pcert1 file unless we are in an environment with ACL2_PCERT set to a
; non-empty string.  (Of course, that warning may also be inhibited by
; set-inhibit-warnings or set-inhibit-output-lst.)

  ":Doc-Section Books

  certify a book in stages for improved parallelism~/

  Provisional certification is a process that can increase parallelism at the
  system level, typically using `make', when certifying a collection of
  ~il[books].  We got this idea from Jared Davis, who developed rudimentary
  provisional certification schemes first at Rockwell Collins and later for his
  `Milawa' project.  Our design has also benefited from conversations with Sol
  Swords.

  To invoke provisional certification, ~pl[books-certification].  For example,
  you could issue the following command.
  ~bv[]
  ACL2_PCERT=t cert.pl -j 4 `find . -name '*.lisp'`
  ~ev[]

  Alternatively, ~pl[books-certification-classic] for a discussion of classic
  ACL2 `make'-based certification (which may disappear in a future ACL2
  release); here we extend those instructions to show how to use provisional
  certification.  (Also, you may wish to look at community books file
  ~c[books/system/pcert/Makefile] for an example.)  We begin by describing a
  few ways to do that.  A simple way is to add the line `~c[ACL2_PCERT=t]' to a
  `make' command that you use for book certification, for example as follows.

  ~bv[]
  make -j 4 ACL2_PCERT=t
  ~ev[]
  The following works too, in a bash shell.
  ~bv[]
  (export ACL2_PCERT=t ; time make -j 4)
  ~ev[]
  Alternatively, add the line
  ~bv[]
  ACL2_PCERT ?= t
  ~ev[]
  to the ~c[Makefile] residing in the directory, placed above the line that
  specifies the `~c[include]' of file ~c[Makefile-generic].  A successful
  `make' will result in creating the desired ~il[certificate] (~c[.cert])
  files.

  Warning: If you put the line ``~c[ACL2_PCERT ?= t]'' below the include of
  ~c[Makefile-generic], it might have no effect.  For example, try editing
  community books file ~c[books/system/pcert/Makefile] by moving the line
  ``~c[ACL2_PCERT ?= t]'' to the bottom of the file, and watch
  ``~c[make top.cert]'' fail to invoke provisional certification.

  The description above may be sufficient for you to use provisional
  certification.  We provide additional documentation below for the reader who
  wants to understand more about this process, for example when not using
  `make'.  Below we assume prior familiarity with ~il[books], in particular
  ~ilc[certify-book] and ~ilc[include-book].  The remainder of this
  ~il[documentation] topic is divided into sections: Summary, Correctness Claim
  and Issues, Combining Pcertify and Convert into Pcertify+, and Further
  Information.~/

  ~st[Summary]

  Recall that certification of a book, ~c[bk], produces a ~il[certificate] file
  ~c[bk.cert].  The provisional certification process produces this file as
  well, but as the last of the following three steps.  All of these steps are
  carried out by calls of ~ilc[certify-book] using its ~c[:pcert] keyword
  argument.  We typically call these steps ``procedures'', to distinguish them
  from the steps of an individual call of ~ilc[certify-book].
  ~bq[]
  o The ``Pcertify'' procedure (sometimes called the ``Create'' procedure) is
  invoked by calling ~ilc[certify-book] with keyword argument
  ~c[:pcert :create].  It produces a file ~c[bk.pcert0], sometimes called the
  ``~c[.pcert0]'' file (pronounced ``dot pee cert zero'').  Proofs are skipped
  during this procedure, which can be viewed as an elaborate syntax check,
  augmented by compilation if specified (as it is by default).

  o The ``Convert'' procedure is invoked by calling ~ilc[certify-book] with
  keyword argument ~c[:pcert :convert].  It creates file ~c[bk.pcert1] from
  ~c[bk.pcert0], by doing proofs for all events in ~c[bk.lisp].  Note that the
  third argument (the `~c[compile-flg]' argument) is ignored by such a call of
  ~c[certify-book] unless its value is ~c[:all] (either explicitly or by way of
  environment variable ~c[ACL2_COMPILE_FLG]).  A subtlety is that if there is a
  compiled file at least as recent as the corresponding ~c[.pcert0] file, then
  that compiled file's write date will be updated to the current time at the
  end of this procedure.  The usual ~il[local-incompatibility] check at the
  end of ~ilc[certify-book] is omitted for the Convert procedure, since it was
  performed towards the end of the Create procedure.

  o The ``Complete'' procedure is invoked by calling ~ilc[certify-book] with
  keyword argument ~c[:pcert :complete].  It checks that every included book
  (including every one that is ~ilc[local]ly included) has a ~c[.cert] file
  that is at least as recent as the corresponding book.  The effect is to move
  ~c[bk.pcert1] to ~c[bk.cert].  Note that all arguments of ~c[certify-book]
  other than the ~c[:pcert] argument are ignored for this procedure, other than
  for some trivial argument checking.~eq[]

  You can combine the Pcertify and Convert procedures into a single procedure,
  Pcertify+, which may be useful for books that contain expensive
  ~ilc[include-book] ~il[events] but do few proofs.  We defer discussion of
  that feature to the section below, ``Combining Pcertify and Convert into
  Pcertify+''.

  The main idea of provisional certification is to break sequential
  dependencies caused by ~ilc[include-book], that is, so that a book's proofs
  are carried out even when it includes books (sometimes called ``sub-books'')
  that have not themselves been fully certified.  For example, suppose that a
  proof development consists of books ~c[A.lisp], ~c[B.lisp], and ~c[C.lisp],
  where file ~c[A.lisp] contains the form ~c[(include-book \"B\")] and file
  ~c[B.lisp] contains the form ~c[(include-book \"C\")].  Normally one would
  first certify ~c[C], then ~c[B], and finally, ~c[A].  However, the
  provisional certification process can speed up the process on a multi-core
  machine, as follows: the Pcertify (pronounced ``pee certify'') procedure
  respects this order but (one hopes) is fast since proofs are skipped; the
  Convert procedure essentially completes the certification in parallel by
  doing proofs and creating ~c[.pcert1] files based on ~c[.pcert0] files; and
  the Complete procedure respects book order when quickly renaming ~c[.pcert1]
  files to ~c[.cert] files.  In our example, the steps would be as follows, but
  note that we need not finish all Pcertify steps before starting some Convert
  steps, nor need we finish all Convert steps before starting some Complete
  steps, as explained further below.
  ~bq[]
  o Pcertify books \"C\", \"B\",and then \"A\", sequentially, skipping proofs
  but doing compilation.

  o Do proofs in parallel for the books using the Convert procedure, where each
  book relies on the existence of its own ~c[.pcert0] file as well as a
  ~c[.cert], ~c[.pcert0], or ~c[.pcert1] file for each of its included
  sub-books.  Write out a ~c[.pcert1] file for the book when the proof
  succeeds.

  o Rename the ~c[.pcert1] file to a corresponding ~c[.cert] file when a
  ~c[.cert] file exists and is up-to-date for each included book.~eq[]

  The Convert step can begin for ~c[bk.lisp] any time after ~c[bk.pcert0] is
  built.  The Complete step can begin for this book any time after
  ~c[bk.pcert1] and every ~c[sub-bk.cert] are built, for ~c[sub-bk] a sub-book
  of ~c[bk].

  The new procedures ~-[] Pcertify, Convert, and Complete ~-[] are invoked by
  supplying a value for the keyword argument ~c[:pcert] of ~ilc[certify-book],
  namely ~c[:create], ~c[:convert], or ~c[:complete], respectively.  Typically,
  and by default, the ~c[compile-flg] argument of ~ilc[certify-book] is ~c[t]
  for the Pcertify procedure, so that ~il[compilation] can take full advantage
  of parallelism.  This argument is treated as ~c[nil] for the other procedures
  except when its value is ~c[:all] in the Convert procedure, as mentioned
  above.

  For those who use ~ilc[make-event], we note that expansion is done in the
  Pcertify procedure; the later steps use the expansion resulting from that
  procedure.  The reason is that although a call of ~ilc[make-event] is similar
  to a macro call, a difference is that the expansion of a ~c[make-event] form
  can depend on the ~il[state].  Therefore, we insist on doing such an
  expansion only once, so that all books involved agree on the expansion.  We
  say more about ~c[make-event] below.

  ~st[Correctness Claim and Issues]

  The Basic Claim for certification is the same whether or not the provisional
  certification process is employed: all books should be certified from
  scratch, with no files written to the directories of the books except by
  ACL2.  Moreover, no trust tags should be used (~pl[defttag]), or else it is
  the responsibility of the user to investigate every occurrence of
  ``~c[TTAG NOTE]'' that is printed to standard output.

  But common practice is to certify a set of books in stages: certify a few
  books, fix some books, re-certify changed books, certify some more books, and
  so on.  In practice, we expect this process to be sound even though it does
  not meet the preconditions for the Basic Claim above.  In particular, we
  expect that the use of checksums in ~il[certificate]s will make it
  exceedingly unlikely that a book is still treated as certified after any
  events in the book or any sub-book, or any ~il[portcullis] ~il[command]s of
  the book or any sub-book, have been modified.

  Provisional certification makes it a bit easier for a determined user to
  subvert correctness.  For example, the Complete procedure only checks write
  dates to ensure that each sub-book's ~c[.cert] file is no older than the
  corresponding ~c[.lisp] file, but it does not look inside ~c[.cert] files of
  sub-books; in particular it does not look at their checksum information.  Of
  course, the automatic dependency analysis provided by classic ACL2
  `make'-based certification avoids accidental problems of this sort.  And,
  checksum information will indeed be applied at ~ilc[include-book] time, at
  least for sub-books included non-~il[local]ly.

  In short: while we believe that the provisional certification process can be
  trusted, we suggest that for maximum trust, it is best for all books in a
  project to be certified from scratch without the provisional certification
  process.

  ~st[Combining Pcertify and Convert into Pcertify+]

  You can combine the Pcertify and Convert procedure into a single procedure,
  Pcertify+, which may be useful for books that contain expensive
  ~ilc[include-book] ~il[events] but do few proofs.  If you are using `make' to
  do provisional certification as described above, just set `make' variable
  ~c[ACL2_BOOKS_PCERT_ARG_T] to the list of books for which you want the
  Pcertify+ procedure performed instead of separate Pcertify and Convert
  procedures.  Either of two common methods may be used to set this variable,
  as illustrated below for the case that books ~c[sub.lisp] and ~c[mid.lisp]
  are the ones on which you want Pcertify+ performed.  One method is to add the
  following to your directory's Makefile, above the ~c[include] of
  ~c[Makefile-generic].
  ~bv[]
  ACL2_BOOKS_PCERT_ARG_T = sub mid
  ~ev[]
  Alternatively, you can specify the desired books on the command line, for
  example as follows.
  ~bv[]
  make -j 4 ACL2_BOOKS_PCERT_ARG_T='sub mid'
  ~ev[]
  Note that the books are given without their ~c[.lisp] extensions.

  At the ACL2 level, the Pcertify+ procedure is performed when the value ~c[t]
  is supplied to the ~c[:pcert] keyword argument of ~ilc[certify-book].  Thus,
  ~c[:pcert t] can be thought of as a combination of ~c[:pcert :create] and
  ~c[:pcert :convert].  However, what ACL2 actually does is to perform the
  Pcertify step without skipping proofs, and at the end of the ~c[certify-book]
  run, it writes out both the ~c[.pcert0] and ~c[.pcert1] file, with
  essentially the same contents.  (We say ``essentially'' because the
  implementation writes ~c[:PCERT-INFO :PROVED] to the end of the ~c[.pcert0]
  file, but not to the ~c[.pcert1] file.)

  ~st[Further Information]

  Some errors during provisional certification cannot be readily solved.  For
  example, if there are circular directory dependencies (for example, some book
  in directory D1 includes some book in directory D2 and vice-versa), then
  classic ACL2 `make'-based certification will quite possibly fail.  For
  another example, perhaps your directory's Makefile is awkward to convert to
  one with suitable dependencies.  When no fix is at hand, it might be best
  simply to avoid provisional certification.  If you are using classic ACL2
  `make'-based certification, you can simply add the following line to your
  directory's ~c[Makefile], or use ``~c[ACL2_PCERT= ]'' on the `make' command
  line, to avoid provisional certification.
  ~bv[]
  override ACL2_PCERT =
  ~ev[]

  We invite anyone who has troubleshooting tips to contact the ACL2 developers
  with suggestions for adding such tips to this section.

  Our next remark is relevant only to users of ~ilc[make-event], and concerns
  the interaction of that utility with state global ~ilc[ld-skip-proofsp].
  Normally, the global value of ~ilc[ld-skip-proofsp] is unchanged during
  ~c[make-event] expansion, except that it is bound to ~c[nil] when the
  ~c[make-event] form has a non-~c[nil] ~c[:check-expansion] argument.  But
  during the Pcertify procedure (not the Pcertify+ procedure),
  ~ilc[ld-skip-proofsp] is always bound to ~c[nil] at the start of
  ~c[make-event] expansion.  To see why, consider for example the community
  book ~c[books/make-event/proof-by-arith.lisp].  This book introduces a macro,
  ~c[proof-by-arith], that expands to a call of ~ilc[make-event].  This
  ~c[make-event] form expands by trying to prove a given theorem using a
  succession of included arithmetic books, until the proof succeeds.  Now
  proofs are skipped during the Pcertify procedure, and if proofs were also
  skipped during ~c[make-event] expansion within that procedure, the first
  arithmetic book's ~ilc[include-book] form would always be saved because the
  theorem's proof ``succeeded'' (as it was skipped!).  Of course, the theorem's
  proof could then easily fail during the Convert step.  If you really want to
  inhibit proofs during ~c[make-event] expansion in the Pcertify step, consider
  using a form such as the following:
  ~c[(state-global-let* ((ld-skip-proofsp nil)) ...)].

  Finally, we describe what it means for there to be a valid ~il[certificate]
  file for including a certified book.  Normally, this is a file with extension
  ~c[.cert].  However, if that ~c[.cert] file does not exist, then ACL2 looks
  for a ~c[.pcert0] file instead; and if that also does not exist, it looks for
  a ~c[.pcert1] file.  (To see why does the ~c[.pcert0] file take priority over
  the ~c[.pcert1] file, note that the Convert procedure copies a ~c[.pcert0]
  file to a ~c[.pcert1] file, so both might exist ~-[] but the ~c[.pcert1] file
  might be incomplete if copying is in progress.)  Once the candidate
  certificate file is thus selected, it must be valid in order for the book to
  be considered certified (~pl[certificate]).  For the certificate file as
  chosen above, then in order for a compiled file to be loaded, it must be at
  least as recent as that certificate file.

  Again, as discussed above, a ~c[.pcert0] or ~c[.pcert1] file may serve as a
  valid certificate file when the ~c[.cert] file is missing.  But when that
  happens, a warning may be printed that a ``provisionally certified'' book has
  been included.  No such warning occurs if environment variable ~c[ACL2_PCERT]
  has a non-empty value, or if that warning is explicitly inhibited
  (~pl[set-inhibit-warnings] and ~pl[set-inhibit-output-lst]).")

(deflabel pathname
  :doc
  ":Doc-Section acl2::Books

  introduction to filename conventions in ACL2~/

  The notion of pathname objects from Common Lisp is not supported in
  ACL2, nor is the function ~c[pathname].  However, ACL2 supports file
  operations, using conventions for naming files based on those of the
  Unix (trademark of AT&T) operating system, so that the character ~c[/]
  is used to terminate directory names.  Some file names are ``absolute''
  (complete) descriptions of a file or directory; others are
  ``relative'' to the current working directory or to the connected
  book directory (~pl[cbd]).  We emphasize that even for users of
  Windows-based systems or Macintosh computers, ACL2 file names are in
  the Unix style.  We will call these ~em[ACL2 pathnames], often
  omitting the ``ACL2.''~/

  Pathnames starting with the directory separator (~c[/]) or the tilde
  character (~c[~~]) are absolute pathnames.  All other pathnames are relative
  pathnames.  An exception is in the Microsoft Windows operating system, where
  it is illegal for the pathname to start with a tilde character but the drive
  may be included, e.g., ~c[\"c:/home/smith/acl2/book-1.lisp\"].  In fact, the
  drive ~em[must] be included in the portcullis of a book; ~pl[portcullis].
  Note also that some host Common Lisps will not support pathnames starting
  with ~c[\"~~\"], for example ~c[~~smith], though ACL2 will generally support
  those starting with ~c[\"~~/\"] regardless of the host Common Lisp.

  Consider the following examples.  The filename string
  ~bv[]
  \"/home/smith/acl2/book-1.lisp\"
  ~ev[]
  is an absolute pathname, with top-level directory ~c[\"home\"],
  under that the directory ~c[\"smith\"] and then the directory
  ~c[\"acl2\"], and finally, within that directory the file
  ~c[\"book-1.lisp\"].  If the connected book directory is
  ~c[\"/home/smith/\"] (~pl[cbd]), then the filename string above
  also corresponds to the relative filename string \"acl2/book1.lisp\".

  Finally, we note that (on non-Windows systems) the pathname ~c[\"~~\"] and
  pathnames starting with ~c[\"~~/\"] are illegal in books being certified.
  Otherwise, a subsidiary ~ilc[include-book] form would have a different
  meaning at certification time than at a later time when the certified book
  is included by a different user.~/")

(deflabel book-example
  :Doc
  ":Doc-Section Books

  how to create, certify, and use a simple book~/

  Suppose you have developed a sequence of admissible ~il[events] which you
  want to turn into a book.  We call this ``publishing'' the book.
  This note explains how to do that.~/

  A key idea of ~il[books] is that they are ``incremental'' in the
  sense that when you include a book in a host logical ~il[world], the
  ~il[world] is incrementally extended by the results established in that
  book.  This is allowed only if every name defined by the incoming
  book is either new or is already identically defined.
  ~l[redundant-events].  This is exactly the same problem faced
  by a programmer who wishes to provide a utility to other people: how
  can he make sure he doesn't create name conflicts?  The solution, in
  Common Lisp, is also the same: use packages.  While ~il[books] and
  packages have a very tenuous formal connection (every book must
  start with an ~ilc[in-package]), the creation of a book is intimately
  concerned with the package issue.  Having motivated what would
  otherwise appear as an unnecessary fascination with packages below,
  we now proceed with a description of how to publish a book.

  Just to be concrete, let's suppose you have already gotten ACL2 to
  accept the following sequence of ~il[command]s, starting in the ACL2
  initial ~il[state].
  ~bv[]
     (defpkg \"ACL2-MY-BOOK\"
             (union-eq *common-lisp-symbols-from-main-lisp-package*
                       *acl2-exports*))
     (in-package \"ACL2-MY-BOOK\")
     (defun app (x y)
       (if (consp x) (cons (car x) (app (cdr x) y)) y))
     (defun rev (x)
       (if (consp x) (app (rev (cdr x)) (list (car x))) nil))
     (defthm rev-app-hack
       (equal (rev (app a (list x))) (cons x (rev a))))
     (defthm rev-rev
       (implies (acl2::true-listp x) (equal (rev (rev x)) x)))
  ~ev[]
  Observe that the first form above defines a package (which imports
  the symbols defined in CLTL such as ~ilc[if] and ~ilc[cons] and the
  symbols used to ~il[command] ACL2 such as ~ilc[defun] and ~ilc[defthm]).  The
  second form selects that package as the current one.  All subsequent
  forms are read into that package.  The remaining forms are just
  event forms: ~ilc[defun]s and ~ilc[defthm]s in this case.

  Typically you would have created a file with Emacs containing these
  forms and you will have submitted each of them interactively to ACL2
  to confirm that they are all admissible.  That interactive
  verification should start in ACL2's initial ~il[world] ~-[] although
  you might, of course, start your sequence of ~il[events] with some
  ~ilc[include-book]s to build a more elaborate ~il[world].

  The first step towards publishing a book containing the results
  above is to create a file that starts with the ~ilc[in-package] and
  then contains the rest of the forms.  Let's call that file
  ~c[\"my-book.lisp\"].  The name is unimportant, except it must end
  with ~c[\".lisp\"].  If there are ~il[events] that you do not wish to be
  available to the user of the book ~-[] e.g., lemmas you proved on your
  way toward proving the main ones ~-[] you may so mark them by
  enclosing them in ~ilc[local] forms.  ~l[local].  Let us suppose
  you wish to hide ~c[rev-app-hack] above.  You may also add standard Lisp
  comments to the file.  The final content of ~c[\"my-book.lisp\"]
  might be:
  ~bv[]
   ; This book contains my app and rev functions and the theorem
   ; that rev is its own inverse.

     (in-package \"ACL2-MY-BOOK\")
     (defun app (x y)
       (if (consp x) (cons (car x) (app (cdr x) y)) y))
     (defun rev (x)
       (if (consp x) (app (rev (cdr x)) (list (car x))) nil))

   ; The following hack is not exported.
     (local (defthm rev-app-hack
       (equal (rev (app a (list x))) (cons x (rev a)))))

     (defthm rev-rev
       (implies (acl2::true-listp x) (equal (rev (rev x)) x)))
  ~ev[]
  The file shown above ~st[is] the book.  By the time this note is
  done you will have seen how to certify that the book is correct, how
  to compile it, and how to use it in other host ~il[world]s.  Observe that
  the ~ilc[defpkg] is not in the book.  It cannot be: Common Lisp
  compilers disagree on how to treat new package definitions appearing
  in files to be compiled.

  Since a book is just a source file typed by the user, ACL2 provides
  a mechanism for checking that the ~il[events] are all admissible and then
  marking the file as checked.  This is called certification.  To
  certify ~c[\"my-book.lisp\"] you should first get into ACL2 with an
  initial ~il[world].  Then, define the package needed by the book, by
  typing the following ~ilc[defpkg] to the ACL2 ~il[prompt]:
  ~bv[]
  ACL2 !>(defpkg \"ACL2-MY-BOOK\"
                 (union-eq *common-lisp-symbols-from-main-lisp-package*
                           *acl2-exports*))
  ~ev[]
  Then execute the ~il[command]:
  ~bv[]
  ACL2 !>(certify-book \"my-book\" 1 t) ; the `t' is in fact the default
  ~ev[]
  Observe that you do not type the ~c[\".lisp\"] part of the file
  name.  For purposes of ~il[books], the book's name is ~c[\"my-book\"] and
  by the time all is said and done, there will be several extensions
  in addition to the ~c[\".lisp\"] extension associated with it.

  The ~c[1] tells ~ilc[certify-book] that you acknowledge that there is
  one command in this ``certification ~il[world]'' (namely the ~ilc[defpkg]).
  To use the book, any prospective host ~il[world] must be extended by
  the addition of whatever ~il[command]s occurred before certification.  It
  would be a pity to certify a book in a ~il[world] containing junk because
  that junk will become the ``~il[portcullis]'' guarding entrance to
  the book.  The ~c[t] above tells ~ilc[certify-book] that you wish to
  compile ~c[\"my-book.lisp\"] also (but ~pl[compilation] for an exception).
  ~ilc[Certify-book] makes many checks but by far the most important and
  time-consuming one is that it ``proves'' every event in the file.

  When ~ilc[certify-book] is done it will have created two new files.
  The first will be called ~c[\"my-book.cert\"] and contains the
  ``~il[certificate]'' attesting to the admissibility of the ~il[events] in
  ~c[\"my-book.lisp\"].  The ~il[certificate] contains the ~ilc[defpkg] and any
  other forms necessary to construct the certification ~il[world].  It also
  contains various check sums used to help you keep track of which
  version of ~c[\"my-book.lisp\"] was certified.

  The second file that may be created by ~ilc[certify-book] is the
  compiled version of ~c[\"my-book.lisp\"] and will have a name that
  is assigned by the host compiler (e.g., ~c[\"my-book.o\"] in GCL,
  ~c[\"my-book.fasl\"] in SBCL).  ~ilc[Certify-book] will also load
  this object file.  When ~ilc[certify-book] is done, you may throw
  away the logical ~il[world] it created, for example by executing the
  ~il[command] ~c[:u].

  To use the book later in any ACL2 session, just execute the event
  ~c[(include-book \"my-book\")].  This will do the necessary
  ~ilc[defpkg], load the non-~ilc[local] ~il[events] in
  ~c[\"my-book.lisp\"] and then may load the compiled code for the
  non-local functions defined in that file.  Checks are made to ensure
  that the ~il[certificate] file exists and describes the version of
  ~c[\"my-book.lisp\"] that is read.  The compiled code is loaded if
  and only if it exists and has a later write date than the source
  file (but ~pl[compilation] for an exception).

  Since ~ilc[include-book] is itself an event, you may put such forms
  into other ~il[books].  Thus it is possible for the inclusion of a single
  book to lead to the inclusion of many others.  The check sum
  information maintained in ~il[certificate]s helps deal with the
  version control problem of the referenced ~il[books].  I.e., if this
  version of ~c[\"my-book\"] is used during the certification of
  ~c[\"your-book\"], then the ~il[certificate] for ~c[\"your-book\"] includes
  the check sum of this version of ~c[\"my-book\"].  If a later
  ~c[(include-book \"your-book\")] finds a version of ~c[\"my-book\"]
  with a different check sum, an error is signalled.  But check sums
  are not perfect and the insecurity of the host file system prevents
  ACL2 from guaranteeing the logical soundness of an ~ilc[include-book]
  event, even for a book that appears to have a valid ~il[certificate]
  (they can be forged, after all).  (~l[certificate] for further
  discussion.)

  This concludes the example of how to create, certify and use a book.
  If you wish, you could now review the ~il[documentation] for book-related
  topics (~pl[books]) and browse through them.  They'll probably
  make sense in this context.  Alternatively, you could continue the
  ``guided tour'' through the rest of the ~il[documentation] of ~il[books].
  ~l[book-name], following the pointer given at the conclusion.")

(deflabel full-book-name
  :doc
  ":Doc-Section Books

  book naming conventions assumed by ACL2~/

  For this discussion we assume that the resident operating system is
  Unix (trademark of AT&T), but analogous remarks apply to other
  operating systems supported by ACL2, in particular, the Macintosh
  operating system where `~c[:]' plays roughly the role of `~c[/]' in
  Unix; ~pl[pathname].

  ACL2 defines a ``full book name'' to be an ``absolute filename
  string,'' that may be divided into contiguous sections:  a
  ``directory string'', a ``familiar name'' and an ``extension''.
  ~l[pathname] for the definitions of ``absolute,'' ``filename
  string,'' and other notions pertaining to naming files.  Below we
  exhibit the three sections of one such string:
  ~bv[]
  \"/usr/home/smith/project/arith.lisp\"

  \"/usr/home/smith/project/\"           ; directory string
                          \"arith\"      ; familiar name
                               \".lisp\" ; extension~/
  ~ev[]
  The sections are marked by the rightmost slash and rightmost dot,
  as shown below.
  ~bv[]
  \"/usr/home/smith/project/arith.lisp\"
                          |     |
                          slash dot
                          |     |
  \"/usr/home/smith/project/\"           ; directory string
                          \"arith\"      ; familiar name
                               \".lisp\" ; extension
  ~ev[]
  The directory string includes (and terminates with) the rightmost
  slash.  The extension includes (and starts with) the rightmost dot.
  The dot must be strictly to the right of the slash so that the
  familiar name is well-defined and nonempty.

  If you are using ACL2 on a system in which file names do not have
  this form, please contact the authors and we'll see what we can do
  about generalizing ACL2's conventions.")

(deflabel book-name
  :doc
  ":Doc-Section  Books

  conventions associated with book names~/
  ~bv[]
  Examples:
  \"list-processing\"
  \"/usr/home/smith/my-arith\"
  ~ev[]
  Book names are string constants that can be elaborated into file
  names.  We elaborate book names by concatenating the ``connected
  book directory'' (~pl[cbd]) string on the left and some
  ``extension,'' such as ~c[\".lisp\"], on the right.  However, the
  connected book directory is not added if the book name itself
  already represents an absolute file name.  Furthermore,
  ~ilc[include-book] and ~ilc[certify-book] temporarily reset the connected
  book directory to be the directory of the book being processed.
  This allows ~ilc[include-book] forms to use file names without explicit
  mention of the enclosing book's directory.  This in turn allows
  ~il[books] (together with those that they include, using
  ~ilc[include-book]) to be moved between directories while maintaining
  their certification and utility.

  You may wish to read elsewhere for details of ACL2 file name
  conventions (~pl[pathname]), for a discussion of the filename
  that is the result of the elaboration described here
  (~pl[full-book-name]), and for details of the concept of the
  connected book directory (~pl[cbd]).  For details of how
  ~ilc[include-book] (~pl[include-book]) and ~ilc[certify-book]
  (~pl[certify-book]) use these concepts, see below.~/

  Often a book name is simply the familiar name of the file.
  (~l[full-book-name] for discussion of the notions of
  ``directory string,'' ``familiar name,'' and ``extension''.  These
  concepts are not on the guided tour through ~il[books] and you
  should read them separately.)  However, it is permitted for book
  names to include a directory or part of a directory name.  Book
  names never include the extension, since ACL2 must routinely tack
  several different extensions onto the name during ~ilc[include-book].
  For example, ~ilc[include-book] uses the ~c[\".lisp\"], ~c[\".cert\"] and
  possibly the ~c[\".o\"] or ~c[\".lbin\"] extensions of the book name.

  Book names are elaborated into full file names by ~ilc[include-book]
  and ~ilc[certify-book].  This elaboration is sensitive to the
  ``connected book directory.'' The connected book directory is an
  absolute filename string (~pl[pathname]) that is part of the
  ACL2 ~ilc[state].  (You may wish to ~pl[cbd] and to
  ~pl[set-cbd] ~-[] note that these are not on the guided tour).
  If a book name is an absolute filename string, ACL2 elaborates it
  simply by appending the desired extension to the right.
  If a book name is a relative filename string, ACL2 appends the
  connected book directory on the left and the desired extension on
  the right.

  Note that it is possible that the book name includes some partial
  specification of the directory.  For example, if the connected book
  directory is ~c[\"/usr/home/smith/\"] then the book name
  ~c[\"project/task-1/arith\"] is a book name that will be elaborated
  to
  ~bv[]
  \"/usr/home/smith/project/task-1/arith.lisp\".
  ~ev[]

  Observe that while the ~il[events] in this ~c[\"arith\"] book are being
  processed the connected book directory will temporarily be set to
  ~bv[]
  \"/usr/home/smith/project/task-1/\".
  ~ev[]
  Thus, if the book requires other ~il[books], e.g.,
  ~bv[]
  (include-book \"naturals\")
  ~ev[]
  then it is not necessary to specify the directory on which they
  reside provided that directory is the same as the superior book.

  This inheritance of the connected book directory and its use to
  elaborate the names of inferior ~il[books] makes it possible to move
  ~il[books] and their inferiors to new directories, provided they maintain
  the same relative relationship.  It is even possible to move with
  ease whole collections of ~il[books] to different filesystems that use
  a different operating system than the one under which the original
  certification was performed.

  The ~c[\".cert\"] extension of a book, if it exists, is presumed to
  contain the most recent ~il[certificate] for the book.
  ~l[certificate] (or, if you are on the guided tour, wait until
  the tour gets there).

  ~l[book-contents] to continue the guided tour.")

(deflabel book-contents
  :doc
  ":Doc-Section  Books

  restrictions on the forms inside ~il[books]~/
  ~bv[]
  Example Book:

  ; This book defines my app function and the theorem that it is
  ; associative.  One irrelevant help lemma is proved first but
  ; it is local and so not seen by include-book.  I depend on the
  ; inferior book \"weird-list-primitives\" from which I get
  ; definitions of hd and tl.

  (in-package \"MY-PKG\")

  (include-book \"weird-list-primitives\")

  (defun app (x y) (if (consp x) (cons (hd x) (app (tl x) y)) y))

  (local
   (defthm help-lemma
     (implies (true-listp x) (equal (app x nil) x))))

  (defthm app-is-associative
    (equal (app (app a b) c) (app a (app b c))))~/

  ~ev[]
  The first form in a book must be ~c[(in-package \"pkg\")] where
  ~c[\"pkg\"] is some package name known to ACL2 whenever the book is
  certified.  The rest of the forms in a book are embedded event
  forms, i.e., ~ilc[defun]s, ~ilc[defthm]s, etc., some of which may be
  marked ~ilc[local].  ~l[embedded-event-form].  The usual Common
  Lisp commenting conventions are provided.  Note that since a book
  consists of embedded event forms, we can talk about the
  ``~ilc[local]'' and ``non-local'' ~il[events] of a book.

  Because ~ilc[in-package] is not an embedded event form, the only
  ~ilc[in-package] in a book is the initial one.  Because ~ilc[defpkg] is
  not an embedded event form, a book can never contain a ~ilc[defpkg]
  form.  Because ~ilc[include-book] is an embedded event form, ~il[books] may
  contain references to other ~il[books].  This makes ~il[books] structured
  objects.

  When the forms in a book are read from the file, they are read with
  ~ilc[current-package] set to the package named in the ~ilc[in-package]
  form at the top of the file.  The effect of this is that all symbols
  are ~il[intern]ed in that package, except those whose packages are given
  explicitly with the ``::'' notation.  For example, if a book begins
  with ~c[(in-package \"ACL2-X\")] and then contains the form
  ~bv[]
    (defun fn (x)
      (acl2::list 'car x))
  ~ev[]
  then ~ilc[defun], ~c[fn], ~c[x], and ~ilc[car] are all ~il[intern]ed in the
  ~c[\"ACL2-X\"] package.  I.e., it is as though the following form
  were read instead:
  ~bv[]
    (acl2-x::defun acl2-x::fn (acl2-x::x)
        (acl2::list 'acl2-x::car acl2-x::x)).
  ~ev[]
  Of course, ~c[acl2-x::defun] would be the same symbol as
  ~c[acl2::defun] if the ~c[\"ACL2-X\"] package imported ~c[acl2::defun].

  If each book has its own unique package name and all the names
  defined within the book are in that package, then name clashes
  between ~il[books] are completely avoided.  This permits the construction
  of useful logical ~il[world]s by the successive inclusion of many ~il[books].
  Although it is often too much trouble to manage several packages,
  their judicious use is a way to minimize name clashes.  Often, a
  better way is to use ~c[local]; ~pl[local].

  How does ~ilc[include-book] know the definitions of the packages used in a
  book, since ~ilc[defpkg]s cannot be among the forms?  More generally,
  how do we know that the forms in a book will be admissible in the
  host logical ~il[world] of an ~ilc[include-book]?  ~l[certificate] for
  answers to these questions.")

(deflabel certificate
  :doc
  ":Doc-Section Books

  how a book is known to be admissible and where its ~ilc[defpkg]s reside~/

  A book, say ~c[\"arith\"], is said to have a ``certificate'' if there
  is a file named ~c[\"arith.cert\"].  Certificates are created by the
  function ~ilc[certify-book] and inspected by ~ilc[include-book].  Check
  sums are used to help ensure that certificates are legitimate and
  that the corresponding book has not been modified since
  certification.  But because the file system is insecure and check
  sums are not perfect it is possible for the inclusion of a book to
  cause inconsistency even though the book carries an impeccable
  certificate.

  The certificate includes the version number of the certifying ACL2.
  A book is considered uncertified if it is included in an ACL2
  with a different ~il[version] number.~/

  The presence of a ``valid'' certificate file for a book attests to
  two things: all of the ~il[events] of the book are admissible in a
  certain extension of the initial ACL2 logic, and the non-~ilc[local]
  ~il[events] of the book are independent of the ~ilc[local] ones
  (~pl[local-incompatibility]).  In addition, the certificate
  contains the ~il[command]s used to construct the ~il[world] in which
  certification occurred.  Among those ~il[command]s, of course, are the
  ~ilc[defpkg]s defining the packages used in the book.  When a book is
  included into a host ~il[world], that ~il[world] is first extended
  by the ~il[command]s listed in the certificate for the book.  Unless that
  causes an error due to name conflicts, the extension ensures that
  all the packages used by the book are identically defined in the
  host ~il[world].

  ~em[Security:]

  Because the host file system is insecure, there is no way ACL2 can
  guarantee that the contents of a book remain the same as when its
  certificate was written.  That is, between the time a book is
  certified and the time it is used, it may be modified.  Furthermore,
  certificates can be counterfeited.  Check sums (~pl[check-sum])
  are used to help detect such problems.  But check sums provide
  imperfect security: two different files can have the same check sum.

  Therefore, from the strictly logical point of view, one must
  consider even the inclusion of certified ~il[books] as placing a burden
  on the user:~bq[]

  The non-erroneous inclusion of a certified book is consistency
  preserving provided (a) the objects read by ~ilc[include-book] from the
  certificate were the objects written there by a ~ilc[certify-book] and
  (b) the forms read by ~ilc[include-book] from the book itself are the
  forms read by the corresponding ~ilc[certify-book].

  ~eq[]We say that a given execution of ~ilc[include-book] is ``certified''
  if a certificate file for the book is present and well-formed and
  the check sum information contained within it supports the
  conclusion that the ~il[events] read by the ~ilc[include-book] are the ones
  checked by ~ilc[certify-book].  When an uncertified ~ilc[include-book]
  occurs, warnings are printed or errors are caused.  But even if no
  warning is printed, you must accept burdens (a) and (b) if you use
  ~il[books].  These burdens are easier to live with if you protect your
  ~il[books] so that other users cannot write to them, you abstain from
  running concurrent ACL2 jobs, and you abstain from counterfeiting
  certificates.  But even on a single user uniprocessor, you can shoot
  yourself in the foot by using the ACL2 ~il[io] primitives to fabricate an
  inconsistent book and the corresponding certificate.

  Note that part (a) of the burden described above implies, in
  particular, that there are no guarantees when a certificate is
  copied.  When ~il[books] are renamed (as by copying them), it is
  recommended that their certificates be removed and the ~il[books] be
  recertified.  The expectation is that recertification will go
  through without a hitch if relative ~il[pathname]s are used.
  ~l[pathname], which is not on the guided tour.

  Certificates essentially contain two parts, a ~il[portcullis] and a
  ~il[keep].  There is a third part, an ~c[expansion-alist], in order
  to record expansions if ~ilc[make-event] has been used, but the user
  need not be concerned with that level of detail.

  ~l[portcullis] to continue the guided tour through ~il[books].")

(deflabel portcullis

; This documentation string formerly concluded (just before "~l[keep] to
; continue...") with the following discussion, until Version  2.6.  Now that we
; change include-book forms in the portcuillis to use absolute pathnames, we do
; not need this.

;   Recall that we disallow ~ilc[include-book] ~il[events] from the portcullis
;   unless the included book's name is an absolute filename
;   (~l[pathname]).  Thus, for example, under the Unix operating
;   system it is impossible to certify a book if the certification
;   ~il[world] was created with
;   ~bv[]
;   ACL2 !>(~il[include-book] \"arith\")
;   ~ev[]
;   The problem here is that the file actually read on behalf of such
;   an ~ilc[include-book] depends upon the then current setting of the
;   connected book directory (~pl[cbd]).  That setting could be
;   changed before the certification occurs.  If we were to copy
;   ~c[(include-book \"arith\")] into the portcullis of the book being
;   certified, there is no assurance that the ~c[\"arith\"] book included
;   would come from the correct directory.  However, by requiring that
;   the ~ilc[include-book]s in the certification ~il[world] give book names
;   that begin with slash we effectively require you to specify the full
;   file name of each book involved in creating your certification
;   ~il[world].  Observe that the execution of
;   ~bv[]
;   (~il[include-book] \"/usr/local/src/acl2/library/arith\")
;   ~ev[]
;   does not depend on the current book directory.  On the other hand,
;   this requirement ~-[] effectively that absolute file names be used in
;   the certification ~il[world] ~-[] means that a book that requires
;   another book in its certification ~il[world] will be rendered
;   uncertified if the required book is removed to another directory.
;   If possible, any ~ilc[include-book] ~il[command] required for a book ought
;   to be placed in the book itself and not in the certification
;   ~il[world].  The only time this cannot be done is if the required
;   book is necessary to some ~ilc[defpkg] required by your book.  Of
;   course, this is just the same advice we have been giving: keep the
;   certification ~il[world] as elementary as possible.

  :doc
  ":Doc-Section Books

  the gate guarding the entrance to a certified book~/

  The certificate (~pl[certificate] for general information) of a
  certified file is divided into two parts, a portcullis and a
  ~il[keep].  These names come from castle lore.  The portcullis of a
  castle is an iron grate that slides up through the ceiling of the
  tunnel-like entrance.  The portcullis of a book ensures that
  ~ilc[include-book] does not start to read the book until the
  appropriate context has been created.~/

  Technically, the portcullis consists of the ~il[version] number of
  the certifying ACL2, a list of ~il[command]s used to create the
  ``certification ~il[world]'' and an alist specifying the check sums
  of all the ~il[books] included in that ~il[world].  The portcullis
  is constructed automatically by ~ilc[certify-book] from the ~il[world]
  in which ~ilc[certify-book] is called, but that ~il[world] must have
  certain properties described below.  After listing the properties we
  discuss the issues in a more leisurely manner.

  Each ~il[command] in the portcullis must be either a ~ilc[defpkg] form or an
  embedded event form (~pl[embedded-event-form]).

  Consider a book to be certified.  The book is a file containing
  event forms.  Suppose the file contains references to such symbols
  as ~c[my-pkg::fn] and ~c[acl2-arith::cancel], but that the book itself
  does not create the packages.  Then a hard Lisp error would be
  caused merely by the attempt to read the expressions in the book.
  The corresponding ~ilc[defpkg]s cannot be written into the book itself
  because the book must be compilable and Common Lisp compilers differ
  on the rules concerning the inline definition of new packages.  The
  only safe course is to make all ~ilc[defpkg]s occur outside of compiled
  files.

  More generally, when a book is certified it is certified within some
  logical ~il[world].  That ``certification ~il[world]'' contains not only
  the necessary ~ilc[defpkg]s but also, perhaps, function and constant
  definitions and maybe even references to other ~il[books].  When
  ~ilc[certify-book] creates the ~il[certificate] for a file it recovers
  from the certification ~il[world] the ~il[command]s used to create that
  ~il[world] from the initial ACL2 ~il[world].  Those ~il[command]s become
  part of the portcullis for the certified book.  In addition,
  ~ilc[certify-book] records in the portcullis the check sums
  (~pl[check-sum]) of all the ~il[books] included in the certification
  ~il[world].

  ~ilc[Include-book] presumes that it is impossible even to read the
  contents of a certified book unless the portcullis can be
  ``raised.'' To raise the portcullis we must be able to execute
  (possibly redundantly, but certainly without error), all of the
  ~il[command]s in the portcullis and then verify that the ~il[books] thus
  included were identical to those used to build the certification
  ~il[world] (up to check sum).  This raising of the portcullis must
  be done delicately since ~ilc[defpkg]s are present: we cannot even read
  a ~il[command] in the portcullis until we have successfully executed the
  previous ones, since packages are being defined.

  Clearly, a book is most useful if it is certified in the most
  elementary extension possible of the initial logic.  If, for
  example, your certification ~il[world] happens to contain a
  ~ilc[defpkg] for ~c[\"MY-PKG\"] and the function ~c[foo], then those
  definitions become part of the portcullis for the book.  Every time
  the book is included, those names will be defined and will have to
  be either new or redundant (~pl[redundant-events]).  But if
  those names were not necessary to the certification of the book,
  their presence would unnecessarily restrict the utility of the book.

  ~l[keep] to continue the guided tour of ~il[books].")

(deflabel version
  :doc
  ":Doc-Section Miscellaneous

  ACL2 Version Number~/

  To determine the version number of your copy of ACL2, evaluate the form
  ~c[(@ acl2-version)].  The value will be a string.  For example,
  ~bv[]
  ACL2 !>(@ acl2-version)
  \"ACL2 Version 3.4\"
  ~ev[]
  ~/

  The part of the string after ~c[\"ACL2 Version \"] is of the form ~c[x.y] or
  ~c[x.y.z], optionally followed by a succession of values in parentheses,
  where ~c[x], ~c[y], and ~c[z] are natural numbers.  If ~c[z] is omitted then
  it is implicitly 0.  We refer to ~c[X], ~c[y], and ~c[z] as the ``major'',
  ``minor'', and ``incrl'' fields, respectively.  The incrl field is used for
  incremental releases.  The discussion just below assumes that incremental
  releases are not employed at the user's site, i.e., the incrl fields are
  always 0.  We remove this assumption when we discuss incremental releases at
  the end of this documenttation topic.

  ~il[Books] are considered certified only in the same version of ACL2
  in which the certification was done.  The ~il[certificate] file
  records the version number of the certifying ACL2 and
  ~il[include-book] considers the book uncertified if that does not
  match the current version number.  Thus, each time we release a new
  version of ACL2, previously certified books should be recertified.

  Note that there are over 150 constants in the system, most having to do with
  the fact that ACL2 is coded in ACL2.  Many of these, for example
  ~c[*common-lisp-specials-and-constants*] and ~c[*acl2-exports*], may change
  from version to version, and this can cause unsoundness.  For example, the
  symbol ~c['set-difference-eq] was added to ~c[*acl2-exports*] in Version_2.9,
  so we can certify a book in Version_2.8 containing the following theorem,
  which is false in Version_2.9.
  ~bv[]
  (null (member 'set-difference-eq *acl2-exports*))
  ~ev[]
  Therefore, we need to disallow inclusion of such a book in a Version_2.9
  session, which otherwise would allow us to prove ~c[nil].  Furthermore, it is
  possible that from one version of the system to another we might change, say,
  the default values on some system function or otherwise make ``intentional''
  changes to the axioms.  It is even possible one version of the system is
  discovered to be unsound and we release a new version to correct our error.

  Therefore we adopted the draconian policy that books are certified
  by a given version of ACL2 and ``must'' be recertified to be used
  in other versions.  We put ``must'' in quotes because in fact, ACL2
  allows a book that was certified in one ACL2 version to be included
  in a later version, using ~ilc[include-book].  But ACL2 does not allow
  ~ilc[certify-book] to succeed when such an ~ilc[include-book] is executed on its
  behalf.  Also, you may experience undesirable behavior if you avoid
  recertification when moving to a different version.  Hence we
  recommend that you stick to the draconion policy of recertifying
  books when updating to a new ACL2 version.

  The string ~c[(@ acl2-version)] can contain implementation-specific
  information in addition to the version number.  For example, in
  Macintosh Common Lisp (MCL) ~c[(char-code #\Newline)] is 13, while as
  far as we know, it is 10 in every other Common Lisp.  Our concern is
  that one could certify a book in an MCL-based ACL2 with the theorem
  ~bv[]
  (equal (char-code #\Newline) 13)
  ~ev[]
  and then include this book in another Lisp and thereby prove ~c[nil].
  So, when a book is certified in an MCL-based ACL2, the book's
  ~il[certificate] mentions ``MCL'' in its version string.  Moreover,
  ~c[(@ acl2-version)] similarly mentions ``MCL'' when the ACL2 image has
  been built on top of MCL.  Thus, an attempt to include a book in an
  MCL-based ACL2 that was certified in a non-MCL-based ACL2, or
  vice-versa, will be treated like an attempt to include an
  uncertified book.

  ~em[Incremental releases.]

  From time to time, so-called ``incremental releases'' of ACL2 are made
  available.  These releases are thoroughly tested on at least two platforms;
  ``normal'' releases, on the other hand, are thoroughly tested on many more
  platforms (perhaps a dozen or so) and are accompanied by updates to the ACL2
  home page.  We provide incremental releases in order to provide timely
  updates for ACL2 users who want them, without imposing unnecessary burdens on
  either on the ACL2 implementors or on ACL2 users who prefer to update less
  frequently.  The implementors expect users to update their copies of ACL2
  when normal releases are made available, but not necessarily when incremental
  releases are made available.

  Incremental releases are accompanied by a bump in the incrl field of the
  version field, while normal releases are accompanied by a bump in the minor
  or (much less frequently) major field and zeroing out of the incrl field.
  Note that incremental releases are full-fledged releases.~/")

(deflabel keep
  :doc
  ":Doc-Section Books

  how we know if ~ilc[include-book] read the correct files~/

  The certificate (~pl[certificate] for general information) of a
  certified file is divided into two parts, a ~il[portcullis] and a
  keep.  These names come from castle lore.  The keep is the strongest
  and usually tallest tower of a castle from which the entire
  courtyard can be surveyed by the defenders.  The keep of a book is a
  list of file names and check sums used after the book has been
  included, to determine if the files read were (up to check sum)
  those certified.~/

  Once the ~il[portcullis] is open, ~ilc[include-book] can enter the book
  and read the event forms therein.  The non-~ilc[local] event forms are
  in fact executed, extending the host theory.  That may read in other
  ~il[books].  When that has been finished, the keep of the
  ~il[certificate] is inspected.  The keep is a list of the book names
  which are included (hereditarily through all subbooks) in the
  certified book (including the certified book itself) together with
  the check sums of the objects in those ~il[books] at the time of
  certification.  We compare the check sums of the ~il[books] just included
  to the check sums of the ~il[books] stored in the keep.  If differences
  are found then we know that the book or one of its subbooks has been
  changed since certification.

  ~l[include-book] to continue the guided tour through ~il[books].")

; The documentation for include-book is in axioms.lisp, where the
; include-book event is defined.

(deflabel uncertified-books
  :doc
  ":Doc-Section Books

  invalid ~il[certificate]s and uncertified ~il[books]~/

  For relevant background ~pl[books], ~pl[certificate], and ~pl[portcullis].

  ~ilc[Include-book] has a special provision for dealing with an uncertified
  book, i.e., a file with no ~il[certificate] or an invalid
  ~il[certificate] (i.e., one whose check sums describe files other than the
  ones actually read).  In this case, a warning is printed and the book is
  otherwise processed much as though it were certified and had an open
  ~il[portcullis].

  If a book ~c[B.lisp] is uncertified and a file ~c[B.port] exists, then the
  forms in ~c[B.port] are evaluated before the forms in ~c[B.lisp].  Such a
  file ~c[B.port] is typically created calling ~ilc[certify-book] on book
  ~c[\"B\"] with argument ~c[:write-port t], so that ~c[B.port] contains the
  ~il[portcullis] ~il[command]s for ~c[B] (the commands present in the
  ~il[world] when that certification was attempted).

  Inclusion of uncertified books can be handy, but it can have disastrous
  consequences.~/

  The provision allowing uncertified ~il[books] to be included can have
  disastrous consequences, ranging from hard lisp errors, to damaged memory, to
  quiet logical inconsistency.

  It is possible for the inclusion of an uncertified book to render the logic
  inconsistent.  For example, one of its non-~ilc[local] ~il[events] might be
  ~c[(defthm t-is-nil (equal t nil))].  It is also possible for the inclusion
  of an uncertified book to cause hard errors or ~il[breaks] into raw Common
  Lisp.  For example, if the file has been edited since it was certified, it
  may contain too many open parentheses, causing Lisp to read past ``end of
  file.'' Similarly, it might contain non-ACL2 objects such as ~c[3.1415] or
  ill-formed event forms that cause ACL2 code to break.

  Even if a book is perfectly well formed and could be certified (in a suitable
  extension of ACL2's initial ~il[world]), its uncertified inclusion might
  cause Lisp errors or inconsistencies!  For example, it might mention packages
  that do not exist in the host ~il[world], especially if the ~c[.port] file
  (discussed above) does not exist from an earlier certification attempt.  The
  ~il[portcullis] of a certified book ensures that the correct ~ilc[defpkg]s
  have been admitted, but if a book is read without actually raising its
  ~il[portcullis], symbols in the file, e.g., ~c[acl2-arithmetic::fn], could
  cause ``unknown package'' errors in Common Lisp.  Perhaps the most subtle
  disaster occurs if the host ~il[world] does have a ~ilc[defpkg] for each
  package used in the book but the host ~ilc[defpkg] imports different symbols
  than those required by the ~il[portcullis].  In this case, it is possible
  that formulas which were theorems in the certified book are non-theorems in
  the host ~il[world], but those formulas can be read without error and will
  then be quietly assumed.

  In short, if you include an uncertified book, ~st[all bets are off] regarding
  the validity of the future behavior of ACL2.

  That said, it should be noted that ACL2 is pretty tough and if errors don't
  occur, the chances are that deductions after the inclusion of an uncertified
  book are probably justified in the (possibly inconsistent) logical extension
  obtained by assuming the admissibility and validity of the definitions and
  conjectures in the book.")

(deflabel books-certification-classic
  :Doc
  ":Doc-Section Books

  classic ACL2 `make'-based certification of ~il[books]~/

  This ~il[documentation] topic explains an approach to certifying directories
  of books, which we call ``classic ACL2 `make'-based certification''.

  Warning: The capability described in this section might be replaced at any
  time by a capability based on corresponding support for community books
  (~pl[books-certification]).  If you think that would be a hardship, please
  contact the ACL2 implementors.

  This topic discusses a way to certify a directory of books other than the
  ACL2 community books.  ~l[books-certification] for how to certify the set of
  ACL2 community ~il[books].  There is also a section in that
  ~il[documentation] topic, ``Restricting to Specific Directories and Books'',
  that provides an alternative to classic ACL2 `make'-based certification (as
  discussed in the present topic) for certifying specified sets of books.

  We assume here a familiarity with Unix/Linux `make'.  We also assume that
  you are using GNU `make' rather than some other flavor of `make'.  And
  finally, we assume, as is typically the case by following the standard
  installation instructions, that you install the ACL2 community books in the
  ~c[books/] subdirectory of your ACL2 distribution.  We will refer below to
  that directory as ~c[BOOKS].

  In summary: to use `make' to certify ~il[books] under a given directory, you
  may create a simple Makefile in that directory (as explained below) so that
  when you stand in that directory, you can submit the command, `make', to
  certify those books.  If you have a multi-processor machine or the like, then
  you can use the `~c[-j] flag `make'-level parallelism by specifying the
  number of concurrent processes.  For example:
  ~bv[]
  make -j 4
  ~ev[]
  For each book ~c[foo.lisp], a file ~c[foo.out] in the same directory as
  ~c[foo.lisp] will contain the output from the corresponding certification
  attempt.  If you have previously executed such a command, then you might
  first want to delete ~il[certificate] files and other generated files by
  executing the following command.
  ~bv[]
  make clean
  ~ev[]

  Note that when you run `make', then by default, the first error will cause
  the process to stop.  You can use ~c[make -i] to force `make' to ignore
  errors, thus continuing past them.  Or, use ~c[make -k] to keep going, but
  skipping certification for any book that includes another whose certification
  has failed.

  By default, your acl2-customization file (~pl[acl2-customization]) is ignored
  by such `make' commands.  However, you can specify the use of an
  acl2-customization file by setting the value of environment variable
  ~c[ACL2_CUSTOMIZATION] to the empty string, indicating a default such file,
  or to the desired absolute pathname.  For example:
  ~bv[]
  make ACL2_CUSTOMIZATION=''
  make ACL2_CUSTOMIZATION='~~/acl2-customization.lisp'
  ~ev[]

  We now discuss how to create makefiles to support `make' commands as
  discussed above.~/

  First we give five steps for creating a ~c[Makefile] to support certification
  of a directory of books, without subdirectories.  For examples of such
  Makefiles you can look in community book directories (which, however, might
  disappear in future versions of ACL2).
  ~bq[]
  1. Include the file ~c[Makefile-generic] from the ~c[books/] subdirectory of
  your ACL2 sources directory, but first perhaps define the variable
  `~c[ACL2]'.  Consider the following example.
  ~bv[]
  ACL2 ?= /Users/john_doe/acl2/acl2-sources/saved_acl2
  include /Users/john_doe/acl2/acl2-sources/books/Makefile-generic
  ~ev[]
  In this example, you can omit the first line, because the default ACL2
  executable is file ~c[saved_acl2] in the directory immediately above the
  directory of the specified ~c[Makefile-generic] file.  Indeed, that is the
  common case.  Note the use of ~c[?=] instead of ~c[=] or ~c[:=], so that
  ~c[ACL2] can instead be defined by the environment or provided on the command
  line as part of the `make' command.

  2. (Optional; usually skipped.)  Set the ~c[INHIBIT] variable if you want to
  see more than the summary output.  For example, if you want to see the same
  output as you would normally see at the terminal, put this line in your
  Makefile after the `~c[include]' lines.
  ~bv[]
  INHIBIT = (assign inhibit-output-lst (list (quote proof-tree)))
  ~ev[]
  For other values to use for ~c[INHIBIT], ~pl[set-inhibit-output-lst] and see
  the original setting of ~c[INHIBIT] in ~c[books/Makefile-generic].

  3. Specify the books to be certified.  Normally, every file with extension
  ~c[.lisp] will be a book that you want to certify, in which case you can skip
  this step.  Otherwise, put a line in your ~c[Makefile] after the ones above
  that specifies the books to be certified.  The following example, from an old
  version of community books file ~c[books/finite-set-theory/osets/Makefile],
  should make this clear.
  ~bv[]
  BOOKS = computed-hints fast instance map membership outer primitives \\
          quantify set-order sets sort
  ~ev[]
  But better yet, use the extension ~c[.lsp] for any Lisp or ACL2 files that
  are not to be certified, so that the definition of ~c[BOOKS] can be omitted.

  4. Create ~c[.acl2] files for books that are to be certified in other than
  the initial ACL2 world (~pl[portcullis]).  For example, if you look in
  community books file ~c[books/arithmetic/equalities.acl2] you will see
  ~ilc[defpkg] forms followed by a ~ilc[certify-book] command, because it was
  determined that ~ilc[defpkg] forms were necessary in the certification world
  in order to certify the ~c[equalities] book.  In general, for each
  ~c[<book-name>.lisp] whose certification requires a non-initial certification
  world, you will need a corresponding ~c[<book-name>.acl2] file that ends with
  the appropriate ~ilc[certify-book] command.

  You also have the option of creating a file ~c[cert.acl2] that has a special
  role.  When file ~c[<book-name>.lisp] is certified, if there is no file
  ~c[<book-name>.acl2] but there is a file ~c[cert.acl2], then ~c[cert.acl2]
  will be used as ~c[<book-name>.acl2] would have been used, as described in
  the preceding paragraph, except that the appropriate ~ilc[certify-book]
  command will be generated automatically.  Thus, no ~c[certify-book] command
  should occur in ~c[cert.acl2].

  It is actually allowed to put raw lisp forms in a ~c[.acl2] file (presumably
  preceded by ~c[:q] or ~c[(value :q)] and followed by ~c[(lp)]).  But this is
  not recommended; we make no guarantees about certification performed any time
  after raw Lisp has been entered in the ACL2 session.

  5. Generally, the next step is to include the following line after the
  `~c[include]' of ~c[Makefile-generic] (see the first step above).
  ~bv[]
  -include Makefile-deps
  ~ev[]
  This will cause `make' to create and then include a file
  ~c[Makefile-deps] that contains ``dependency'' lines needed by `make'.
  If those dependencies are somehow flawed, it may be because you have
  ~ilc[include-book] forms that are not truly including books, for example in
  multi-line comments (~c[#|..|#]).  These will be ignored if preceded by a
  semicolon (~c[;]), or if you add a line break after ``~c[include-book].''
  But instead of adding the `~c[-include]' line above, you can create
  dependency lines yourself by running the command
  ~bv[]
  make dependencies
  ~ev[]
  and pasting the result into the end of your ~c[Makefile], and editing as you
  see fit.~eq[]

  This concludes the basic instructions for creating a ~c[Makefile] in a
  directory including books.  Here are some other capabilities offered by
  community books file ~c[books/Makefile-subdirs].  Not included below is a
  discussion of how to increase parallelism by avoiding the need to certify
  included books before certifying a given book;
  ~pl[provisional-certification].

  ~st[Subdirectory Support]

  There is support for using `make' to certify books in subdirectories.
  Consider the following example.
  ~bv[]
  DIRS = pass1 bind-free floor-mod
  include ../Makefile-subdirs
  ~ev[]
  This indicates that we are to run `make' in subdirectories ~c[pass1/],
  ~c[bind-free/], and ~c[floor-mod/] of the current directory.

  You can combine this subdirectory support with the support already discussed
  for certifying books in the top-level directory.  Here is an example, which
  as of this writing is in community books file ~c[books/arithmetic-3/Makefile]
  contains the following lines.
  ~bv[]
  arith-top: top all
  all: top

  DIRS = pass1 bind-free floor-mod
  include ../Makefile-subdirs
  include ../Makefile-generic

  -include Makefile-deps
  ~ev[]
  The `~c[top]' target is defined in ~c[../Makefile-subdirs] to call `make' in
  each subdirectory specified in ~c[DIRS].  We have set the default target in
  the example above to a new name, ~c[arith-top], that makes that ~c[top]
  target before making the `~c[all]' target which, in turn, is the default
  target in any ~c[Makefile-generic], and is responsible for certifying books
  in the current directory as discussed in the five steps displayed above.

  Use ~c[Makefile-psubdirs] instead of ~c[Makefile-subdirs] if certification of
  a book in a subdirectory never depends on certification of a book in a
  different subdirectory, because then the ~c[-j] option of `make' can allow
  subdirectories to be processed in parallel.

  ~st[Cleaning Up]

  We note that there is a ~c[clean] target.  Thus,
  ~bv[]
  make clean
  ~ev[]
  will remove generated files including ~c[.cert], ~c[.out] files, and compiled
  files.

  ~st[System Books]

  An environment variable ~c[ACL2_SYSTEM_BOOKS] is generally set automatically,
  so you can probably skip reading the following paragraph unless your attempt
  to certify books fails to locate those books properly.

  The environment variable ~c[ACL2_SYSTEM_BOOKS] can be set to the top-level
  directory of the ACL2 community books.  A Unix-style pathname, typically
  ending in ~c[books/] or ~c[books], is permissible.  In most cases, your ACL2
  executable is a small script in which you can set this environment variable
  just above the line on which the actual ACL2 image is invoked, for example:
  ~bv[]
  export ACL2_SYSTEM_BOOKS
  ACL2_SYSTEM_BOOKS=/home/acl2/v3-2/acl2-sources/books
  ~ev[]
  However, you can also set ~c[ACL2_SYSTEM_BOOKS] as a `make' variable, by
  setting it in your ~c[Makefile] before the first target definition, e.g.:
  ~bv[]
  ACL2_SYSTEM_BOOKS ?= /home/acl2/v3-2/acl2-sources/books
  ~ev[]

  ~st[Compilation Support]

  The file ~c[books/Makefile-generic] provides support for compiling books that
  are already certified (but ~pl[compilation] for an exception).  For example,
  suppose that you have certified books using GCL as the host Lisp, resulting
  in compiled files with the ~c[.o] extension.  Now suppose you would like to
  compile the books for Allegro Common Lisp, whose compiled files have the
  ~c[.fasl] extension.  The following command will work if you have included
  ~c[books/Makefile-generic] in your ~c[Makefile].
  ~bv[]
  make fasl
  ~ev[]
  In general, the compiled file extension for a Lisp supported by ACL2 will be
  a target name for building compiled files for all your books (after
  certifying the books, if not already up-to-date on certification).

  If you run into problems, you can get help by joining the ~c[acl2-help] email
  list (follow the link from the ACL2 home page) and sending a message to that
  list.  Also consider trying another version of GNU `make'; for example, we
  have found that versions 3.81 and 3.82 sometimes cause errors on Linux where
  version 3.80 does not.")

(defdoc books-certification

  ":Doc-Section Books

  certifying ACL2 community ~il[books]~/

  For background on the ACL2 community books, ~pl[community-books].  Here we
  explain how to certify those books, or some of those books, with ACL2.  We
  thank Bishop Brock, Jared Davis, and Sol Swords for their substantial
  contributions to this methodology.  See ~c[books/Makefile], in the community
  books, for more about ``Credits and History'', and for additional technical
  details not covered in this topic (for example, how to build a local copy of
  the xdoc manual for those who may wish to do that).

  For more information about installing ACL2, see the installation
  instructions, either by following a link from the ACL2 home page or by going
  directly to the page
  ~url[http://www.cs.utexas.edu/users/moore/acl2/current/installation/installation.html].
  For information about so-called ``classic ACL2 `make'-based certification'',
  which provides support for certifying directories of books but may disappear
  in a future ACL2 release, ~pl[books-certification-classic].

  ~st[The Basics]

  We make the following assumptions.
  ~bq[]
  o Gnu `make' is available on your system via the `make' command (rather
  than some other flavor of `make').  (Execute `~c[make --version] to verify
  this.)

  o You have built or obtained an ACL2 executable.

  o The ACL2 community books are installed in the ~c[books/] subdirectory of
  your ACL2 distribution, as is the case when you have followed the standard
  installation instructions.

  o All commands shown below are issued in the top-level (ACL2 sources)
  directory of your ACL2 distribution.~eq[]

  By default the ACL2 executable is file ~c[saved_acl2] in your ACL2 sources
  directory, and you can issue the following command to the shell in order to
  do a ``regression run'' that certifies all of the community books using that
  executable.
  ~bv[]
  make regression
  ~ev[]
  Better yet, save a log file in case there are problems, for example as
  follows.
  ~bv[]
  (make regression) >& make-regression.log
  ~ev[]
  or perhaps better yet:
  ~bv[]
  (time nice make regression) >& make-regression.log
  ~ev[]
  For the sake of brevity, below we'll skip mentioning any of `~c[time]',
  `~c[nice]', or `~c[>& make-regression.log]'.  But saving a log file, in
  particular, is useful in case you encounter problems to report.

  If you fetched the community books using svn, then you will have a directory
  ~c[books/workshops/] that is not necessary for certifying the other books.
  If you want to skip certification of the books under ~c[books/workshops/],
  use target `~c[certify-books]' instead of target `~c[regression]', for
  example as follows.
  ~bv[]
  (time nice make certify-books) >& make-certify-books.log
  ~ev[]

  Whether you use target `~c[regression]' or target `~c[certify-books]', then
  for each book ~c[foo.lisp] whose certification is attempted, a file
  ~c[foo.cert.out] in the same directory will contain the output from the
  book's certification attempt.

  A regression run may take a few hours, but if you have a multiprocessing
  computer, you can speed it up by certifying some books in parallel, by
  providing a value for `make' option ~c[-j].  For example, if you have 8
  hardware threads then you might want to issue the following command.
  ~bv[]
  make regression -j 8
  ~ev[]~/

  ~st[Specifying the ACL2 Executable]

  If your ACL2 executable is not file ~c[saved_acl2] in the ACL2 sources
  directory, then you will need to specify that executable.  You can do that by
  setting variable ~c[ACL2], either as an environment variable or, as displayed
  below, as a `make' variable.  Either way, you will need to avoid relative
  pathnames.  For example, the first two forms below are legal, but the third
  is not, assuming that ~c[my-acl2] is on your ~c[PATH] in a Unix-like
  environment (e.g., linux or MacOS) and that ~c[my-saved_acl2] is just a
  pathname relative to your ACL2 sources directory, which is not on your path.
  ~bv[]
  make regression -j 8 ACL2=my-acl2
  make regression -j 8 ACL2=/u/smith/bin/acl2
  # The following only works if my-saved_acl2 is on your path (see above).
  make regression -j 8 ACL2=my-saved_acl2
  ~ev[]

  ~st[Cleaning]

  You can delete files generated by book certification (including ~c[.cert]
  files, ~c[.out] files, compiled files, and more) by issuing the following
  command (again, in your ACL2 sources directory).
  ~bv[]
  make clean-books
  ~ev[]
  If you want to cause such deletion and then do a regression, simply replace
  the `~c[regression]' or `~c[certify-books]' target by `~c[regression-fresh]'
  or `~c[certify-books-fresh]', respectively, for example as follows.
  follows.
  ~bv[]
  make -j 4 regression-fresh
  make -j 4 certify-books-fresh
  ~ev[]

  If however you only want to clean up generated files residing under a given
  directory (or its subdirectories, and recursively), you can issue the
  following command while standing in that directory, where ~c[DIR] is a
  pathname of your ~c[books] directory.
  ~bv[]
  DIR/clean.pl
  ~ev[]
  For example, to clean up generated files under ~c[books/arithmetic], you
  could do the following.
  ~bv[]
  cd books/arithmetic
  ../clean.pl
  cd - # to return to the ACL2 sources directory, if you wish to do so
  ~ev[]

  ~st[Restricting to Specific Directories and Books]

  You can specify which books you want certified by using any or all of the
  variables ~c[EXCLUDED_PREFIXES], ~c[ACL2_BOOK_CERTS], or ~c[ACL2_BOOK_DIRS].
  First, the set of desired ~c[.cert] files is restricted to those that do not
  start with any string that is one of the words in the value of
  ~c[EXCLUDED_PREFIXES].  Then ~c[ACL2_BOOK_CERTS] and ~c[ACL2_BOOK_DIRS], if
  supplied, specify which books should be certified, as illustrated by the
  following example.
  ~bv[]
  make -j 8 regression-fresh \\
   ACL2_BOOK_DIRS=\"symbolic paco\" \\
   ACL2_BOOK_CERTS=\" \\
    workshops/2006/cowles-gamboa-euclid/Euclid/ed6a.cert \\
    workshops/2006/cowles-gamboa-euclid/Euclid/ed4bb.cert \\
    \"
  ~ev[]
  Then all book in directories ~c[symbolic] and ~c[paco] will be certified, as
  will the books ~c[workshops/2006/cowles-gamboa-euclid/Euclid/ed6a.lisp] and
  ~c[workshops/2006/cowles-gamboa-euclid/Euclid/ed4bb.lisp].  Note that all
  pathnames should be relative to your community books directory; in
  particular, they should not be absolute pathnames.  Also notice the ~c[.cert]
  extension used in files supplied for ~c[ACL2_BOOK_CERTS].

  Alternatively, you may wish to invoke ~c[books/cert.pl] while standing in a
  directory under which you want to certify books.  This will certify not only
  those books, but all supporting books ~-[] even those not under the current
  directory ~-[] that do not have up-to-date ~c[.cert] files.  The following is
  a simple command to invoke that will certify all books in the current
  directory, where if the ~c[books/] directory is not on your path, you will
  need to provide a suitable filename, e.g. ~c[../../cert.pl] or
  ~c[~~/acl2/books/cert.pl].
  ~bv[]
  cert.pl -j 4 *.lisp
  ~ev[]
  Here is a more complex command, which illustrates a way to certify books in
  subdirectories (as well as the current directory), the use of provisional
  certification (~pl[provisional-certification]), and `make'-level parallelism
  (in this case specifying four parallel processes).
  ~bv[]
  ACL2_PCERT=t cert.pl -j 4 `find . -name '*.lisp'`
  ~ev[]
  Note that with this approach, unlike classic ACL2 `make'-based certification
  (~pl[books-certification-classic], out-of-date ~c[.cert] files that are not
  under the current directory will also be built.  For documentation of
  ~c[cert.pl] invoke:
  ~bv[]
  cert.pl -h
  ~ev[]
  See the top of ~c[cert.pl] for authorship and copyright information.

  Finally, we give a brief summary of how to use so-called ``classic ACL2
  `make'-based certification'' for community books;
  ~pl[books-certification-classic] for details.  Note that support for this
  approach might be eliminated in a future ACL2 release.  We welcome comments
  from the ACL2 community about whether or not that would be a good thing to
  do.  See the discussion above about ~c[ACL2_BOOK_DIRS] for the ``modern'' way
  to accomplish the same thing.

  Many community book directories have a ~c[Makefile].  If you modify books
  only in such a directory, you can recertify by standing in that directory and
  issuing a `make' command.  This command can optionally specify an ACL2
  executable as well as parallelism, for example as follows, where the first
  line (~c[make clean]) is optional.
  ~bv[]
  make clean
  (time nice make -j 8 ACL2=my-acl2)
  ~ev[]

  ~st[ACL2 Customization Files]

  By default, your acl2-customization file (~pl[acl2-customization]) is ignored
  by all flavors of ``~c[make regression]''.  However, you can specify the use
  of an acl2-customization file by setting the value of environment variable
  ~c[ACL2_CUSTOMIZATION] to the empty string, indicating a default such file,
  or to the desired absolute pathname.  For example:
  ~bv[]
  make regression ACL2_CUSTOMIZATION=''
  make regression ACL2_CUSTOMIZATION='~~/acl2-customization.lisp'
  ~ev[]

  ~st[Regressions for Experimental Extensions of ACL2]

  The instructions are unchanged if you are using ACL2(h)
  (~pl[hons-and-memoization]).  However, note that the default executable (when
  ~c[ACL2] is not specified) remains ~c[saved_acl2] in your ACL2 sources
  directory, not ~c[saved_acl2h] as one might expect for ACL2(h)(p),
  respectively.  So probably you'll want to supply ``~c[ACL2=<your_acl2>]''
  explicitly with your `make' command.

  The comments above also pertain pertain to using ACL2(p) (~pl[parallel]); the
  default is ~c[saved_acl2] rather than ~c[saved_acl2p].  However, we recommend
  that you use ACL2, not ACL2(p), for your regression.  Then you can use
  ACL2(p) for your own proof developments.  (The analogous comment applies to
  ACL2(hp), which combines capabilities of ACL2(h) and ACL2(p), i.e., we
  recommend that you use ACl2(h) for your regression in that case.)  However,
  if you want to use ACL2(p) or ACL2(hp) for your regression,
  ~pl[waterfall-parallelism-for-book-certification].

  If you intend to certify books in the ~c[nonstd] subdirectory of the
  community books, you will want to use ACL2(r) (~pl[real]).  In that case,
  substitute target ~c[regression-nonstd] for target ~c[regression].  The
  default executable (when ~c[ACL2] is not specified) will be file
  ~c[saved_acl2r] in your ACL2 sources directory, rather than ~c[saved_acl2].

  ~st[Provisional Certification]

  To use provisional certification (~pl[provisional-certification]), supply
  ~c[ACL2_PCERT=t] with your `make' command.  Here is an example.
  ~bv[]
  time nice make regression -j 4 ACL2_BOOK_DIRS=deduction ACL2_PCERT=t
  ~ev[]

  ~st[Miscellany]

  Other control of the certification process may be found by perusing community
  books file ~c[books/make_cert].  In particular, the ~c[INHIBIT] variable
  may be set to a call of ~ilc[set-inhibit-output-lst], for example as
  follows to obtain the output one would get by default in an (interactive)
  ACL2 session.
  ~bv[]
  time nice make regression -j 4 ACL2_BOOK_DIRS=arithmetic \\
    INHIBIT='(set-inhibit-output-lst proof-tree)'
  ~ev[]

  ~st[Troubleshooting]

  If you run into problems, you can get help by joining the ~c[acl2-help] email
  list (follow the link from the ACL2 home page) and sending a message to that
  list.  Also consider trying another version of GNU `make'; for example, we
  have found that versions 3.81 and 3.82 sometimes cause errors on Linux where
  version 3.80 does not.  Note however that Version 3.80 does not print certain
  informational messages that are printed by later versions.~/")

(link-doc-to regression books books-certification)

; 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 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
                   `(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
                   `(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 (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
    (if (output-in-infixp state) event-form (cons 'defchoose (car def)))
    (let* ((wrld (w state))
           (event-form (or event-form (cons 'defchoose def)))
           (raw-bound-vars (cadr def))
           (valid-keywords '(:doc :strengthen))
           (ka (nthcdr 4 def)) ; def is the argument list of a defchoose call
           (doc (cadr (assoc-keyword :doc ka)))
           (strengthen (cadr (assoc-keyword :strengthen def))))
      (er-progn
       (chk-all-but-new-name (car def) ctx 'constrained-function wrld state)
       (cond
        ((not (and (keyword-value-listp ka)
                   (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 arguments ~&0. However, ~
              ~x1 does not have this form.  See :DOC defchoose."
             valid-keywords
             event-form))
        ((and doc
              (not (doc-stringp doc)))
         (er soft ctx
             "Illegal doc string has been supplied in ~x0.  See :DOC ~
              doc-string."
             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))
        (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 'function nil ctx wrld state))
                 (doc-pair (translate-doc fn doc ctx 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))
                         (diff (set-difference-eq bound-and-free-vars
                                                  body-vars))
                         (ignore-ok (cdr (assoc-eq
                                          :ignore-ok
                                          (table-alist 'acl2-defaults-table
                                                       wrld)))))
                    (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."
                          (set-difference-eq body-vars
                                             (append bound-vars formals))
                          event-form))
                     ((and diff
                           (null ignore-ok))
                      (er soft ctx
                          "The variable~#0~[ ~&0~ occurs~/s ~&0 occur~] in the ~
                           body of the form ~x1.  However, ~#0~[this variable ~
                           does~/these variables do~] not appear either in the ~
                           bound variables or the formals of that form.  In ~
                           order to avoid this error, see :DOC set-ignore-ok."
                          diff
                          event-form))
                     (t
                      (pprogn
                       (cond
                        ((eq ignore-ok :warn)
                         (warning$ ctx "Ignored-variables"
                                   "The variable~#0~[ ~&0 occurs~/s ~&0 ~
                                    occur~] in the body of the following ~
                                    defchoose form:~|~x1~|However, ~#0~[this ~
                                    variable does~/these variables do~] not ~
                                    appear either in the bound variables or ~
                                    the formals of that form.  In order to ~
                                    avoid this warning, see :DOC set-ignore-ok."
                                   diff
                                   event-form))
                        (t state))
                       (let* ((stobjs-in
                               (compute-stobj-flags formals nil wrld))
                              (stobjs-out
                               (compute-stobj-flags bound-vars 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
                                     (update-doc-database
                                      fn doc doc-pair 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))))))))))))))))))))))

(defun non-acceptable-defun-sk-p (name args body doc quant-ok rewrite exists-p)

; 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.

  (declare (ignore doc))
  (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 (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)
                (symbolp (car body))
                (member-equal (symbol-name (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 FORALL or EXISTS and vars is a ~
            variable or a true list of variables.  The body ~x0 is therefore ~
            illegal."
           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 (symbol-name-tree-occur 'forall (caddr body))
               (symbol-name-tree-occur '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; sadly, this is not yet the case ~
            (though you are welcome to contact the implementors and request ~
            this capability).  If however you really intend this DEFUN-SK form ~
            to be executed (because, for example, ~x0 is in the scope of a ~
            macro that expands it away), simply give a non-nil :quant-ok ~
            argument.  See :DOC defun-sk."
           (if (symbol-name-tree-occur 'forall (caddr body))
               'forall
             'exists)
           body))
     (t nil))))

(defmacro defun-sk (name args body
                         &key
                         doc quant-ok skolem-name thm-name rewrite strengthen
                         #+:non-standard-analysis
                         (classicalp 't classicalp-p)
                         (witness-dcls
                          '((declare (xargs :non-executable t)))))

  ":Doc-Section Events

  define a function whose body has an outermost quantifier~/
  ~bv[]
  Examples:
  (defun-sk exists-x-p0-and-q0 (y z)
    (exists x
            (and (p0 x y z)
                 (q0 x y z))))

  (defun-sk exists-x-p0-and-q0 (y z) ; equivalent to the above
    (exists (x)
            (and (p0 x y z)
                 (q0 x y z))))

  (defun-sk forall-x-y-p0-and-q0 (z)
    (forall (x y)
            (and (p0 x y z)
                 (q0 x y z)))
    :strengthen t)~/

  General Form:
  (defun-sk fn (var1 ... varn) body
    &key rewrite doc quant-ok skolem-name thm-name witness-dcls strengthen)
  ~ev[]
  where ~c[fn] is the symbol you wish to define and is a new symbolic
  name (~pl[name]), ~c[(var1 ... varn)] is its list of formal
  parameters (~pl[name]), and ~c[body] is its body, which must be
  quantified as described below.  The ~c[&key] argument ~ilc[doc] is an optional
  ~il[documentation] string to be associated with ~c[fn]; for a description
  of its form, ~pl[doc-string].  In the case that ~c[n] is 1, the list
  ~c[(var1)] may be replaced by simply ~c[var1].  The other arguments are
  explained below.

  For a simple example, ~pl[defun-sk-example].  For a more elaborate example,
  ~pl[Tutorial4-Defun-Sk-Example].  ~l[quantifier-tutorial] for a careful
  beginner's introduction that takes you through typical kinds of
  quantifier-based reasoning in ACL2.  Also ~pl[quantifiers] for an example
  illustrating how the use of recursion, rather than explicit quantification
  with ~c[defun-sk], may be preferable.

  Below we describe the ~c[defun-sk] event precisely.  First, let us
  consider the examples above.  The first example, again, is:
  ~bv[]
  (defun-sk exists-x-p0-and-q0 (y z)
    (exists x
            (and (p0 x y z)
                 (q0 x y z))))
  ~ev[]
  It is intended to represent the predicate with formal parameters ~c[y]
  and ~c[z] that holds when for some ~c[x], ~c[(and (p0 x y z) (q0 x y z))]
  holds.  In fact ~c[defun-sk] is a macro that adds the following two
  ~il[events], as shown just below.  The first event guarantees that if
  this new predicate holds of ~c[y] and ~c[z], then the term shown,
  ~c[(exists-x-p0-and-q0-witness y z)], is an example of the ~c[x] that is
  therefore supposed to exist.  (Intuitively, we are axiomatizing
  ~c[exists-x-p0-and-q0-witness] to pick a witness if there is one.
  We comment below on the use of ~ilc[defun-nx]; for now, consider ~c[defun-nx]
  to be ~ilc[defun].)  Conversely, the second event below guarantees that if
  there is any ~c[x] for which the term in question holds, then the new
  predicate does indeed hold of ~c[y] and ~c[z].
  ~bv[]
  (defun-nx exists-x-p0-and-q0 (y z)
    (let ((x (exists-x-p0-and-q0-witness y z)))
      (and (p0 x y z) (q0 x y z))))
  (defthm exists-x-p0-and-q0-suff
    (implies (and (p0 x y z) (q0 x y z))
             (exists-x-p0-and-q0 y z)))
  ~ev[]
  Now let us look at the third example from the introduction above:
  ~bv[]
  (defun-sk forall-x-y-p0-and-q0 (z)
    (forall (x y)
            (and (p0 x y z)
                 (q0 x y z))))
  ~ev[]
  The intention is to introduce a new predicate
  ~c[(forall-x-y-p0-and-q0 z)] which states that the indicated conjunction
  holds of all ~c[x] and all ~c[y] together with the given ~c[z].  This time, the
  axioms introduced are as shown below.  The first event guarantees
  that if the application of function ~c[forall-x-y-p0-and-q0-witness] to
  ~c[z] picks out values ~c[x] and ~c[y] for which the given term
  ~c[(and (p0 x y z) (q0 x y z))] holds, then the new predicate
  ~c[forall-x-y-p0-and-q0] holds of ~c[z].  Conversely, the (contrapositive
  of) the second axiom guarantees that if the new predicate holds of
  ~c[z], then the given term holds for all choices of ~c[x] and ~c[y] (and that
  same ~c[z]).
  ~bv[]
  (defun-nx forall-x-y-p0-and-q0 (z)
    (mv-let (x y)
            (forall-x-y-p0-and-q0-witness z)
            (and (p0 x y z) (q0 x y z))))
  (defthm forall-x-y-p0-and-q0-necc
    (implies (not (and (p0 x y z) (q0 x y z)))
             (not (forall-x-y-p0-and-q0 z))))
  ~ev[]
  The examples above suggest the critical property of ~c[defun-sk]:  it
  indeed does introduce the quantified notions that it claims to
  introduce.

  Notice that the ~ilc[defthm] event just above, ~c[forall-x-y-p0-and-q0-necc],
  may not be of optimal form as a rewrite rule.  Users sometimes find that when
  the quantifier is ~c[forall], it is useful to state this rule in a form where
  the new quantified predicate is a hypothesis instead.  In this case that form
  would be as follows:
  ~bv[]
  (defthm forall-x-y-p0-and-q0-necc
    (implies (forall-x-y-p0-and-q0 z)
             (and (p0 x y z) (q0 x y z))))
  ~ev[]
  ACL2 will turn this into one ~c[:]~ilc[rewrite] rule for each conjunct,
  ~c[(p0 x y z)] and ~c[(q0 x y z)], with hypothesis
  ~c[(forall-x-y-p0-and-q0 z)] in each case.  In order to get this effect, use
  ~c[:rewrite :direct], in this case as follows.
  ~bv[]
  (defun-sk forall-x-y-p0-and-q0 (z)
    (forall (x y)
            (and (p0 x y z)
                 (q0 x y z)))
    :rewrite :direct)
  ~ev[]

  We now turn to a detailed description of ~c[defun-sk], starting with a
  discussion of its arguments as shown in the \"General Form\" above.

  The third argument, ~c[body], must be of the form
  ~bv[]
  (Q bound-vars term)
  ~ev[]
  where:  ~c[Q] is the symbol ~ilc[forall] or ~ilc[exists] (in the \"ACL2\"
  package), ~c[bound-vars] is a variable or true list of variables
  disjoint from ~c[(var1 ... varn)] and not including ~ilc[state], and
  ~c[term] is a term.  The case that ~c[bound-vars] is a single variable
  ~c[v] is treated exactly the same as the case that ~c[bound-vars] is
  ~c[(v)].

  The result of this event is to introduce a ``Skolem function,'' whose name is
  the keyword argument ~c[skolem-name] if that is supplied, and otherwise is
  the result of modifying ~c[fn] by suffixing \"-WITNESS\" to its name.  The
  following definition and one of the following two theorems (as indicated) are
  introduced for ~c[skolem-name] and ~c[fn] in the case that ~c[bound-vars]
  (see above) is a single variable ~c[v].  The name of the ~ilc[defthm] event
  may be supplied as the value of the keyword argument ~c[:thm-name]; if it is
  not supplied, then it is the result of modifying ~c[fn] by suffixing
  \"-SUFF\" to its name in the case that the quantifier is ~ilc[exists], and
  \"-NECC\" in the case that the quantifier is ~ilc[forall].
  ~bv[]
  (defun-nx fn (var1 ... varn)
    (let ((v (skolem-name var1 ... varn)))
      term))

  (defthm fn-suff ;in case the quantifier is EXISTS
    (implies term
             (fn var1 ... varn)))

  (defthm fn-necc ;in case the quantifier is FORALL
    (implies (not term)
             (not (fn var1 ... varn))))
  ~ev[]

  In the ~c[forall] case, however, the keyword pair ~c[:rewrite :direct] may be
  supplied after the body of the ~c[defun-sk] form, in which case the
  contrapositive of the above form is used instead:
  ~bv[]
  (defthm fn-necc ;in case the quantifier is FORALL
    (implies (fn var1 ... varn)
             term))
  ~ev[]
  This is often a better choice for the \"-NECC\" rule, provided ACL2 can parse
  ~c[term] as a ~c[:]~ilc[rewrite] rule.  A second possible value of the
  ~c[:rewrite] argument of ~c[defun-sk] is ~c[:default], which gives the same
  behavior as when ~c[:rewrite] is omitted.  Otherwise, the value of
  ~c[:rewrite] should be the term to use as the body of the ~c[fn-necc] theorem
  shown above; ACL2 will attempt to do the requisite proof in this case.  If
  that term is weaker than the default, the properties introduced by
  ~c[defun-sk] may of course be weaker than they would be otherwise.  Finally,
  note that the ~c[:rewrite] keyword argument for ~c[defun-sk] only makes sense
  if the quantifier is ~c[forall]; it is thus illegal if the quantifier is
  ~c[exists].  Enough said about ~c[:rewrite]!

  In the case that ~c[bound-vars] is a list of at least two variables, say
  ~c[(bv1 ... bvk)], the definition above (with no keywords) is the following
  instead, but the theorem remains unchanged.
  ~bv[]
  (defun-nx fn (var1 ... varn)
    (mv-let (bv1 ... bvk)
            (skolem-name var1 ... varn)
            term))
  ~ev[]

  In order to emphasize that the last element of the list, ~c[body], is a
  term, ~c[defun-sk] checks that the symbols ~ilc[forall] and ~ilc[exists] do
  not appear anywhere in it.  However, on rare occasions one might
  deliberately choose to violate this convention, presumably because
  ~ilc[forall] or ~ilc[exists] is being used as a variable or because a
  macro call will be eliminating ``calls of'' ~ilc[forall] and ~ilc[exists].
  In these cases, the keyword argument ~c[quant-ok] may be supplied a
  non-~c[nil] value.  Then ~c[defun-sk] will permit ~ilc[forall] and
  ~ilc[exists] in the body, but it will still cause an error if there is
  a real attempt to use these symbols as quantifiers.

  The use of ~ilc[defun-nx] above, rather than ~ilc[defun], disables certain
  checks that are required for evaluation, in particular the single-threaded
  use of ~ilc[stobj]s.  However, there is a price: calls of these defined
  functions cannot be evaluated; ~pl[defun-nx].  Normally that is not a
  problem, since these notions involve quantifiers.  But you are welcome to
  replace this ~ilc[declare] form with your own, as follows: if you supply a
  list of ~c[declare] forms to keyword argument ~c[:witness-dcls], these will
  become the declare forms in the generated ~ilc[defun].  Note that if your
  value of ~c[witness-dcls] does not contain the form
  ~c[(declare (xargs :non-executable t))], then the appropriate wrapper for
  non-executable functions will not be added automatically, i.e., ~ilc[defun]
  will be used in place of ~c[defun-nx].  Note also that if ~il[guard]
  verification is attempted, then it will likely fail with an error message
  complaining that ``guard verification may depend on local properties.''  In
  that case, you may wish to delay guard verification, as in the following
  example.
  ~bv[]
  (encapsulate
   ()
   (defun-sk foo (x)
     (exists n (and (integerp n)
                    (< n x)))
     :witness-dcls ((declare (xargs :guard (integerp x)
                                    :verify-guards nil))))
   (verify-guards foo))
  ~ev[]

  ~c[Defun-sk] is a macro implemented using ~ilc[defchoose].  Hence, it should
  only be executed in ~il[defun-mode] ~c[:]~ilc[logic]; ~pl[defun-mode] and
  ~pl[defchoose].  Advanced feature: If argument ~c[:strengthen t] is passed to
  ~c[defun-sk], then ~c[:strengthen t] will generate the extra constraint that
  that is generated for the corresponding ~c[defchoose] event; ~pl[defchoose].
  You can use the command ~c[:]~ilc[pcb!] to see the event generated by a call
  of the ~c[defun-sk] macro.

  If you find that the rewrite rules introduced with a particular use of
  ~c[defun-sk] are not ideal, even when using the ~c[:rewrite] keyword
  discussed above (in the ~c[forall] case), then at least two reasonable
  courses of action are available for you.  Perhaps the best option is to prove
  the ~ilc[rewrite] rules you want.  If you see a pattern for creating rewrite
  rules from your ~c[defun-sk] events, you might want to write a macro that
  executes a ~c[defun-sk] followed by one or more ~ilc[defthm] events.  Another
  option is to write your own variant of the ~c[defun-sk] macro, say,
  ~c[my-defun-sk], for example by modifying a copy of the definition of
  ~c[defun-sk] from the ACL2 sources.

  If you want to represent nested quantifiers, you can use more than one
  ~c[defun-sk] event.  For example, in order to represent
  ~bv[]
  (forall x (exists y (p x y z)))
  ~ev[]
  you can use ~c[defun-sk] twice, for example as follows.
  ~bv[]
  (defun-sk exists-y-p (x z)
    (exists y (p x y z)))

  (defun-sk forall-x-exists-y-p (z)
    (forall x (exists-y-p x z)))
  ~ev[]

  Some distracting and unimportant warnings are inhibited during
  ~c[defun-sk].

  Note for ACL2(r) users (~pl[real]): In ACL2(r), the keyword ~c[:CLASSICALP]
  is also supported.  Its legal values are ~c[t] (the default) and ~c[nil], and
  it determines whether or not (respectively) ACL2(r) will consider ~c[fn] to
  be a classical function.  It must be the case that the value is
  ~c[t] (perhaps implicitly, by default) if and only if ~c[body] is classical.

  Note that this way of implementing quantifiers is not a new idea.  Hilbert
  was certainly aware of it 60 years ago!  Also
  ~pl[conservativity-of-defchoose] for a technical argument that justifies the
  logical conservativity of the ~ilc[defchoose] event in the sense of the paper
  by Kaufmann and Moore entitled ``Structured Theory Development for a
  Mechanized Logic'' (Journal of Automated Reasoning 26, no. 2 (2001),
  pp. 161-203).~/"

  (let* ((exists-p (and (true-listp body)
                        (symbolp (car body))
                        (equal (symbol-name (car body)) "EXISTS")))
         (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
              (intern-in-package-of-symbol
               (concatenate 'string (symbol-name name) "-WITNESS")
               name)))
         (thm-name
          (or thm-name
              (intern-in-package-of-symbol
               (concatenate 'string (symbol-name name)
                            (if exists-p "-SUFF" "-NECC"))
               name)))
         (msg (non-acceptable-defun-sk-p name args body doc quant-ok rewrite
                                         exists-p)))
    (if msg
        `(er soft '(defun-sk . ,name)
             "~@0"
             ',msg)
      `(encapsulate
        ()
        (logic)
        (set-match-free-default :all)
        (set-inhibit-warnings "Theory" "Use" "Free" "Non-rec" "Infected")
        (encapsulate
         ((,skolem-name ,args
                         ,(if (= (length bound-vars) 1)
                              (car bound-vars)
                            (cons 'mv bound-vars))
                         #+:non-standard-analysis
                         ,@(and classicalp-p
                                `(:classicalp ,classicalp))))
         (local (in-theory '(implies)))
         (local
          (defchoose ,skolem-name ,bound-vars ,args
            ,defchoose-body
            ,@(and strengthen
                   '(:strengthen t))))
         ,@(and strengthen
                `((defthm ,(packn (list 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)))
         (,(if (member-equal '(declare (xargs :non-executable t)) witness-dcls)
               'defun-nx
             'defun)
           ,name ,args
           ,@witness-dcls
           ,(if (= (length bound-vars) 1)
                `(let ((,(car bound-vars) (,skolem-name ,@args)))
                   ,body-guts)
              `(mv-let (,@bound-vars)
                       (,skolem-name ,@args)
                       ,body-guts)))
         (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))))
         ,@(if doc
               `((defdoc ,name ,doc))
             nil))))))

(deflabel forall
  :doc
  ":Doc-Section Defun-sk

  universal quantifier~/~/

  The symbol ~c[forall] (in the ACL2 package) represents universal
  quantification in the context of a ~ilc[defun-sk] form.
  ~l[defun-sk] and ~pl[exists].

  ~l[quantifiers] for an example illustrating how the use of
  recursion, rather than explicit quantification with ~ilc[defun-sk], may be
  preferable.")

(deflabel exists
  :doc
  ":Doc-Section Defun-sk

  existential quantifier~/~/

  The symbol ~c[exists] (in the ACL2 package) represents existential
  quantification in the context of a ~ilc[defun-sk] form.
  ~l[defun-sk] and ~pl[forall].

  ~l[quantifiers] for an example illustrating how the use of
  recursion, rather than explicit quantification with ~ilc[defun-sk], may be
  preferable.")

(deflabel defun-sk-example
  :doc
  ":Doc-Section Defun-sk

  a simple example using ~ilc[defun-sk]~/~/

  For a more through, systematic beginner's introduction to quantification in
  ACL2, ~pl[quantifier-tutorial].

  The following example illustrates how to do proofs about functions defined
  with ~ilc[defun-sk].  The events below can be put into a certifiable book
  (~pl[books]).  The example is contrived and rather silly, in that it shows
  how to prove that a quantified notion implies itself, where the antecedent
  and conclusion are defined with different ~ilc[defun-sk] events.  But it
  illustrates the formulas that are generated by ~ilc[defun-sk], and how to use
  them.  Thanks to Julien Schmaltz for presenting this example as a challenge.
  ~bv[]
  (in-package \"ACL2\")

  (encapsulate
   (((p *) => *)
    ((expr *) => *))

   (local (defun p (x) x))
   (local (defun expr (x) x)))

  (defun-sk forall-expr1 (x)
    (forall (y) (implies (p x) (expr y))))

  (defun-sk forall-expr2 (x)
    (forall (y) (implies (p x) (expr y)))))

  ; We want to prove the theorem my-theorem below.  What axioms are there that
  ; can help us?  If you submit the command

  ; :pcb! forall-expr1

  ; then you will see the following two key events.  (They are completely
  ; analogous of course for FORALL-EXPR2.)

  ;   (DEFUN FORALL-EXPR1 (X)
  ;     (LET ((Y (FORALL-EXPR1-WITNESS X)))
  ;          (IMPLIES (P X) (EXPR Y))))
  ;
  ;   (DEFTHM FORALL-EXPR1-NECC
  ;     (IMPLIES (NOT (IMPLIES (P X) (EXPR Y)))
  ;              (NOT (FORALL-EXPR1 X)))
  ;     :HINTS
  ;     ((\"Goal\" :USE FORALL-EXPR1-WITNESS)))

  ; We see that the latter has value when FORALL-EXPR1 occurs negated in a
  ; conclusion, or (therefore) positively in a hypothesis.  A good rule to
  ; remember is that the former has value in the opposite circumstance: negated
  ; in a hypothesis or positively in a conclusion.

  ; In our theorem, FORALL-EXPR2 occurs positively in the conclusion, so its
  ; definition should be of use.  We therefore leave its definition enabled,
  ; and disable the definition of FORALL-EXPR1.

  ;   (thm
  ;     (implies (and (p x) (forall-expr1 x))
  ;              (forall-expr2 x))
  ;     :hints ((\"Goal\" :in-theory (disable forall-expr1))))
  ;
  ;   ; which yields this unproved subgoal:
  ;
  ;   (IMPLIES (AND (P X) (FORALL-EXPR1 X))
  ;            (EXPR (FORALL-EXPR2-WITNESS X)))

  ; Now we can see how to use FORALL-EXPR1-NECC to complete the proof, by
  ; binding y to (FORALL-EXPR2-WITNESS X).

  ; We use defthmd below so that the following doesn't interfere with the
  ; second proof, in my-theorem-again that follows.
  (defthmd my-theorem
    (implies (and (p x) (forall-expr1 x))
             (forall-expr2 x))
    :hints ((\"Goal\"
             :use ((:instance forall-expr1-necc
                              (x x)
                              (y (forall-expr2-witness x)))))))

  ; The following illustrates a more advanced technique to consider in such
  ; cases.  If we disable forall-expr1, then we can similarly succeed by having
  ; FORALL-EXPR1-NECC applied as a :rewrite rule, with an appropriate hint in how
  ; to instantiate its free variable.  See :doc hints.

  (defthm my-theorem-again
    (implies (and (P x) (forall-expr1 x))
             (forall-expr2 x))
    :hints ((\"Goal\"
             :in-theory (disable forall-expr1)
             :restrict ((forall-expr1-necc
                         ((y (forall-expr2-witness x))))))))
  ~ev[]")

(defdoc quantifier-tutorial
  ":Doc-Section Defun-sk

  A Beginner's Guide to Reasoning about Quantification in ACL2~/

  The initial version of this tutorial was written by Sandip Ray.  Additions
  and revisions are welcome.  Sandip has said:
  ~bq[]
  ``This is a collection of notes that I wrote to remind myself of how to
  reason about quantifiers when I just started.  Most users after they have
  gotten the hang of quantifiers probably will not need this and will be able
  to use their intuitions to guide them in the process.  But since many ACL2
  users are not used to quantification, I am hoping that this set of notes
  might help them to think clearly while reasoning about quantifiers in
  ACL2.''~eq[]

  Many ACL2 papers start with the sentence ``ACL2 is a quantifier-free
  first-order logic of recursive functions.''  It is true that the ~em[syntax]
  of ACL2 is quantifier-free; every formula is assumed to be universally
  quantified over all free variables in the formula.  But the ~em[logic] in
  fact does afford arbitrary first-order quantification.  This is obtained in
  ACL2 using a construct called ~c[defun-sk].  ~l[defun-sk].

  Many ACL2 users do not think in terms of ~il[quantifiers].  The focus is
  almost always on defining recursive functions and reasoning about them using
  induction.  That is entirely justified, in fact, since proving theorems about
  recursive functions by induction plays to the strengths of the theorem
  prover.  Nevertheless there are situations where it is reasonable and often
  useful to think in terms of quantifiers.  However, reasoning about
  quantifiers requires that you get into the mindset of thinking about theorems
  in terms of quantification.  This note is about how to do this effectively
  given ACL2's implementation of quantification.  This does not discuss
  ~ilc[defun-sk] in detail, but merely shows some examples.  A detailed
  explanation of the implementation is in the ACL2 ~il[documentation]
  (~pl[defun-sk]); also ~pl[conservativity-of-defchoose].

  [Note: Quantifiers can be used for some pretty cool things in ACL2.  Perhaps
  the most interesting example is the way of using quantifiers to introduce
  arbitrary tail-recursive equations; see the paper ``Partial Functions in
  ACL2'' by Panagiotis Manolios and J Strother Moore.  This note does not
  address applications of quantifiers, but merely how you would reason about
  them once you think you want to use them.]~/

  Assume that you have some function ~c[P].  I have just left ~c[P] as a unary
  function stub below, since I do not care about what ~c[P] is.
  ~bv[]
  (defstub P (*) => *)
  ~ev[]
  Now suppose you want to specify the concept that ``there exists some ~c[x]
  such that ~c[(P x)] holds''.  ACL2 allows you to write that directly using
  quantifiers.
  ~bv[]
  (defun-sk exists-P () (exists x (P x)))
  ~ev[]
  If you submit the above form in ACL2 you will see that the theorem prover
  specifies two functions ~c[exists-p] and ~c[exists-p-witness], and exports
  the following constraints:
  ~bv[]
  1.  (defun exists-P () (P (exists-P-witness)))
  2.  (defthm exists-P-suff (implies (p x) (exists-p)))
  ~ev[]
  Here ~c[exists-P-witness] is a new function symbol in the current ACL2
  theory.  What do the constraints above say?  Notice the constraint
  ~c[exists-p-suff].  It says that if you can provide any ~c[x] such that
  ~c[(P x)] holds, then you know that ~c[exists-p] holds.  Think of the other
  constraint (definition of ~c[exists-p]) as going the other way.  That is, it
  says that if ~c[exists-p] holds, then there is some ~c[x], call it
  ~c[(exists-p-witness)], for which ~c[P] holds.  Notice that nothing else is
  known about ~c[exists-p-witness] than the two constraints above.

  [Note: ~c[exists-p-witness] above is actually defined in ACL2 using a special
  form called ~c[defchoose].  ~l[defchoose].  This note does not talk about
  ~c[defchoose].  So far as this note is concerned, think of
  ~c[exists-p-witness] as a new function symbol that has been generated somehow
  in ACL2, about which nothing other than the two facts above is known.]

  Similarly, you can talk about the concept that ``for all ~c[x] ~c[(P x)]
  holds.'' This can be specified in ACL2 by the form:
  ~bv[]
  (defun-sk forall-P () (forall x (P x)))
  ~ev[]
  This produces the following two constraints:
  ~bv[]
  1.  (defun forall-P () (P (forall-p-witness)))
  2.  (defthm forall-p-necc (implies (not (P x)) (not (forall-p))))
  ~ev[]
  To understand these, think of ~c[for-all-p-witness] as producing some ~c[x]
  which does not satisfy ~c[P], if such a thing exists.  The constraint
  ~c[forall-p-necc] merely says that if ~c[forall-p] holds then ~c[P] is
  satisfied for every ~c[x].  (To see this more clearly, just think of the
  contrapositive of the formula shown.) The other constraint (definition of
  ~c[forall-p]) implies that if ~c[forall-p] does not hold then there is some
  ~c[x], call it ~c[(forall-p-witness)], which does not satisfy ~c[P].  To see
  this, just consider the following formula which is immediately derivable from
  the definition.
  ~bv[]
  (implies (not (forall-p)) (not (P (forall-witness))))
  ~ev[]
  The description above suggests that to reason about quantifiers, the
  following Rules of Thumb, familiar to most any student of logic, are useful.
  ~bq[]
  RT1: To prove ~c[(exists-p)], construct some object ~c[A] such that ~c[P]
  holds for ~c[A] and then use ~c[exists-P-suff].

  RT2: If you assume ~c[exists-P] in your hypothesis, use the definition of
  ~c[exists-p] to know that ~c[P] holds for ~c[exists-p-witness].  To use this
  to prove a theorem, you must be able to derive the theorem based on the
  hypothesis that ~c[P] holds for something, whatever the something is.

  RT3: To prove ~c[forall-P], prove the theorem ~c[(P x)] (that is, that ~c[P]
  holds for an arbitrary ~c[x]), and then simply instantiate the definition of
  ~c[forall-p], that is, show that ~c[P] holds for the witness.

  RT4: If you assume ~c[forall-p] in the hypothesis of the theorem, see how you
  can prove your conclusion if indeed you were given ~c[(P x)] as a theorem.
  Possibly for the conclusion to hold, you needed that ~c[P] holds for some
  specific set of ~c[x] values.  Then use the theorem ~c[forall-p-necc] by
  instantiating it for the specific ~c[x] values you care about.~eq[]

  Perhaps the above is too terse.  In the remainder of the note, we will
  consider several examples of how this is done to prove theorems in ACL2 that
  involve quantified notions.

  Let us consider two trivial theorems.  Assume that for some unary function
  ~c[r], you have proved ~c[(r x)] as a theorem.  Let us see how you can prove
  that (1) there exists some x such that ~c[(r x)] holds, and (2) for all ~c[x]
  ~c[(r x)] holds.

  We first model these things using ~ilc[defun-sk].  Below, ~c[r] is simply
  some function for which ~c[(r x)] is a theorem.
  ~bv[]
  (encapsulate
   (((r *) => *))
   (local (defun r (x) (declare (ignore x)) t))
   (defthm r-holds (r x)))

  (defun-sk exists-r () (exists x (r x)))
  (defun-sk forall-r () (forall x (r x)))
  ~ev[]
  ACL2 does not have too much reasoning support for quantifiers.  So in most
  cases, one would need ~c[:use] hints to reason about quantifiers.  In order
  to apply ~c[:use] ~il[hints], it is preferable to keep the function
  definitions and theorems disabled.
  ~bv[]
  (in-theory (disable exists-r exists-r-suff forall-r forall-r-necc))
  ~ev[]
  Let us now prove that there is some ~c[x] such that ~c[(r x)] holds.  Since
  we want to prove ~c[exists-r], we must use ~c[exists-r-suff] by RT1.  We do
  not need to construct any instance here since ~c[r] holds for all ~c[x] by
  the theorem above.
  ~bv[]
  (defthm exists-r-holds
    (exists-r)
    :hints ((\"Goal\" :use ((:instance exists-r-suff)))))
  ~ev[]
  Let us now prove the theorem that for all ~c[x], ~c[(r x)] holds.  By RT3, we
  must be able to prove it by definition of ~c[forall-r].
  ~bv[]
  (defthm forall-r-holds
    (forall-r)
    :hints ((\"Goal\" :use ((:instance (:definition forall-r))))))
  ~ev[]
  [Note: Probably no ACL2 user in his or her right mind would prove the
  theorems ~c[exists-r-holds] and ~c[forall-r-holds] above.  The theorems shown
  are only for demonstration purposes.]

  For the remainder of this note we will assume that we have two stubbed out
  unary functions ~c[M] and ~c[N], and we will look at proving some quantified
  properties of these functions.
  ~bv[]
  (defstub M (*) => *)
  (defstub N (*) => *)
  ~ev[]
  Let us now define the predicates ~c[all-M], ~c[all-N], ~c[ex-M], and ~c[ex-N]
  specifying the various quantifications.
  ~bv[]
  (defun-sk all-M () (forall x (M x)))
  (defun-sk all-N () (forall x (N x)))
  (defun-sk some-M () (exists x (M x)))
  (defun-sk some-N () (exists x (N x)))

  (in-theory (disable all-M all-N all-M-necc all-N-necc))
  (in-theory (disable some-M some-N some-M-suff some-N-suff))
  ~ev[]
  Let us prove the classic distributive properties of quantification: the
  distributivity of universal quantification over conjunction, and the
  distributivity of existential quantification over disjunction.  We can state
  these properties informally in ``pseudo ACL2'' notation as follows:
  ~bv[]
  1.  (exists x: (M x)) or (exists x: (N x)) <=> (exists x: (M x) or (N x))
  2.  (forall x: (M x)) and (forall: x (N x)) <=> (forall x: (M x) and (N x))
  ~ev[]
  To make these notions formal we of course need to define the formulas at the
  right-hand sides of 1 and 2.  So we define ~c[some-MN] and ~c[all-MN] to
  capture these concepts.
  ~bv[]
  (defun-sk some-MN () (exists x (or (M x) (N x))))
  (defun-sk all-MN () (forall x (and (M x) (N x))))

  (in-theory (disable all-MN all-MN-necc some-MN some-MN-suff))
  ~ev[]
  First consider proving property 1.  The formal statement of this theorem would
  be: ~c[(iff (some-MN) (or (some-M) (some-N)))].

  How do we prove this theorem?  Looking at RT1-RT4 above, note that they
  suggest how one should reason about quantification when one has an
  ``implication''.  But here we have an ``equivalence''.  This suggests another
  rule of thumb.
  ~bq[]
  RT5: Whenever possible, prove an equivalence involving quantifiers by proving
  two implications.~eq[]

  Let us apply RT5 to prove the theorems above.  So we will first prove:
  ~c[(implies (some-MN) (or (some-M) (some-N)))]

  How can we prove this?  This involves assuming a quantified predicate
  ~c[(some-MN)], so we must use RT2 and apply the definition of ~c[some-MN].
  Since the conclusion involves a disjunction of two quantified predicates, by
  RT1 we must be able to construct two objects ~c[A] and ~c[B] such that either
  ~c[M] holds for ~c[A] or ~c[N] holds for ~c[B], so that we can then invoke
  ~c[some-M-suff] and ~c[some-N-suff] to prove the conclusion.  But now notice
  that if ~c[some-MN] is true, then there is already an object, in fact
  ~c[some-MN-witness], such that either ~c[M] holds for it, or ~c[N] holds for
  it.  And we know this is the case from the definition of ~c[some-MN]! So we
  will simply prove the theorem instantiating ~c[some-M-suff] and
  ~c[some-N-suff] with this witness.  The conclusion is that the following
  event will go through with ACL2.
  ~bv[]
  (defthm le1
    (implies (some-MN)
             (or (some-M) (some-N)))
    :rule-classes nil
    :hints ((\"Goal\"
              :use ((:instance (:definition some-MN))
                    (:instance some-M-suff
                               (x (some-MN-witness)))
                    (:instance some-N-suff
                               (x (some-MN-witness)))))))
  ~ev[]
  This also suggests the following rule of thumb:
  ~bq[]
  RT6: If a conjecture involves assuming an existentially quantified predicate
  in the hypothesis from which you are trying to prove an existentially
  quantified predicate, use the witness of the existential quantification in
  the hypothesis to construct the witness for the existential quantification in
  the conclusion.~eq[]

  Let us now try to prove the converse of le1, that is:
  ~c[(implies (or (some-M) (some-N)) (some-MN))]

  Since the hypothesis is a disjunction, we will just prove each case
  individually instead of proving the theorem by a :~c[cases] hint.  So we
  prove the following two lemmas.
  ~bv[]
  (defthm le2
    (implies (some-M) (some-MN))
    :rule-classes nil
    :hints ((\"Goal\"
              :use ((:instance (:definition some-M))
                    (:instance some-MN-suff
                               (x (some-M-witness)))))))

  (defthm le3
    (implies (some-N) (some-MN))
    :rule-classes nil
    :hints ((\"Goal\"
              :use ((:instance (:definition some-N))
                    (:instance some-MN-suff
                               (x (some-N-witness)))))))
  ~ev[]
  Note that the hints above are simply applications of RT6 as in ~c[le1].  With
  these lemmas, of course the main theorem is trivial.
  ~bv[]
  (defthmd |some disjunction|
    (iff (some-MN) (or (some-M) (some-N)))
    :hints ((\"Goal\"
              :use ((:instance le1)
                    (:instance le2)
                    (:instance le3)))))
  ~ev[]
  Let us now prove the distributivity of universal quantification over
  conjunction, that is, the formula: ~c[(iff (all-MN) (and (all-M) (all-N)))]

  Applying RT5, we will again decompose this into two implications.  So
  consider first the one-way implication:
  ~c[(implies (and (all-M) (all-N)) (all-MN))].

  Here we get to assume ~c[all-M] and ~c[all-N].  Thus by RT4 we can use
  ~c[all-M-necc] and ~c[all-N-necc] to think as if we are given the formulas
  ~c[(M x)] and ~c[(N x)] as theorems.  The conclusion here is also a universal
  quantification, namely we have to prove ~c[all-MN].  Then RT3 tells us to
  proceed as follows.  Take any object ~c[y].  Try to find an instantiation
  ~c[z] of the hypothesis that implies ~c[(and (M y) (N y))].  Then instantiate
  ~c[y] with ~c[all-MN-witness].  Note that the hypothesis lets us assume
  ~c[(M x)] and ~c[(N x)] to be theorems.  Thus to justify we need to
  instantiate ~c[x] with ~c[y], and in this case, therefore, with
  ~c[all-MN-witness].  To make the long story short, the following event goes
  through with ACL2:
  ~bv[]
  (defthm lf1
     (implies (and (all-M) (all-N))
              (all-MN))
      :rule-classes nil
      :hints ((\"Goal\"
                :use ((:instance (:definition all-MN))
                      (:instance all-M-necc (x (all-MN-witness)))
                      (:instance all-N-necc (x (all-MN-witness)))))))
  ~ev[]
  This suggests the following rule of thumb which is a dual of RT6:
  ~bq[]
  RT7: If a conjecture assumes some universally quantified predicate in the
  hypothesis and its conclusion asserts a universallly quantified predicate,
  then instantiate the ``necessary condition'' (~c[forall-mn-necc]) of the
  hypothesis with the witness of the conclusion to prove the conjecture.~eq[]

  Applying RT7 now we can easily prove the other theorems that we need to show
  that universal quantification distributes over conjunction.  Let us just go
  through this motion in ACL2.
  ~bv[]
  (defthm lf2
    (implies (all-MN)
             (all-M))
    :rule-classes nil
    :hints ((\"Goal\"
              :use ((:instance (:definition all-M))
                    (:instance all-MN-necc
                               (x (all-M-witness)))))))

  (defthm lf3
    (implies (all-MN)
             (all-N))
    :rule-classes nil
    :hints ((\"Goal\"
              :use ((:instance (:definition all-N))
                    (:instance all-MN-necc
                               (x (all-N-witness)))))))

  (defthmd |all conjunction|
    (iff (all-MN)
         (and (all-M) (all-N)))
   :hints ((\"Goal\" :use ((:instance lf1)
                         (:instance lf2)
                         (:instance lf3)))))
  ~ev[]
  The rules of thumb for universal and existential quantification should make
  you realize the duality of their use.  Every reasoning method about universal
  quantification can be cast as a way of reasoning about existential
  quantification, and vice versa.  Whether you reason using universal and
  existential quantifiers depends on what is natural in a particular context.
  But just for the sake of completeness let us prove the duality of universal
  and existential quantifiers.  So what we want to prove is the following:
  ~bv[]
  3.  (forall x (not (M x))) = (not (exists x (M x)))
  ~ev[]
  We first formalize the notion of ~c[(forall x (not (M x)))] as a
  quantification.
  ~bv[]
  (defun-sk none-M () (forall x (not (M x))))
  (in-theory (disable none-M none-M-necc))
  ~ev[]
  So we now want to prove: ~c[(equal (none-M) (not (some-M)))].

  As before, we should prove this as a pair of implications.  So let us prove
  first: ~c[(implies (none-M) (not (some-M)))].

  This may seem to assert an existential quantification in the conclusion, but
  rather, it asserts the ~em[negation] of an existential quantification.  We
  are now trying to prove that something does not exist.  How do we do that?
  We can show that nothing satisfies ~c[M] by just showing that
  ~c[(some-M-witness)] does not satisfy ~c[M].  This suggests the following
  rule of thumb:
  ~bq[]
  RT8: When you encounter the negation of an existential quantification think
  in terms of a universal quantification, and vice-versa.
  ~eq[]
  Ok, so now applying RT8 and RT3 you should be trying to apply the definition of
  ~c[some-M].  The hypothesis is just a pure (non-negated) universal quantification
  so you should apply RT4.  A blind application lets us prove the theorem as
  below.
  ~bv[]
  (defthm nl1
    (implies (none-M) (not (some-M)))
    :rule-classes nil
    :hints ((\"Goal\"
              :use ((:instance (:definition some-M))
                    (:instance none-M-necc (x (some-M-witness)))))))
  ~ev[]
  How about the converse implication?  I have deliberately written it as
  ~c[(implies (not (none-M)) (some-M))] instead of switching the left-hand and
  right-hand sides of ~c[nl1], which would have been equivalent.  Again, RH8
  tells us how to reason about it, in this case using RH2, and we succeed.
  ~bv[]
  (defthm nl2
    (implies (not (none-M)) (some-M))
    :rule-classes nil
    :hints ((\"Goal\"
              :use ((:instance (:definition none-M))
                    (:instance some-M-suff (x (none-M-witness)))))))
  ~ev[]
  So finally we just go through the motions of proving the equality.
  ~bv[]
  (defthmd |forall not = not exists|
    (equal (none-M) (not (some-M)))
    :hints ((\"Goal\"
              :use ((:instance nl1)
                    (:instance nl2)))))
  ~ev[]
  Let us now see if we can prove a slightly more advanced theorem which can be
  stated informally as: If there is a natural number ~c[x] which satisfies
  ~c[M], then there is a least natural number ~c[y] that satisfies ~c[M].

  [Note: Any time I have had to reason about existential quantification I have
  had to do this particular style of reasoning and state that if there is an
  object satisfying a predicate, then there is also a ``minimal'' object
  satisfying the predicate.]

  Let us formalize this concept.  We first define the concept of existence of a
  natural number satisfying ~c[x].
  ~bv[]
  (defun-sk some-nat-M () (exists x (and (natp x) (M x))))
  (in-theory (disable some-nat-M some-nat-M-suff))
  ~ev[]
  We now talk about what it means to say that ~c[x] is the least number
  satisfying ~c[M].
  ~bv[]
  (defun-sk none-below (y)
    (forall r (implies (and (natp r) (< r y)) (not (M r))))))
  (in-theory (disable none-below none-below-necc))

  (defun-sk min-M () (exists y (and (M y) (natp y) (none-below y))))
  (in-theory (disable min-M min-M-suff))
  ~ev[]
  The predicate ~c[none-below] says that no natural number less than ~c[y]
  satisfies ~c[M].  The predicate ~c[min-M] says that there is some natural
  number ~c[y] satisfying ~c[M] such that ~c[none-below] holds for ~c[y].

  So the formula we want to prove is: ~c[(implies (some-nat-M) (min-M))].

  Since the formula requires that we prove an existential quantification, RT1
  tells us to construct some object satisfying the predicate over which we are
  quantifying.  We should then be able to instantiate ~c[min-M-suff] with this
  object.  That predicate says that the object must be the least natural number
  that satisfies ~c[M].  Since such an object is uniquely computable if we know
  that there exists some natural number satisfying ~c[M], let us just write a
  recursive function to compute it.  This function is ~c[least-M] below.
  ~bv[]
  (defun least-M-aux (i bound)
    (declare (xargs :measure (nfix (- (1+ bound) i))))
    (cond ((or (not (natp i))
               (not (natp bound))
               (> i bound))
           0)
         ((M i) i)
         (t (least-M-aux (+ i 1) bound))))

  (defun least-M (bound) (least-M-aux 0 bound))
  ~ev[]
  Let us now reason about this function as one does typically.  So we prove
  that this object is indeed the least natural number that satisfies ~c[M],
  assuming that ~c[bound] is a natural number that satisfies ~c[M].
  ~bv[]
  (defthm least-aux-produces-an-M
    (implies (and (natp i)
                  (natp bound)
                  (<= i bound)
                  (M bound))
             (M (least-M-aux i bound))))

  (defthm least-<=bound
    (implies (<= 0 bound)
             (<= (least-M-aux i bound) bound)))

  (defthm least-aux-produces-least
    (implies (and (natp i)
                  (natp j)
                  (natp bound)
                  (<= i j)
                  (<= j bound)
                  (M j))
              (<= (least-M-aux i bound) j)))

  (defthm least-aux-produces-natp
    (natp (least-M-aux i bound)))

  (defthmd least-is-minimal-satisfying-m
    (implies (and (natp bound)
                  (natp i)
                   (< i (least-M bound)))
             (not (M i)))
    :hints ((\"Goal\"
              :in-theory (disable least-aux-produces-least least-<=bound)
              :use ((:instance least-<=bound
                               (i 0))
                    (:instance least-aux-produces-least
                               (i 0)
                               (j i))))))

  (defthm least-has-m
    (implies (and (natp bound)
                  (m bound))
             (M (least-M bound))))

  (defthm least-is-natp
    (natp (least-M bound)))
  ~ev[]
  So we have done that, and hopefully this is all that we need about
  ~c[least-M].  So we disable everything.
  ~bv[]
  (in-theory (disable least-M natp))
  ~ev[]
  Now of course we note that the statement of the conjecture we are interested
  in has two quantifiers, an inner ~c[forall] (from ~c[none-below]) and an
  outer ~c[exists] (from ~c[min-M]).  Since ACL2 is not very good with
  quantification, we hold its hands to reason with the quantifier part.  So we
  will first prove something about the ~c[forall] and then use it to prove what
  we need about the ~c[exists].
  ~bq[]
  RT9: When you face nested quantifiers, reason about each nesting
  separately.~eq[]

  So what do we want to prove about the inner quantifier?  Looking carefully at
  the definition of ~c[none-below] we see that it is saying that for all natural
  numbers ~c[r] < ~c[y], ~c[(M r)] does not hold.  Well, how would we want to
  use this fact when we want to prove our final theorem?  We expect that we
  will instantiate ~c[min-M-suff] with the object ~c[(least-M bound)] where we
  know (via the outermost existential quantifier) that ~c[M] holds for
  ~c[bound], and we will then want to show that ~c[none-below] holds for
  ~c[(least-M bound)].  So let us prove that for any natural number (call it
  ~c[bound]), ~c[none-below] holds for ~c[(least-M bound)].  For the final
  theorem we only need it for natural numbers satisfying ~c[M], but note that
  from the lemma ~c[least-is-minimal-satisfying-m] we really do not need that
  ~c[bound] satisfies ~c[M].

  So we are now proving:
  ~c[(implies (natp bound) (none-below (least-M bound)))].

  Well since this is a standard case of proving a universally quantified
  predicate, we just apply RT3.  We have proved that for all naturals ~c[i] <
  ~c[(least-M bound)], ~c[i] does not satisfy ~c[M] (lemma
  ~c[least-is-minimal-satisfying-M]), so we merely need the instantiation of
  that lemma with ~c[none-below-witness] of the thing we are trying to prove,
  that is, ~c[(least-M bound)].  The theorem below thus goes through.
  ~bv[]
  (defthm least-is-minimal
    (implies (natp bound)
             (none-below (least-M bound)))
    :hints ((\"Goal\"
              :use ((:instance (:definition none-below)
                               (y (least-M bound)))
                    (:instance least-is-minimal-satisfying-m
                               (i (none-below-witness (least-M bound))))))))
  ~ev[]
  Finally we are in the outermost existential quantifier, and are in the
  process of applying ~c[min-M-suff].  What object should we instantiate it
  with?  We must instantiate it with ~c[(least-M bound)] where ~c[bound] is an
  object which must satisfy ~c[M] and is a natural.  We have such an object,
  namely ~c[(some-nat-M-witness)] which we know have all these qualities given
  the hypothesis.  So the proof now is just RT1 and RT2.
  ~bv[]
  (defthm |minimal exists|
    (implies (some-nat-M) (min-M))
    :hints ((\"Goal\"
              :use ((:instance min-M-suff
                               (y (least-M (some-nat-M-witness))))
                    (:instance (:definition some-nat-M))))))
  ~ev[]

  If you are comfortable with the reasoning above, then you are comfortable
  with quantifiers and probably will not need these notes any more.  In my
  opinion, the best way of dealing with ACL2 is to ask yourself why you think
  something is a theorem, and the rules of thumb above are simply guides to the
  questions that you need to ask when you are dealing with quantification.

  Here are a couple of simple exercises for you to test if you understand
  the reasoning process.

  ~st[Exercise 1].  Formalize and prove the following theorem.  Suppose there
  exists ~c[x] such that ~c[(R x)] and suppose that all ~c[x] satisfy
  ~c[(P x)].  Then prove that there exists ~c[x] such that ~c[(P x) & (R x)].
  (See
  ~url[http://www.cs.utexas.edu/users/moore/acl2/contrib/quantifier-exercise-1-solution.html]
  for a solution.)

  ~st[Exercise 2].  Recall the example just before the preceding exercise,
  where we showed that if there exists a natural number ~c[x] satisfying ~c[M]
  then there is another natural number ~c[y] such that ~c[y] satisfies ~c[M]
  and for every natural number ~c[z] < ~c[y], ~c[z] does not.  What would
  happen if we remove the restriction of ~c[x], ~c[y], and ~c[z] being
  naturals?  Of course, we will not talk about ~c[<] any more, but suppose you
  use the total order on all ACL2 objects (from community book
  ~c[\"books/misc/total-order\"]).  More concretely, consider the definition of
  ~c[some-M] above.  Let us now define two other functions:
  ~bv[]
  (include-book \"misc/total-order\" :dir :system)

  (defun-sk none-below-2 (y)
    (forall r (implies (<< r y) (not (M r)))))

  (defun-sk min-M2 () (exists y (and (M y) (none-below-2 y))))
  ~ev[]
  The question is whether ~c[(implies (some-M) (min-M2))] is a theorem.  Can
  you prove it?  Can you disprove it?~/")

(deflabel quantifiers
  :doc
  ":Doc-Section Defun-sk

  issues about quantification in ACL2~/

  ACL2 supports first-order quantifiers ~ilc[exists] and ~ilc[forall] by way of
  the ~ilc[defun-sk] event.  However, proof support for quantification is quite
  limited.  Therefore, you may prefer using recursion in place of ~c[defun-sk]
  when possible (following common ACL2 practice).~/

  For example, the notion ``every member of ~c[x] has property ~c[p]'' can be
  defined either with recursion or explicit quantification, but proofs may be
  simpler when recursion is used.  We illustrate this point with two proofs of
  the same informal claim, one of which uses recursion which the other uses
  explicit quantification.  Notice that with recursion, the proof goes through
  fully automatically; but this is far from true with explicit quantification
  (especially notable is the ugly hint).

  The informal claim for our examples is:  If every member ~c[a] of each
  of two lists satisfies the predicate ~c[(p a)], then this holds of their
  ~ilc[append]; and, conversely.

  ~l[quantifiers-using-recursion] for a solution to this example using
  recursion.

  ~l[quantifiers-using-defun-sk] for a solution to this example using
  ~ilc[defun-sk].  Also ~l[quantifiers-using-defun-sk-extended] for an
  elaboration on that solution.

  But perhaps first, ~pl[defun-sk] for an ACL2 utility to introduce first-order
  quantification in a direct way.  Examples of the use of ~c[defun-sk] are also
  available: ~pl[defun-sk-example] and ~pl[Tutorial4-Defun-Sk-Example] for
  basic examples, and ~pl[quantifier-tutorial] for a more complete, careful
  beginner's introduction that takes you through typical kinds of
  quantifier-based reasoning in ACL2.~/")

(deflabel quantifiers-using-recursion
  :doc
  ":Doc-Section Quantifiers

  recursion for implementing quantification~/

  The following example illustrates the use of recursion as a means of
  avoiding proof difficulties that can arise from the use of explicit
  quantification (via ~ilc[defun-sk]).  ~l[quantifiers] for more about
  the context of this example.~/
  ~bv[]
  (in-package \"ACL2\")

  ; We prove that if every member A of each of two lists satisfies the
  ; predicate (P A), then this holds of their append; and, conversely.

  ; Here is a solution using recursively-defined functions.

  (defstub p (x) t)

  (defun all-p (x)
    (if (atom x)
        t
      (and (p (car x))
           (all-p (cdr x)))))

  (defthm all-p-append
    (equal (all-p (append x1 x2))
           (and (all-p x1) (all-p x2))))
  ~ev[]")

(deflabel quantifiers-using-defun-sk
  :doc
  ":Doc-Section Quantifiers

  quantification example~/

  ~l[quantifiers] for the context of this example.  It should be
  compared to a corresponding example in which a simpler proof is
  attained by using recursion in place of explicit quantification;
  ~pl[quantifiers-using-recursion].~/
  ~bv[]
  (in-package \"ACL2\")

  ; We prove that if every member A of each of two lists satisfies the
  ; predicate (P A), then this holds of their append; and, conversely.

  ; Here is a solution using explicit quantification.

  (defstub p (x) t)

  (defun-sk forall-p (x)
    (forall a (implies (member a x)
                       (p a))))

  (defthm member-append
    (iff (member a (append x1 x2))
         (or (member a x1) (member a x2))))

  (defthm forall-p-append
    (equal (forall-p (append x1 x2))
           (and (forall-p x1) (forall-p x2)))
    :hints ((\"Goal\" ; ``should'' disable forall-p-necc, but no need
             :use
             ((:instance forall-p-necc
                         (x (append x1 x2))
                         (a (forall-p-witness x1)))
              (:instance forall-p-necc
                         (x (append x1 x2))
                         (a (forall-p-witness x2)))
              (:instance forall-p-necc
                         (x x1)
                         (a (forall-p-witness (append x1 x2))))
              (:instance forall-p-necc
                         (x x2)
                         (a (forall-p-witness (append x1 x2))))))))
  ~ev[]

  Also ~pl[quantifiers-using-defun-sk-extended] for an
  elaboration on this example.")

(deflabel quantifiers-using-defun-sk-extended
  :doc
  ":Doc-Section Quantifiers

  quantification example with details~/

  ~l[quantifiers-using-defun-sk] for the context of this example.~/
  ~bv[]
  (in-package \"ACL2\")

  ; We prove that if every member A of each of two lists satisfies the
  ; predicate (P A), then this holds of their append; and, conversely.

  ; Here is a solution using explicit quantification.

  (defstub p (x) t)

  (defun-sk forall-p (x)
    (forall a (implies (member a x)
                       (p a))))

  ; The defun-sk above introduces the following axioms.  The idea is that
  ; (FORALL-P-WITNESS X) picks a counterexample to (forall-p x) if there is one.

  ;   (DEFUN FORALL-P (X)
  ;     (LET ((A (FORALL-P-WITNESS X)))
  ;          (IMPLIES (MEMBER A X) (P A))))
  ;
  ;   (DEFTHM FORALL-P-NECC
  ;     (IMPLIES (NOT (IMPLIES (MEMBER A X) (P A)))
  ;              (NOT (FORALL-P X)))
  ;     :HINTS ((\"Goal\" :USE FORALL-P-WITNESS)))

  ; The following lemma seems critical.

  (defthm member-append
    (iff (member a (append x1 x2))
         (or (member a x1) (member a x2))))

  ; The proof of forall-p-append seems to go out to lunch, so we break into
  ; directions as shown below.

  (defthm forall-p-append-forward
    (implies (forall-p (append x1 x2))
             (and (forall-p x1) (forall-p x2)))
    :hints ((\"Goal\" ; ``should'' disable forall-p-necc, but no need
             :use
             ((:instance forall-p-necc
                         (x (append x1 x2))
                         (a (forall-p-witness x1)))
              (:instance forall-p-necc
                         (x (append x1 x2))
                         (a (forall-p-witness x2)))))))

  (defthm forall-p-append-reverse
    (implies (and (forall-p x1) (forall-p x2))
             (forall-p (append x1 x2)))
    :hints ((\"Goal\"
             :use
             ((:instance forall-p-necc
                         (x x1)
                         (a (forall-p-witness (append x1 x2))))
              (:instance forall-p-necc
                         (x x2)
                         (a (forall-p-witness (append x1 x2))))))))

  (defthm forall-p-append
    (equal (forall-p (append x1 x2))
           (and (forall-p x1) (forall-p x2)))
    :hints ((\"Goal\" :use (forall-p-append-forward
                          forall-p-append-reverse))))

  ~ev[]")

; Here is the defstobj event.

; We start with the problem of finding the arguments to the defstobj event.
; The form looks likes

; (defstobj name ... field-descri ...
;           :renaming alist
;           :doc string)
;           :inline flag)

; where the :renaming, :doc, 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, a renaming alist, and a doc string.  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."))
        ((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-user-fns (names wrld ctx state)
  (cond
   ((null names) (value nil))
   ((or (acl2-system-namep (car names) wrld)
        (equal (guard (car names) nil wrld) *t*))
    (chk-unrestricted-guards-for-user-fns (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)))))

(defconst *expt2-28* (expt 2 28))

(defun fix-stobj-array-type (type wrld)

; Note: Wrld may be a world or nil.  If wrld is nil and we are in raw Lisp,
; then this function should be called in a context where the symbol-value is
; available for any symbol introduced by a previous defconst event.  Our
; intended use case meets that criterion: evaluation of a defstobj form during
; loading of the compiled file for a book.

  (let* ((max (car (caddr type)))
         (n (cond ((consp wrld)
                   (let ((qc (defined-constant max wrld)))
                     (and qc (unquote qc))))
                  #-acl2-loop-only
                  ((eq wrld nil)
                   (and (symbolp max)
                        (symbol-value max)))
                  (t nil))))
    (cond (n (list (car type)
                   (cadr type)
                   (list n)))
          (t type))))

(defun chk-stobj-field-descriptor (name field-descriptor ctx wrld state)

; See the comment just before chk-acceptable-defstobj1 for an explanation of
; our handling of Common Lisp compliance.

  (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))
                 (let ((keys (odds field-descriptor)))
                   (and (no-duplicatesp keys)
                        (subsetp-eq keys '(: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))
            (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)))
       (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))
                    (stobjp (stobjp etype t wrld))
                    (etype-term ; used only when (not stobjp)
                     (and (not stobjp) ; optimization
                          (translate-declaration-to-guard etype 'x wrld)))
                    (n (car (caddr type0)))
                    (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
                ((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))
                (stobjp ; Defstobj-raw-init-fields depends on this check.
                 (cond ((eq etype 'state)
                        (er soft ctx
                            etype-error-string
                            field 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.  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
                 (er-let*
                     ((pair (simple-translate-and-eval etype-term
                                                       (list (cons 'x init))
                                                       nil
                                                       (msg
                                                        "The type ~x0"
                                                        etype-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 "auxiliary function" ctx state)
                    (chk-unrestricted-guards-for-user-fns
                     (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 in the array ~
                           specification for the ~x2 field of ~x3."
                          init etype field name))
                     (t (value nil)))))))))))
        ((assoc-keyword :resizable (cdr field-descriptor))
         (er soft ctx
             "The :resizable keyword is only legal for array types, hence is ~
              illegal for the ~x0 field of ~x1."
             field name))
        (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.
               (cond ((eq type 'state)
                      (er soft ctx
                          type-error-string
                          field 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
               (er-let* ((pair (simple-translate-and-eval type-term
                                                          (list (cons 'x init))
                                                          nil
                                                          (msg
                                                           "The type ~x0"
                                                           type-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 "body" ctx state)
                  (chk-unrestricted-guards-for-user-fns
                   (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 ~
                         for the ~x2 field of ~x3."
                        init type field name))
                   (t (value nil)))))))))))))))

(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 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 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 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 (if (and (consp type)
                            (eq (car type) 'array))
                       :array
                     :non-array)))
        (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))
                      (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 defconst-name (name)
  (intern-in-package-of-symbol
   (concatenate 'string "*" (symbol-name name) "*")
   name))

(defun chk-acceptable-defstobj1
  (name field-descriptors ftemps renaming 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)

; 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 :initially val), where
; either or both of the keyword fields can be omitted.  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, 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) 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 (if (and (consp type)
                           (eq (car type) 'array))
                      :array
                    :non-array))
            (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)
        (if (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))
          (value nil))
        (chk-acceptable-defstobj1 name field-descriptors (cdr ftemps)
                                  renaming ctx wrld state
                                  (list* fieldp-name
                                         accessor-name
                                         updater-name
                                         (if (eq key2 :array)
                                             (list* length-name
                                                    resize-name
                                                    names)
                                           names))
                                  (cons accessor-const-name
                                        const-names))))))))

(defconst *defstobj-keywords*
  '(:renaming :doc :inline :congruent-to))

(defun defstobj-redundancy-bundle (args)

; See redundant-defstobjp to see how this is used.

; The treatment of erp below is justified as follows.  If this function is used
; to compute a redundancy bundle for a new purported but ill-formed defstobj,
; the bundle will contain the symbol 'error in the field-descriptors slot,
; which will cause it not to match any correct redundancy bundle.  Thus, the
; purported defstobj will not be considered redundant and the error will be
; detected by the admissions process.

  (mv-let
   (erp field-descriptors key-alist)
   (partition-rest-and-keyword-args args *defstobj-keywords*)
   (list* (if erp
              'error
            field-descriptors)
          (cdr (assoc-eq :renaming key-alist))

; We include the :congruent-to field, for example to avoid errors like the
; following.

;   (defstobj st1 fld1)
;
;   (encapsulate
;    ()
;    (local (defstobj st2 fld2 fld3))
;    (defstobj st2 fld2 fld3 :congruent-to st1))
;
;   ; Raw lisp error!
;   (fld3 st1)

          (cdr (assoc-eq :congruent-to key-alist)))))

(defun old-defstobj-redundancy-bundle (name wrld)

; Name has a (non-nil) 'stobj property in the given world.  We return data
; relevant for redundancy from the event associated with name in wrld.

  (assert$
   (getprop name 'stobj nil 'current-acl2-world wrld)
   (let ((ev (get-event name wrld)))
     (and ev
          (assert$ (and (member-eq (car ev) '(defstobj defabsstobj))
                        (eq (cadr ev) name))
                   (defstobj-redundancy-bundle (cddr ev)))))))

(defun redundant-defstobjp (name args wrld)

; Note: At one time we stored the defstobj template on the property
; list of a defstobj name and we computed the new template from args
; and compared the two templates to identify redundancy.  To make this
; possible without causing runtime errors we had to check, here, that
; the arguments -- which have not yet been checked for well-formedness
; -- were at least of the right basic shape, e.g., that the renaming
; is a doublet-style-symbol-to-symbol-alistp and that each
; field-descriptor is either a symbol or a true-list of length 1, 3,
; or 5 with :type and :initially fields.  But this idea suffered the
; unfortunate feature that an illegal defstobj event could be
; considered redundant.  For example, if the illegal event had a
; renaming that included an unnecessary function symbol in its domain,
; that error was not caught.  The bad renaming produced a good
; template and if a correct version of that defstobj had previously
; been executed, the bad one was recognized as redundant.
; Unfortunately, if one were to execute the bad one first, an error
; would result.

; So we have changed this function to be extremely simple.

  (and (getprop name 'stobj nil 'current-acl2-world wrld)
       (equal (old-defstobj-redundancy-bundle name wrld)
              (defstobj-redundancy-bundle 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
; signal an error or return nil.

  (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)))
    (t
     (let ((renaming (cdr (assoc-eq :renaming key-alist)))
           (doc (cdr (assoc-eq :doc key-alist)))
           (inline (cdr (assoc-eq :inline key-alist)))
           (congruent-to (cdr (assoc-eq :congruent-to key-alist))))
       (cond
        ((redundant-defstobjp name args wrld)
         (value 'redundant))
        ((not (booleanp inline))
         (er soft ctx
             "DEFSTOBJ requires the :INLINE keyword argument to have a Boolean ~
              value.  See :DOC defstobj."))
        ((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
              (getprop congruent-to 'absstobj-info nil 'current-acl2-world
                       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
                    (car (old-defstobj-redundancy-bundle 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))
        (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 ((or (eq name 'I)
                     (eq name 'V))
                 (er soft ctx
                     "DEFSTOBJ does not allow single-threaded objects with ~
                      the names I or V because those symbols are used as ~
                      formals, along with the new stobj name itself, in ~
                      ``primitive'' stobj functions that will be ~
                      defined."))
                (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)))

; We use translate-doc here just to check the string.  We throw away
; the section-symbol and citations returned.  We'll repeat this later.

          (translate-doc name doc ctx state)
          (er-let*
            ((wrld1 (chk-just-new-name name 'stobj nil ctx wrld state))
             (wrld2 (chk-just-new-name (the-live-var name) 'stobj-live-var
                                       nil ctx wrld1 state)))
            (chk-acceptable-defstobj1 name field-descriptors field-descriptors
                                      renaming 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 deconsts generated, invoke
;   (defstobj-defconsts (strip-accessor-names (caddr template)) 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 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.

; Now we introduce the idea of the "template" of a defstobj, which
; includes a normalized version of the field descriptors under the
; renaming.

(defun defstobj-fields-template (field-descriptors renaming wrld)

; Note: Wrld may be a world or nil.  See fix-stobj-array-type.

  (cond
   ((endp field-descriptors) 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))
           (init (if (consp (car field-descriptors))
                     (cadr (assoc-keyword :initially
                                          (cdr (car field-descriptors))))
                   nil))
           (resizable (if (consp (car field-descriptors))
                          (cadr (assoc-keyword :resizable
                                               (cdr (car field-descriptors))))
                        nil))
           (key2 (if (and (consp type)
                          (eq (car type) 'array))
                     :array
                   :non-array))
           (fieldp-name (defstobj-fnname field :recognizer key2 renaming))
           (accessor-name (defstobj-fnname field :accessor key2 renaming))
           (updater-name (defstobj-fnname field :updater key2 renaming))
           (resize-name (defstobj-fnname field :resize key2 renaming))
           (length-name (defstobj-fnname field :length key2 renaming)))
      (cons (list fieldp-name
                  (cond ((and (consp type)
                              (eq (car type) 'array))
                         (fix-stobj-array-type type wrld))
                        (t type))
                  init
                  accessor-name
                  updater-name
                  length-name
                  resize-name
                  resizable)
            (defstobj-fields-template
              (cdr field-descriptors) renaming wrld))))))

(defun defstobj-template (name args wrld)

; Note: Wrld may be a world or nil.  See fix-stobj-array-type.

; We unpack the args to get the renamed field descriptors.  We return a list of
; the form (namep create-name fields doc inline congruent-to), where: namep is
; the name of the recognizer for the single-threaded object; create-name is the
; name of the constructor for the stobj; fields is a list corresponding to the
; field descriptors, but normalized with respect to the renaming, types, etc.;
; doc is the doc string, or nil if no doc string is supplied; inline is t if
; :inline t was specified in the defstobj event, else nil; and congruent-to is
; the :congruent-to field of the defstobj event (default: nil).  A field in
; fields is of the form (recog-name type init accessor-name updater-name
; length-name resize-name resizable).  The last three fields are nil unless
; type has the form (ARRAY ptype (n)), in which case ptype is a primitive type
; and n is a positive integer.  Init is the evg of a constant term, i.e.,
; should be quoted to be a treated as a term.  Doc is the value of the :doc
; keyword arg in args.

  (mv-let
   (erp field-descriptors key-alist)
   (partition-rest-and-keyword-args args *defstobj-keywords*)
   (cond
    (erp

; If the defstobj has been admitted, this won't happen.

     (er hard 'defstobj
         "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.  Thus, ~
          ~x1 is ill-formed."
         *defstobj-keywords*
         (list* 'defstobj name args)))
    (t
     (let ((renaming (cdr (assoc-eq :renaming key-alist)))
           (doc (cdr (assoc-eq :doc key-alist)))
           (inline (cdr (assoc-eq :inline key-alist)))
           (congruent-to (cdr (assoc-eq :congruent-to key-alist))))
       (list (defstobj-fnname name :recognizer :top renaming)
             (defstobj-fnname name :creator :top renaming)
             (defstobj-fields-template field-descriptors renaming wrld)
             doc
             inline
             congruent-to))))))

(defun defstobj-component-recognizer-calls (ftemps n var ans)

; Warning:  See the guard remarks in the Essay on Defstobj Definitions.

; Given a list of field templates, e.g., ((regp ...) (pcp ...) ...),
; where n is one less than the number of fields and var is some
; symbol, v, we return ((regp (nth 0 v)) (pcp (nth 1 v)) ...).  Except,
; if field represents a non-resizable array then we also include a
; corresponding length statement in the list.

  (cond ((endp ftemps)
         (reverse ans))
        (t (defstobj-component-recognizer-calls
             (cdr ftemps)
             (+ n 1)
             var
             (let* ((type (cadr (car ftemps)))
                    (nonresizable-ar (and (consp type)
                                          (eq (car type) 'array)
                                          (not (nth 7 (car ftemps)))))
                    (pred-stmt `(,(car (car ftemps)) (nth ,n ,var))))
               (if nonresizable-ar
                   (list* `(equal (len (nth ,n ,var)) ,(car (caddr type)))
                          pred-stmt
                          ans)
                 (cons pred-stmt ans)))))))

(defun defstobj-component-recognizer-axiomatic-defs (name template ftemps wrld)

; Warning:  See the guard remarks in the Essay on Defstobj Definitions.

; It is permissible for wrld to be nil, as this merely defeats additional
; checking by translate-declaration-to-guard.

; We return a list of defs (see defstobj-axiomatic-defs) for all the
; recognizers for the single-threaded resource named name with the given
; template.  The answer contains the top-level recognizer as well as the
; definitions of all component recognizers.  The answer contains defs for
; auxiliary functions used in array component recognizers.  The defs are listed
; in an order suitable for processing (components first, then top-level).

  (cond
   ((endp ftemps)
    (let* ((recog-name (car template))
           (field-templates (caddr template))
           (n (length field-templates)))

; Rockwell Addition: See comment below.

; Note: The recognizer for a stobj must be Boolean!  That is why we
; conclude the AND below with a final T.  The individual field
; recognizers need not be Boolean and sometimes are not!  For example,
; a field with :TYPE (MEMBER e1 ... ek) won't be Boolean, nor with
; certain :TYPE (OR ...) involving MEMBER.  The reason we want the
; stobj recognizer to be Boolean is so that we can replace it by T in
; guard conjectures for functions that have been translated with the
; stobj syntactic restrictions.  See optimize-stobj-recognizers.

      (list `(,recog-name (,name)
                          (declare (xargs :guard t
                                          :verify-guards t))
                          (and (true-listp ,name)
                               (= (length ,name) ,n)
                               ,@(defstobj-component-recognizer-calls
                                   field-templates 0 name nil)
                               t)))))
   (t
    (let ((recog-name (nth 0 (car ftemps)))
          (type (nth 1 (car ftemps))))

; Below we simply append the def or defs for this field to those for
; the rest.  We get two defs for each array field and one def for each
; of the others.

      (cons (cond
             ((and (consp type)
                   (eq (car type) 'array))
              (let ((etype (cadr type)))
                `(,recog-name (x)
                              (declare (xargs :guard t
                                              :verify-guards t))
                              (if (atom x)
                                  (equal x nil)
                                  (and ,(translate-stobj-type-to-guard
                                         etype '(car x) wrld)
                                       (,recog-name (cdr x)))))))
             (t (let ((type-term (translate-stobj-type-to-guard
                                  type 'x wrld)))

; We might not use x in the type-term and so have to declare it ignorable.

                  `(,recog-name (x)
                                (declare (xargs :guard t
                                                :verify-guards t)
                                         (ignorable x))
                                ,type-term))))
            (defstobj-component-recognizer-axiomatic-defs
              name template (cdr ftemps) wrld))))))

(defun defstobj-field-fns-axiomatic-defs (top-recog var n ftemps wrld)

; Wrld is normally a logical world, but it can be nil when calling this
; function from raw Lisp.

; Warning: Keep the formals in the definitions below in sync with corresponding
; formals defstobj-field-fns-raw-defs.  Otherwise trace$ may not work
; correctly; we saw such a problem in Version_5.0 for a resize function.

; 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 becomes the
; 'stobj property laid down by defstobj-fn, and function
; chk-stobj-let/updaters1 assumes that it will find each updater definition in
; that property immediately after the corresponding accessor definition.

  (cond
   ((endp ftemps)
    nil)
   (t (let* ((field-template (car ftemps))
             (type (nth 1 field-template))
             (init (nth 2 field-template))
             (arrayp (and (consp type) (eq (car type) 'array)))
             (type-term            ; used in guard
              (and (not arrayp)    ; else type-term is not used
                   (if (null wrld) ; called from raw Lisp, so guard is ignored
                       t
                     (translate-stobj-type-to-guard type 'v wrld))))
             (array-etype (and arrayp (cadr type)))
             (array-etype-term     ; used in guard
              (and arrayp          ; else array-etype-term is not used
                   (if (null wrld) ; called from raw Lisp, so guard is ignored
                       t
                     (translate-stobj-type-to-guard array-etype 'v wrld))))
             (array-length (and arrayp (car (caddr type))))
             (accessor-name (nth 3 field-template))
             (updater-name (nth 4 field-template))
             (length-name (nth 5 field-template))
             (resize-name (nth 6 field-template))
             (resizable (nth 7 field-template)))
        (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 ,var)
                             (declare (xargs :guard
                                             (and (,top-recog ,var)
                                                  (integerp i)
                                                  (<= 0 i)
                                                  (< i (,length-name ,var))
                                                  ,@(if (eq array-etype-term
                                                            t)
                                                        nil
                                                      (list array-etype-term)))
                                             :verify-guards t))
                             (update-nth-array ,n i v ,var)))
           (defstobj-field-fns-axiomatic-defs
             top-recog var (+ n 1) (cdr ftemps) wrld)))
         (t
          (append
           `((,accessor-name (,var)
                             (declare (xargs :guard (,top-recog ,var)
                                             :verify-guards t))
                             (nth ,n ,var))
             (,updater-name (v ,var)
                            (declare (xargs :guard
                                            ,(if (eq type-term t)
                                                 `(,top-recog ,var)
                                               `(and ,type-term
                                                     (,top-recog ,var)))
                                            :verify-guards t))
                            (update-nth ,n v ,var)))
           (defstobj-field-fns-axiomatic-defs
             top-recog var (+ n 1) (cdr ftemps) wrld))))))))

(defun defstobj-axiomatic-init-fields (ftemps wrld)

; Keep this in sync with defstobj-raw-init-fields.

  (cond
   ((endp ftemps) nil)
   (t (let* ((field-template (car ftemps))
             (type (nth 1 field-template))
             (arrayp (and (consp type) (eq (car type) 'array)))
             (array-size (and arrayp (car (caddr type))))
             (init0 (nth 2 field-template))
             (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 ftemps) wrld)))
         (t ; whether the type is given or not is irrelevant
          (cons init
                (defstobj-axiomatic-init-fields (cdr ftemps) wrld))))))))

(defun defstobj-creator-fn (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-let/updaters1 assumes that it will
; find each updater definition in that property immediately after the
; corresponding accessor definition.

; See the Essay on Defstobj Definitions.

  (let ((field-templates (caddr template)))
    (append
     (defstobj-component-recognizer-axiomatic-defs name template
       field-templates wrld)
     (cons
      (defstobj-creator-fn (cadr template) field-templates wrld)
      (defstobj-field-fns-axiomatic-defs (car template) name 0
        field-templates wrld)))))

(defun simple-array-type (array-etype dimensions)
  (declare (ignore dimensions))
  (cond
   ((eq array-etype t)
    `(simple-vector *))
   ((eq array-etype '*)
    (er hard 'simple-array-type
        "Implementation error: We had thought that * is an invalid type-spec! ~
         ~ Please contact the ACL2 implementors."))
   (t `(simple-array ,array-etype (*)))))

#-acl2-loop-only
(defun-one-output stobj-copy-array-aref (a1 a2 i n)
  (declare (type (unsigned-byte 29) i n))

; Copy the first n elements of array a1 into array a2, starting with index i,
; and then return a2.  See also copy-array-svref and stobj-copy-array-fix-aref.
; Note that this copying does not copy substructures, so in the case that a1 is
; an array of stobjs, if 0 <= i < n then the ith element of a1 will be EQ to
; the ith element of a2 after the copy is complete.

  (cond
   ((>= i n) a2)
   (t (setf (aref a2 i)
            (aref a1 i))
      (stobj-copy-array-aref a1 a2
                             (the (unsigned-byte 29) (1+ i))
                             (the (unsigned-byte 29) n)))))

#-acl2-loop-only
(defun-one-output stobj-copy-array-svref (a1 a2 i n)
  (declare (type (unsigned-byte 29) i n)
           (type simple-vector a1 a2))

; This is a variant of copy-array-aref for simple vectors a1 and a2.

  (cond
   ((>= i n) a2)
   (t (setf (svref a2 i)
            (svref a1 i))
      (stobj-copy-array-svref a1 a2
                              (the (unsigned-byte 29) (1+ i))
                              (the (unsigned-byte 29) n)))))

#-acl2-loop-only
(defun-one-output stobj-copy-array-fix-aref (a1 a2 i n)
  #+gcl ; declaration causes errors in cmucl and sbcl and may not be necessary
        ; except in gcl (to avoid boxing)
  (declare (type (unsigned-byte 29) i n)
           (type (simple-array (signed-byte 29) (*)) a1 a2))

; This is a variant of copy-array-aref for arrays of fixnums a1 and a2.  We
; need this special version to avoid fixnum boxing in GCL during resizing.

  (cond
   ((>= i n) a2)
   (t (setf (aref a2 i)
            (aref a1 i))
      (stobj-copy-array-fix-aref a1 a2
                                 (the (unsigned-byte 29) (1+ i))
                                 (the (unsigned-byte 29) n)))))

(defmacro live-stobjp (name)

; Through Version_4.3, this macro was called the-live-stobj, and its body was
; `(eq ,name ,(the-live-var name)).  However, we need a more permissive
; definition in support of congruent stobjs (and perhaps local stobjs and stobj
; fields of nested stobjs).  Note that no ACL2 object is a simple-vector; in
; particular, a string is a vector but not a simple-vector.

  `(typep ,name 'simple-vector))

(defun array-etype-is-fixnum-type (array-etype)
  (declare (xargs :guard
                  (implies (consp array-etype)
                           (true-listp array-etype))))
  (and (consp array-etype)
       (case (car array-etype)
             (integer
              (let* ((e1 (cadr array-etype))
                     (int1 (if (integerp e1)
                               e1
                             (and (consp e1)
                                  (integerp (car e1))
                                  (1- (car e1)))))
                     (e2 (caddr array-etype))
                     (int2 (if (integerp e2)
                               e2
                             (and (consp e2)
                                  (integerp (car e2))
                                  (1- (car e2))))))
                (and int1
                     int2
                     (>= int1 (- *expt2-28*))
                     (< int2 *expt2-28*))))
             (mod
              (and (integerp (cadr array-etype))
                   (< (cadr array-etype)
                      *expt2-28*)))
             (unsigned-byte
              (and (integerp (cadr array-etype))
                   (<= (cadr array-etype)
                       29)))
             (signed-byte
              (and (integerp (cadr array-etype))
                   (<= (cadr array-etype)
                       30))))))

(defun defstobj-field-fns-raw-defs (var flush-var inline n ftemps)

; Warning: Keep the formals in the definitions below in sync with corresponding
; formals defstobj-field-fns-raw-defs.  Otherwise trace$ may not work
; correctly; we saw such a problem in Version_5.0 for a resize function.

; Warning:  See the guard remarks in the Essay on Defstobj Definitions.

  #-hons (declare (ignorable flush-var)) ; irrelevant var without hons
  (cond
   ((endp ftemps) nil)
   (t
    (append
     (let* ((field-template (car ftemps))
            (type (nth 1 field-template))
            (init (nth 2 field-template))
            (arrayp (and (consp type) (eq (car type) 'array)))
            (array-etype0 (and arrayp (cadr type)))
            (stobj-creator (get-stobj-creator (if arrayp array-etype0 type)
                                              nil))
            (scalar-type
             (if stobj-creator t type)) ; only used when (not arrayp)
            (array-etype (and arrayp
                              (if stobj-creator

; Stobj-creator is non-nil when array-etype is a stobj.  The real element type,
; then, is simple-array rather than a simple-array-type, so we might say that
; the parent stobj array is not simple.  But we will assume that the advantage
; of having a simple-vector for the parent stobj outweighs the advantage of
; having a simple-vector element type declaration.

                                  t
                                array-etype0)))
            (simple-type (and arrayp
                              (simple-array-type array-etype (caddr type))))
            (array-length (and arrayp (car (caddr type))))
            (vref (and arrayp
                       (if (eq (car simple-type) 'simple-vector)
                           'svref
                         'aref)))
            (fix-vref (and arrayp
                           (if (array-etype-is-fixnum-type array-etype)
                               'fix-aref
                             vref)))
            (accessor-name (nth 3 field-template))
            (updater-name (nth 4 field-template))
            (length-name (nth 5 field-template))
            (resize-name (nth 6 field-template))
            (resizable (nth 7 field-template)))
       (cond
        (arrayp
         `((,length-name
            (,var)
            ,@(and inline (list *stobj-inline-declare*))
            ,@(if (not resizable)
                  `((declare (ignore ,var))
                    ,array-length)
                `((the (and fixnum (integer 0 *))
                       (length (svref ,var ,n))))))
           (,resize-name
            (i ,var)
            ,@(if (not resizable)
                  `((declare (ignore i))
                    (prog2$
                     (er hard ',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."
                         ',accessor-name
                         ',var)
                     ,var))
                `((if (not (and (integerp i)
                                (>= i 0)
                                (< i array-dimension-limit)))
                      (hard-error
                       ',resize-name
                       "Attempted array resize failed because the requested ~
                        size ~x0 was not a nonnegative integer less than the ~
                        value of Common Lisp constant array-dimension-limit, ~
                        which is ~x1.  These bounds on array sizes are fixed ~
                        by ACL2."
                       (list (cons #\0 i)
                             (cons #\1 array-dimension-limit)))
                    (let* ((var ,var)
                           (old (svref var ,n))
                           (min-index (min i (length old)))
                           (new (make-array$ i

; The :initial-element below is probably not necessary in the case
; that we are downsizing the array.  At least, CLtL2 does not make any
; requirements about specifying an :initial-element, even when an
; :element-type is supplied.  However, it seems harmless enough to go
; ahead and specify :initial-element even for downsizing: resizing is
; not expected to be fast, we save a case split here (at the expense
; of this comment!), and besides, we are protecting against the
; possibility that some Common Lisp will fail to respect the spec and
; will cause an error by trying to initialize a fixnum array (say)
; with NILs.

                                             :initial-element
                                             ',init
                                             :element-type
                                             ',array-etype)))
                      #+hons (memoize-flush ,flush-var)
                      (setf (svref var ,n)
                            (,(pack2 'stobj-copy-array- fix-vref)
                             old new 0 min-index))
                      ,@(and stobj-creator
                             `((when (< (length old) i)
                                 (loop for j from (length old) to (1- i)
                                       do (setf (svref new j)
                                                (,stobj-creator))))))
                      var)))))
           (,accessor-name
            (i ,var)
            (declare (type (and fixnum (integer 0 *)) i))
            ,@(and inline (list *stobj-inline-declare*))
            (the ,array-etype
                 (,vref (the ,simple-type (svref ,var ,n))
                        (the (and fixnum (integer 0 *)) i))))
           (,updater-name
            (i v ,var)
            (declare (type (and fixnum (integer 0 *)) i)
                     (type ,array-etype v))
            ,@(and inline (list *stobj-inline-declare*))
            (progn
              #+hons (memoize-flush ,flush-var)

; See the long comment below for the updater in the scalar case, about
; supporting *1* functions.

              (setf (,vref (the ,simple-type (svref ,var ,n))
                           (the (and fixnum (integer 0 *)) i))
                    (the ,array-etype v))
              ,var))))
        ((eq scalar-type t)
         `((,accessor-name (,var)
                           ,@(and inline (list *stobj-inline-declare*))
                           (svref ,var ,n))
           (,updater-name (v ,var)
                          ,@(and inline (list *stobj-inline-declare*))
                          (progn
                            #+hons (memoize-flush ,flush-var)

; For the case of a stobj field, we considered causing an error here since the
; raw Lisp code for stobj-let avoids calling updaters because there is no need:
; updates for fields that are stobjs have already updated destructively.
; However, a raw Lisp updater can be called by a *1* function, say *1*f,
; applied to live stobjs, when guard checking does not pass control to the raw
; Lisp function, f.  Perhaps we could optimize to avoid this, but there is no
; need; this setf is fast and is only called on behalf of executing *1*
; function calls.  See the comment referencing "defstobj-field-fns-raw-defs" in
; community book misc/nested-stobj-tests.lisp.  To see this point in action,
; evaluate the forms under that comment after modifying this definition by
; uncommenting the following line of code.

;                           ,@(when stobj-creator '((break$))) ; see just above

                            (setf (svref ,var ,n) v)
                            ,var))))
        (t
         (assert$
          (not stobj-creator) ; scalar-type is t for stobj-creator
          `((,accessor-name (,var)
                            ,@(and inline (list *stobj-inline-declare*))
                            (the ,scalar-type
                                 (aref (the (simple-array ,scalar-type (1))
                                            (svref ,var ,n))
                                       0)))
            (,updater-name (v ,var)
                           (declare (type ,scalar-type v))
                           ,@(and inline (list *stobj-inline-declare*))
                           (progn
                             #+hons (memoize-flush ,flush-var)
                             (setf (aref (the (simple-array ,scalar-type (1))
                                              (svref ,var ,n))
                                         0)
                                   (the ,scalar-type v))
                             ,var)))))))
     (defstobj-field-fns-raw-defs var flush-var inline (1+ n) (cdr ftemps))))))

(defun defstobj-raw-init-fields (ftemps)

; Keep this in sync with defstobj-axiomatic-init-fields.

  (cond
   ((endp ftemps) nil)
   (t (let* ((field-template (car ftemps))
             (type (nth 1 field-template))
             (arrayp (and (consp type) (eq (car type) 'array)))
             (array-etype0 (and arrayp (cadr type)))
             (array-size (and arrayp (car (caddr type))))
             (stobj-creator (get-stobj-creator (if arrayp array-etype0 type)
                                               nil))
             (array-etype (and arrayp

; See comment for this binding in defstobj-field-fns-raw-defs.

                               (if stobj-creator
                                   t
                                 array-etype0)))
             (init (nth 2 field-template)))
        (cond
         (arrayp
          (cons (cond (stobj-creator
                       (assert$
                        (null init) ; checked by chk-stobj-field-descriptor
                        (assert$

; We expect array-size to be a natural number, as this is checked by
; chk-stobj-field-descriptor (using fix-stobj-array-type).  It is important
; that array-size not be a Lisp form that references the variable AR, even
; after macroexpasion, in order to avoid capture by the binding of AR below.

                         (natp array-size)
                         `(let ((ar (make-array$ ,array-size

; Do not be tempted to use :initial-element (,stobj-creator) here, because that
; would presumably share structure among all the created stobjs.

                                                 :element-type ',array-etype)))
                            (loop for i from 0 to ,(1- array-size)
                                  do
                                  (setf (svref ar i) (,stobj-creator)))
                            ar))))
                      (t `(make-array$ ,array-size
                                       :element-type ',array-etype
                                       :initial-element ',init)))
                (defstobj-raw-init-fields (cdr ftemps))))
         ((eq type t)
          (cons (kwote init) (defstobj-raw-init-fields (cdr ftemps))))
         (stobj-creator
          (cons `(,stobj-creator) (defstobj-raw-init-fields (cdr ftemps))))
         (t (cons `(make-array$ 1
                                :element-type ',type
                                :initial-element ',init)
                  (defstobj-raw-init-fields (cdr ftemps)))))))))

(defun defstobj-raw-init (template)

; This function generates the initialization code for the live object
; representing the stobj name.

  (let ((field-templates (caddr template)))
    `(vector ,@(defstobj-raw-init-fields field-templates))))

(defun defstobj-raw-defs (name template congruent-stobj-rep wrld)

; Warning:  See the guard remarks in the Essay on Defstobj Definitions.

; This function generates a list of defs.  Each def is such that
; (defun . def) is a well-formed raw Lisp definition.  The defuns can
; be executed in raw lisp to define the versions of the recognizers,
; accessors, and updaters (and for array fields, length and resize
; functions) that are run when we know the guards are satisfied.  Many
; of these functions anticipate application to the live object itself.

; It is permissible for wrld to be nil, as this merely defeats additional
; checking by translate-declaration-to-guard.  If wrld is nil, then
; congruent-stobj-rep should be the result of calling congruent-stobj-rep on
; name and the world where the corresponding defstobj is executed.  If wrld is
; non-nil, then it should be an ACL2 world and congruent-stobj-rep is
; irrelevant.

; WARNING: If you change the formals of these generated raw defs be
; sure to change the formals of the corresponding axiomatic defs.

  (let* ((recog (first template))
         (creator (second template))
         (field-templates (third template))
         (inline (fifth template)))
    (append
     (all-but-last
      (defstobj-component-recognizer-axiomatic-defs name template
        field-templates wrld))
     `((,recog (,name)
               (cond
                ((live-stobjp ,name)
                 t)
                (t (and (true-listp ,name)
                        (= (length ,name) ,(length field-templates))
                        ,@(defstobj-component-recognizer-calls
                            field-templates 0 name nil)))))
       (,creator ()
                 ,(defstobj-raw-init template))
       ,@(defstobj-field-fns-raw-defs
           name
           (if wrld
               (congruent-stobj-rep (or (sixth template) name)
                                    wrld)
             congruent-stobj-rep)
           inline 0 field-templates)))))

(defun put-stobjs-in-and-outs1 (name ftemps wrld)

; See put-stobjs-in-and-outs for a table that explains what we're doing.

  (cond
   ((endp ftemps) wrld)
   (t (let ((type (nth 1 (car ftemps)))
            (acc-fn (nth 3 (car ftemps)))
            (upd-fn (nth 4 (car ftemps)))
            (length-fn (nth 5 (car ftemps)))
            (resize-fn (nth 6 (car ftemps))))
        (put-stobjs-in-and-outs1
         name
         (cdr ftemps)
         (cond
          ((and (consp type)
                (eq (car type) 'array))
           (let* ((etype (cadr type))
                  (stobj-flg (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)))))))))
          (t
           (let ((stobj-flg (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.

; Relevant functions and their settings:

;      fn                  stobjs-in         stobjs-out
; topmost recognizer       (name)            (nil)
; creator                  ()                (name)
; field recogs             (nil ...)         (nil)
; simple accessor          (name)            (nil)
; array accessor           (nil name)        (nil)
; simple updater           (nil name)        (name)
; array updater            (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
; and the accessors -- which do not return stobjs, 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 (car template))
        (creator-name (cadr template))
        (field-templates (caddr template)))

; Each element of field templates is of the form:
;       0      1                     2    3    4        5
; (field-recog field-recog-helper-fn type init accessor updater)
; or, for arrays,
; (field-recog field-recog-helper-fn type init accessor updater length-name
;  resize-name)
; and we know if the field is simple or an array according to whether
; (car type) is ARRAY.

    (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 strip-accessor-names (x)

; This could just as well be called strip-cadddrs.  X is the caddr of a
; defstobj template; see defstobj-template.

  (if (endp x)
      nil
    (cons (cadddr (car x))
          (strip-accessor-names (cdr x)))))

(defun defstobj-defconsts (names index)
  (if (endp names)
      nil
    (cons `(defconst ,(defconst-name (car names)) ,index)
          (defstobj-defconsts (cdr names) (1+ index)))))

(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
   (if (output-in-infixp state)
       event-form
     (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))
        (t
         (enforce-redundancy
          event-form ctx wrld0
          (let* ((template (defstobj-template name args wrld1))
                 (field-names (strip-accessor-names (caddr template)))
                 (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 (car template))
                 (creator-name (cadr template))
                 (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 puts each updater immediately after
; the corresponding accessor, as assumed by function chk-stobj-let/updaters1.

		  (strip-cars ax-def-lst))
                 (the-live-var (the-live-var name))
                 (doc (fourth template))
                 (congruent-to (sixth template)))
            (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 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 since its *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
                                         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.

                (er-let*
                 ((doc-pair (translate-doc name doc ctx state)))
                 (let* ((wrld2 (w state))
                        (wrld3
                         (update-doc-database
                          name doc doc-pair
                          (putprop
                           name 'congruent-stobj-rep
                           (and congruent-to
                                (congruent-stobj-rep congruent-to wrld2))
                           (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
                              (cons the-live-var
                                    (list*
                                     recog-name
                                     creator-name
                                     (append (remove1-eq
                                              creator-name
                                              (remove1-eq recog-name

; See the comment in the binding of names above.

                                                          names))
                                             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))))))))))))

; The property 'stobj marks a single-threaded object name.  Its value is a
; non-nil list containing all the names associated with this object.  The car
; of the list is always the live variable name for the object.  The cadr and
; caddr of the list (for all user-defined stobjs, i.e., all but our STATE) are
; the stobj recognizer and creator for the stobj, respectively.  The remaining
; elements are the names of the other events introduced, including definitions
; of the accessors and the updaters.

; 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
                                     ,template
                                     ,ax-def-lst)
                                  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
; motivation is to understand why the standard logical definition of evaluation
; is correctly implemented by how evaluation really works in Lisp, using live
; stobjs.

; Below, we use the term ``stobj primitive (for s)'' to indicate a function
; introduced by a defstobj or (more often) defabsstobj event (for stobj s).  In
; the case of defabsstobj, an ``:EXEC function'' or ``:LOGIC function'' is a
; stobj primitive associated with an :EXEC or :LOGIC keyword (perhaps by
; default), respectively.

; Informally, we wish to relate two kinds of evaluation, one using :LOGIC
; primitives and one using corresponding :EXEC primitives, in corresponding
; environments where each abstract stobj is bound to an object satisfying its
; :LOGIC recognizer in the first environment and its :EXEC recognizer in the
; second.  Such evaluation will enforce guards before making calls of stobj
; primitives at the :LOGIC level and (as we will see, by the :GUARD-THM
; theorems) guarantee that guards thus hold for calls of stobj primitives at
; the :EXEC level.  Because of the latter, we can even imagine passing live
; stobjs around for the :EXEC evaluation.  But the replacement of ACL2 objects
; by live stobjs is not what's new for abstract stobjs, so we do not address it
; here.  Thus in the remainder of this Essay, we deal only with ACL2 objects,
; without any consideration of raw Lisp evaluation using live stobjs.  We
; imagine two sorts of logical evaluation using either :LOGIC or :EXEC
; primitives, with the goal of showing that they keep the corresponding states
; (latches) in sync.

; Fix an ACL2 world, and let A be a set of abstract stobj names.  We introduce
; a variant of EV, A-evaluation, which models evaluation using :EXEC functions
; for abstract stobjs in A.  (But note that throughout, we ignore the EV
; arguments of state, hard-error-returns-nilp, and aok, which aren't of
; interest for our exposition.  See also the Essay on EV for some relevant
; background.)  As is the case for EV, A-evaluation maps a term, alist, and
; latches to a (possibly multiple) value and new latches, but for A-evaluation
; there is a new wrinkle: for each function symbol f introduced for an abstract
; stobj in A that is bound in latches, the :EXEC definition of f is used
; (instead of the logical definition, which invokes the :LOGIC function).  If A
; is the empty set, then A-evaluation reduces to EV, and we call it
; pure-evaluation.  As with EV, A-evaluation comprehends guards and can return
; an error indication when there is a guard violation; and in that case, as
; with actual ACL2 evaluation, it must return such an error when latched stobjs
; are involved (even with guard-checking nil or :NONE).

; It is tempting to show a direct correspondence between pure-evaluation and
; A-evaluation, where A is the set of abstract stobj names.  But we will
; instead define a sort of "dual-rail" evaluator that does both of these
; together, because we need those two evaluations to stop at the same time in
; order to compare their returned latches.  Now, it is possible to show that
; A-evaluation continues for at _least_ as long as pure-evaluation, by applying
; the :GUARD-THM theorems when comparing a :LOGIC function call during
; pure-evaluation with a corresponding :EXEC function call during A-evaluation.
; But A-evaluation could run longer, so we need a way to stop it at the point
; that pure-evaluation stops, in order to compare the returned latches for
; each.  Before we define our dual-rail evaluator, we need a few definitions.

; For a set A of abstract stobj names, an alist S is A-valid if for every stobj
; name s0 in the domain of S: if s0 is in A then S(s0) satisfies the :EXEC
; recognizer for s0, and otherwise S(s0) satisfies the recognizer for s0
; (hence, the :LOGIC recognizer for s0 if s0 is an abstract stobj).  We may say
; ``valid'' in place of ``A-valid'' if A is clear from context or
; ``pure-valid'' if A is the empty set.

; For a given abstract stobj s0, two ACL2 objects x$c and x$a are said to
; s0-correspond (or, just "correspond" if s0 is clear from context) if
; corr(x$c,x$a) holds, where corr is the (ordinary logical interpretation of
; the) :CORR-FN for s0.  Let A be a set of abstract stobj names and let S$c and
; S$a be alists.  We say that S$c and S$a A-correspond if they have the same
; domain and for every x in their domain: if x is in A then S$c(x) and S$a(x)
; correspond, and otherwise S$c(x) = S$a(x).  In the context of an expected
; stobjs-out, two results A-correspond if they have the same number of values
; and for each position n, if the nth element of the stobjs-out is some s0 in A
; then the respective nth values s0-correspond, and otherwise the respective
; nth values are equal.

; We are ready to model dual-rail evaluation with a function ev5.

;   (ev5 term alist$a alist$c latches$a latches$c A)
;   =
;   (mv erp result$c result$a latches$c' latches$a')

; The definition of EV5 (details omitted here) is, with two exceptions
; discussed below, a straightforward modification of EV for a dual-rail
; semantics, i.e., returning the results of A-evaluation (result$c and
; latches$c') and pure-evaluation (result$a and latches$a').  The first
; exception is that guards are checked only for pure-evaluation.  The second
; exception pertains to any call of a primitive for an abstract stobj in A that
; is bound in latches$c (or equivalently, in latches$a).  In that case,
; A-evaluation and pure-evaluation are used independently on the :EXEC and
; :LOGIC functions for the primitive, respectively, to compute the result pairs
; <result$c,latches$c'> and <result$a,latches$a'>, respectively).  We argue
; below that both of these evaluations occur without guard violations.

; The following correctness claim justifies the use of concrete stobjs to
; simulate evaluation with abstract stobjs.

;   Claim.  Let A be a set of abstract stobj names, and let u be a term.  Also
;   let S$c and S$a be A-corresponding alists that are A-valid and pure-valid,
;   respectively, with a common domain that includes all free variables of u.
;   Let L$c and L$a be the respective restrictions of S$c and S$a to a common
;   set of stobj names, and assume that A is a subset of the common domain of
;   L$c and L$a.  Assume either of the following, where EV_A is the variant of
;   EV that evaluates using :EXEC functions in the case of stobj primitives for
;   members of A.

;   (a) (ev_A u S$c L$c) = (mv erp r$c L$c')
;       AND
;       (ev   u S$a L$a) = (mv nil r$a L$a')
;   OR
;   (b) (ev5 u S$c S$a L$c L$a A) = (mv erp r$c r$a L$c' L$a').

;   Then the following properties hold.

;   (1) In case (b) with erp nil, and in case (a) (for any erp):
;       (i)  r$c A-corresponds to r$a; and
;       (ii) L$c' and L$a' are the respective updates of L$c and L$a
;            according to r$c, r$a, and the stobjs-out of u, in the obvious
;            sense.
;   (2) L$c', L$a', L$c, and (thus) L$a all have the same domain.
;   (3) L$c' A-corresponds to L$a'.
;   (4) L$c' is A-valid and L$a' is pure-valid.
;   (5) In case (a), erp is nil.

; Remark.  The subset restriction does not impair the relevance of this Claim.
; In an actual evaluation in the top-level loop, consider the latches as
; including a binding for every known stobj name that occurs in the term to be
; evaluated.  Local stobjs and stobj-let-bound stobjs don't present a problem,
; since each will add a binding to the latches; but we ignore these for the
; proof.

; Proof.  We give only an outline of the proof, first dealing with (a) by
; itself, then using (a) in the proof sketch for (b).

; The proof of (a) is by induction on A.  First consider the base case, where A
; is empty.  Clearly (1)(i), (3), and (5) hold vacuously.  Parts (1)(ii) and
; (2) are just facts about EV.  Finally, (4) reduces to showing that L$a' is
; pure-valid.  This follows from the :PRESERVED theorems, each of which has a
; stobj primitive guard as a hypothesis, and the fact that EV returns an error
; (mv non-nil ...) when the guard doesn't hold for a call of a stobj primitive.
; We omit details.

; So assume that A is non-empty.  Let s0 be the abstract stobj in A that was
; last introduced in the world.  Hence we may write A = A' U {s0} where by the
; inductive hypothesis, the claim holds for A'.

; We now proceed by computational induction.  We consider only the interesting
; case, leaving the rest to the reader: u is (f ... s0 ...), where f is a stobj
; primitive for s0 (whose arguments may include members of A'), and where the
; arguments evaluate without error.  Thus, we may assume (a), since (b) clearly
; implies (a) in the non-error case.  Let f$a and f$c be the :LOGIC and :EXEC
; functions for f (respectively).  For notational simplicity we consider only
; the case that f returns a single value; the general case is really the same,
; except for focusing on a particular position's result.  Let r' be the result
; of pure-evaluation of (f$c ... s0 ...).  We make the following two
; observations, each followed by a justification.

; (*)   r' {s0}-corresponds to r$a.

; To see this, first note that since we are assuming that the evaluation (ev u
; S$a L$a) does not result in an error, i.e., returns (mv nil ...), we know
; that the guard of f is met for the call of f in the term u.  We may therefore
; apply the :CORRESPONDENCE theorem for f, to show that (f$c ... s0 ...) and
; (f$a ... s0 ...) {s0}-correspond.  But these are respectively equal to r' and
; r$a because pure-evaluation (i.e., EV) returns a result provably equal to its
; input.

; (**)  r$c A'-corresponds to r'.

; This holds by the inductive hypothesis on A', since A'-evaluation of the body
; of f$c produces the same result as A-evaluation of the body of f$c (namely,
; r$c), as no primitive function for s0 is ancestral in f$c (because f$c was
; defined before the introduction of abstract stobj s0).

; From (*) and (**), a case analysis (on the type of result returned by f)
; yields that r$c A-corresponds to r$a.  Conclusion (1)(i) follows, and
; (1)(ii), (2), and (3) then follow by usual arguments for EV.  For (5), we
; observe that since the guard holds for the call of f (as argued for (*)
; above)), then by the :GUARD-THM theorems, the guard holds for the
; corresponding call of f$c; hence since f$c is guard-verified, its call's
; A-evaluation concludes without error.  For (4): the preservation of stobj
; recognizers for other than abstract stobjs, and thus for :EXEC recognizers
; for abstract stobjs in A, is a well-known property of well-guarded stobj
; computations (and the f$c is indeed well-guarded, as argued for (5) above);
; and for :LOGIC recognizers of stobjs in A it follows from the :PRESERVED
; theorems.  Note that the :PRESERVED theorems again require that the guard is
; met, which was argued above.

; That concludes the proof of case (a), so we now consider case (b).  The proof
; is by computational induction.  The interesting case is the same one we dealt
; with in the proof of case (a).  In case (b), EV5 first checks the guard for
; pure evaluation before passing control to EV_A and EV, passing up (mv erp
; ...) with erp non-nil if the check fails; and in that case we simply appeal
; to the inductive hypothesis.  But if the guard-check succeeds, then since f
; is guard-verified, we know that there will be no guard violation, and
; pure-evaluation (EV) will return with erp = nil.  So we can apply case (a),
; completing the proof.

; Note: the argument above probably works if we allow an arbitrary guard for a
; function exported by defabsstobj instead of using the guard of its :logic
; function.  If the need for such flexibility arises (presumably in the form of
; a new :guard keyword for defabsstobj :exports), we should revisit this Essay
; in order to be sure that the argument holds together.  But careful: allowing
; an arbitrary guard might not be feasible!  A comment in update-guard-post
; explains that substituting exported functions for their :logic versions has
; the property that guard proof obligations are essentially preserved.  But the
; use of user-supplied guards destroys that argument, and as a result, we no
; longer can trust evaluation of the guard in raw Lisp.

(defun absstobj-name (name type)

; Warning: The (absstobj-name name :CREATOR) should equal (defstobj-fnname name
; :CREATOR :TOP nil), because of the use of the latter in
; parse-with-local-stobj.

  (declare (type symbol name type))
  (mv-let (prefix suffix)
          (case type
            (:A (mv nil "$A")) ; abstract
            (:C (mv nil "$C")) ; concrete
            (:CREATOR (mv "CREATE-" nil))
            (:RECOGNIZER (mv nil "P"))
            (:RECOGNIZER-LOGIC (mv nil "$AP"))
            (:RECOGNIZER-EXEC (mv nil "$CP"))
            (:CORR-FN (mv nil "$CORR"))
            (:CORRESPONDENCE (mv nil "{CORRESPONDENCE}"))
            (:PRESERVED (mv nil "{PRESERVED}"))
            (:GUARD-THM (mv nil "{GUARD-THM}"))
            (otherwise (mv (er hard 'absstobj-name
                               "Unrecognized type, ~x0."
                               type)
                           nil)))
          (let* ((s (symbol-name name))
                 (s (if prefix (concatenate 'string prefix s) s))
                 (s (if suffix (concatenate 'string s suffix) s)))
            (intern-in-package-of-symbol s name))))

#-acl2-loop-only
(defmacro defabsstobj (&whole event-form
                              name
                              &key
                              concrete recognizer creator exports
                              protect-default
                              &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)))
         (st$c (cond ((null concrete) (absstobj-name name :C))
                     ((consp concrete) (car concrete))
                     (t concrete)))
         (creator (or creator (absstobj-name name :CREATOR)))
         (creator-name (if (consp creator)
                           (car creator)
                         creator))
         (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
       `(progn

; We place the defvar above the subsequent let*, in order to avoid
; warnings in Lisps such as CCL that compile on-the-fly.

          (defvar ,the-live-name)

; 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) corresponding 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* ((boundp (boundp ',the-live-name))
                 (d (and boundp
                         (get ',the-live-name
                              'redundant-raw-lisp-discriminator)))
                 (ok-p (and boundp
                            (equal d ',event-form))))
            (cond
             (ok-p ',name)
             ((and boundp (not (raw-mode-p *the-live-state*)))
              (interface-er
               "Illegal attempt to redeclare the (abstract) single-threaded ~
                object ~s0."
               ',name))
             (t
              (setf ,the-live-name
                ,(defabsstobj-raw-init creator-name methods))
              (setf (get ',the-live-name 'redundant-raw-lisp-discriminator)
                    ',event-form)
              (let ((old (and boundp ; optimization (as for defstobj)
                              (assoc-eq ',name *user-stobj-alist*))))
                (cond
                 (old ; 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)
                  (setf (cdr old)
                        (symbol-value ',the-live-name)))
                 (t
                  (assert$
                   (not (assoc-eq ',name *user-stobj-alist*))
                   (setq *user-stobj-alist*
                         (cons (cons ',name (symbol-value ',the-live-name))
                               *user-stobj-alist*))))))
              ',name)))))))))

#+acl2-loop-only
(defmacro defabsstobj (&whole event-form
                              name
                              &key
                              concrete recognizer creator corr-fn exports
                              protect-default
                              congruent-to missing-only doc)

  ":Doc-Section Events

  define a new abstract single-threaded object ~/

  We assume familiarity with single-threaded objects; ~pl[stobj] and
  ~pl[defstobj].  The event ~c[defabsstobj] defines a so-called ``abstract
  stobj'', a notion we introduce briefly now and then explain in more depth
  below.

  The evaluation of a ~il[defstobj] event produces logical definitions for
  several functions: a recognizer, which characterizes the ~il[stobj] in terms
  of lists; a creator, which produces an initial suitable list structure; and
  field accessors and updators, defined in terms of ~ilc[nth] and
  ~ilc[update-nth].  ~c[Defabsstobj] provides a way to define alternate
  definitions for ``stobj primitives'' for a corresponding single-threaded
  object.  These stobj primitives include a recognizer, a creator, and other
  ``exported'' functions.  In essence, ~c[defabsstobj] establishes interface
  functions, or ``exports'', on a new stobj that is a copy of an indicated
  ``concrete'' stobj that already exists.

  We begin below with an introduction to abstract ~il[stobj]s.  We then explain
  the ~ilc[defabsstobj] event by way of an example.  We conclude by giving
  summary documentation for the ~c[defabsstobj] event.

  For another introduction to abstract stobjs, see the paper ``Abstract Stobjs
  and Their Application to ISA Modeling'' by Shilpi Goel, Warren A. Hunt, Jr.,
  and Matt Kaufmann, in the proceedings of ACL2 Workshop 2013,
  ~url[http://www.cs.uwyo.edu/~~ruben/acl2-13].~/

  ~st[INTRODUCTION]

  We start with a brief review of ~il[stobj]s and some potential problems with
  them, followed by an introduction to abstract stobjs and how they can avoid
  these problems.  Prior experience with stobjs will probably help the reader
  to absorb the ideas below.

  Recall that single-threaded objects, or ~il[stobj]s, provide a way for ACL2
  users to stay within the ACL2 logic, where every data object is an atom or a
  ~ilc[cons] of data objects, while obtaining the benefits of fast evaluation
  through destructive updates.  Consider for example this very simple event.
  ~bv[]
  (defstobj st fld)
  ~ev[]
  This event introduces a recognizer, ~c[stp], and a creator, ~c[create-st],
  for a data structure consisting of a single field accessed and updated by
  functions ~c[fld] and ~c[update-fld], respectively.  Each of these four
  primitive functions has both a logical definition, which is used when the
  prover reasons about the function, and an executable definition, which is
  used in raw Lisp.  In the logic, ~c[stp] recognizes objects that have the
  requisite fields.  In raw Lisp, there is a ``live stobj'', which is an array
  object whose fields correspond to those specified by the ~ilc[defstobj]
  event, implemented as Lisp arrays.

  Here are the logical definition and the executable definition, respectively,
  that are introduced for the field accessor, ~c[fld], introduced above.
  Notice that since a stobj is represented in raw Lisp using an array, the raw
  Lisp accessor uses a raw Lisp array accessor, ~c[svref].  (You can see all
  the logical and executable definitions by evaluating the form
  ~c[(trace$ defstobj-axiomatic-defs defstobj-raw-defs)] before evaluating the
  ~ilc[defstobj] form.)
  ~bv[]
  ; logical definition
  (defun fld (st)
    (declare (xargs :guard (stp st)
                    :verify-guards t))
    (nth 0 st))

  ; executable (raw Lisp) definition
  (defun fld (st)
    (svref st 0))
  ~ev[]

  Sophisticated programming with stobjs can provide efficient implementations
  of algorithms, but may require the preservation of a complex invariant.  One
  can, of course, define a function to implement such an invariant after
  introducing the stobj, as follows.
  ~bv[]
  ; Introduce a stobj.
  (defstobj st fld1 ... fldk)

  ; Define an invariant on that stobj.
  (defun good-stp (st)
    (declare (xargs :stobjs st))
    ...)

  ; Define some basic functions that update the stobj and preserve the
  ; invariant.
  (defun update-st (... st ...)
    (declare (xargs :stobjs st
                    :guard (and (good-stp st) ...)))
    ...)
  ...

  ; Prove that the invariant is indeed preserved by those basic functions.
  (defthm good-stp-update-st
    (implies (and (good-stp st)
                  ...)
             (good-stp (update-st ... st ...))))
  ...

  ; Implement algorithms built on the basic functions.
  (defun foo (... st ...)
    (declare (xargs :stobjs st
                    :guard (and (good-stp st) ...)))
    ... (update-st ... st ...) ...)

  ; Prove invariance theorems about these algorithms.
  (defthm good-stp-foo
    (implies (and (good-stp st)
                  ...)
             (good-stp (foo ... st ...))))
  ...

  ; Prove other properties of these algorithms.
  (defthm foo-is-correct
    (implies (and (good-stp st)
                  ...)
             (some-property (foo ... st ...))))
  ...
  ~ev[]

  But there are at least two potential difficulties in using stobjs as
  described above.
  ~bq[]
  1. When ~c[foo] is executed on concrete data in the ACL2 loop, the guard
  check may be expensive because ~c[(good-stp st)] is expensive.

  2. Reasoning about ~c[foo] (using rules like ~c[foo-is-correct] above)
  involves proving hypotheses of invariance theorems, which may be complicated
  for the user to manage or slow for the theorem prover.~eq[]

  The ~c[defabsstobj] event offers an opportunity to address these issues.  It
  introduces a new stobj, which we call an ``abstract stobj'', which is
  associated with a corresponding ``concrete stobj'' introduced by an earlier
  ~ilc[defstobj] event.  The ~c[defabsstobj] event specifies a logical
  (~c[:LOGIC]) and an executable (~c[:EXEC]) definition for each primitive
  operation, or ``stobj primitive'', involving that stobj.  As is the case for
  ~ilc[defstobj], the logical definition is what ACL2 reasons about, and is
  appropriate to apply to an ACL2 object satisfying the logical definition of
  the recognizer function for the stobj.  The executable definition is applied
  in raw Lisp to a live stobj, which is an array object associated with the
  given stobj name.

  We can picture a sequence of updates to corresponding abstract and concrete
  stobjs as follows.  Initially in this picture, ~c[st$a0] and ~c[st$c0] are a
  corresponding abstract and concrete stobj (respectively).  Then an update,
  ~c[u1], is applied with ~c[:LOGIC] and ~c[:EXEC] functions ~c[u$a1] and
  ~c[u$c1], respectively.  The resulting abstract and concrete stobj, ~c[st$a1]
  and ~c[st$c1], correspond as before.  Then a second update, ~c[u2], is
  applied with ~c[:LOGIC] and ~c[:EXEC] functions ~c[u$a2] and ~c[u$c2],
  respectively ~-[] again preserving the correspondence.  And so on.

  ~bv[]
  Abstract               u$a1       u$a2       u$a3
  (:logic)         st$a0  --> st$a1  --> st$a2  -->   ...

                     ^          ^          ^               ^
  Correspondence     |          |          |          ...  |
                     v          v          v               v

                         u$c1       u$c2       u$c3
  Concrete         st$c0  --> st$c1  --> st$c2  -->   ...
  (:exec)
  ~ev[]

  We conclude this introduction with some remarks about implementation.
  Consider an abstract stobj ~c[st] with corresponding concrete stobj ~c[st$c].
  The live stobjs for ~c[st] and ~c[st$c] have the same structure, but are
  distinct arrays.  Indeed, the raw Lisp creator function for ~c[st$c] is
  called to create a new initial live stobj for ~c[st].  As we will see below,
  reads and writes in raw Lisp to the live stobj for ~c[st] are ultimately
  performed using the primitive accessors and updaters defined for ~c[st$c].
  One might think of the live stobjs for ~c[st] and ~c[st$c] as being congruent
  stobjs (~pl[defstobj]), except that the stobjs themselves are not congruent:
  the stobj primitives introduced for ~c[st] may be applied to ~c[st] but not
  arbitrary field updaters of ~c[st$c], for example.  As one might expect, the
  ~c[:EXEC] function for an exported function is applied to the live stobj for
  ~c[st] in raw Lisp.

  ~st[EXAMPLE]

  We present examples, with detailed comments intended to explain abstract
  stobjs, in two community books: ~c[books/misc/defabsstobj-example-1.lisp] and
  ~c[books/misc/defabsstobj-example-2.lisp].  In this section we outline the
  first of these.  We suggest that after you finish this ~il[documentation]
  topic, you read through those two books.

  Here is the first of two closely related ~c[defabsstobj] ~il[events] from the
  book ~c[defabsstobj-example-1.lisp], but in expanded form.  We will show the
  abbreviated form later, which omits most of data in the form that is
  immediately below.  Thus most of the information shown here is default
  information.  We believe that the comments below explain most or all of what
  you need to know in order to start using ~c[defabsstobj], and that you will
  learn the remainder when you see error messages.  For example, we do not say
  in the comments below that every ~c[:LOGIC] and ~c[:EXEC] function must be
  ~il[guard]-verified, but that is indeed a requirement.

  ~bv[]
  (defabsstobj st ; The new abstract stobj is named st.

  ; The concrete stobj corresponding to st is st$c:

    :concrete st$c

  ; The recognizer for the new abstract stobj is stp, which is defined to be
  ; st$ap in the logic, and is executed on the live stobj in raw Lisp using
  ; st$cp.

    :recognizer (stp :logic st$ap :exec st$cp)

  ; The initial stobj is defined as create-st (a function of no arguments),
  ; which is defined logically as create-st$a, though create-st$c is invoked to
  ; create the initial live stobj for st.  The :correspondence and :preserved
  ; keywords refer to proof obligations, discussed below.

    :creator (create-st :logic create-st$a :exec create-st$c
                        :correspondence create-st{correspondence}
                        :preserved create-st{preserved})

  ; Proof obligations are generated that involve a correspondence between the
  ; new abstract stobj and corresponding concrete stobj.  The function
  ; st$corr, which need not be executable (see :DOC defun-nx), takes two
  ; arguments, a concrete stobj and an abstract stobj.  This function symbol is
  ; used in the statements of the proof obligations.

    :corr-fn st$corr

  ; In this example we have four exports.  In each case a new function is
  ; introduced that has the same signature as its :EXEC function, except that
  ; st$c is replaced by st.  The :LOGIC and :EXEC functions are as specified,
  ; and the other keywords refer to proof obligations that we discuss below.

    :exports ((lookup :logic lookup$a
                      :exec mem$ci
                      :correspondence lookup{correspondence}
                      :guard-thm lookup{guard-thm})
              (update :logic update$a
                      :exec update-mem$ci
                      :correspondence update{correspondence}
                      :preserved update{preserved}
                      :guard-thm update{guard-thm})
              (misc :logic misc$a
                    :exec misc$c
                    :correspondence misc{correspondence})
              (update-misc :logic update-misc$a
                           :exec update-misc$c
                           :correspondence update-misc{correspondence}
                           :preserved update-misc{preserved}))
    :doc nil)
  ~ev[]

  Note that all stobj primitives (recognizer, creator, and exported functions)
  are defined in the ACL2 loop in terms of their ~c[:LOGIC] functions and in
  raw Lisp in terms of their ~c[:EXEC] functions.  In the ACL2 loop, a
  ~ilc[defun] form defines a function, while in raw Lisp, a ~ilc[defmacro] form
  defines a macro (for efficiency).  We first illustrate how that works for the
  recognizer.  (You can see all the logical and executable definitions by
  evaluating the form
  ~c[(trace$ defabsstobj-axiomatic-defs defabsstobj-raw-defs)] before
  evaluating the ~ilc[defstobj] form.)
  ~bv[]
  ; In the ACL2 loop:
  (defun stp (st)
    (declare (xargs :guard 't))
    (st$ap st))

  ; In raw Lisp:
  (defmacro stp (&rest args) (cons 'st$cp args))
  ~ev[]

  The definitions are made similarly for exported functions, with ~il[guard]s
  derived from their ~c[:LOGIC] functions as follows.  Consider the exported
  function ~c[update] in our example.  Its ~c[:LOGIC] function, ~c[update$a],
  has formals ~c[(k val st$a)] and the following guard.
  ~bv[]
  (and (and (integerp k) (<= 0 k) (<= k 49))
       (and (integerp val) (<= 0 val))
       (st$ap st$a)
       (mem$c-entryp val))
  ~ev[]
  The formals of ~c[update] are obtained by starting with the formals of its
  ~c[:EXEC] function, ~c[update-mem$ci] ~-[] which are ~c[(i v st$c)] ~-[] and
  replacing the concrete stobj name ~c[st$c] by the new stobj name ~c[st].  The
  formals of ~c[update] are thus ~c[(i v st)].  The guard for ~c[update] is
  obtained in two steps.  The first step is to substitute the formals of
  ~c[update] for the formals of ~c[update$a] in the guard for ~c[update$a], to
  obtain the following.
  ~bv[]
  (and (and (integerp i) (<= 0 i) (<= i 49))
       (and (integerp v) (<= 0 v))
       (st$ap st)
       (mem$c-entryp v))
  ~ev[]
  The second step is to replace, for each new stobj primitive ~c[p], the
  ~c[:LOGIC] function for ~c[p] by ~c[p] itself.  The only ~c[:LOGIC] function
  occurring in the formula just above is ~c[st$ap], which is the ~c[:LOGIC]
  funcction for ~c[stp].  The guard for ~c[update] is thus as follows.
  ~bv[]
  (and (and (integerp i) (<= 0 i) (<= i 49))
       (and (integerp v) (<= 0 v))
       (stp st)
       (mem$c-entryp v))
  ~ev[]

  We turn now to the proof obligations, as promised above.  There are three
  types: ~c[:CORRESPONDENCE], ~c[:PRESERVED], and ~c[:GUARD-THM].  All required
  lemmas may be printed simply by defining the necessary ~c[:LOGIC] and
  ~c[:EXEC] functions and then submitting the ~c[defabsstobj] event.
  (To advanced users: also ~pl[defabsstobj-missing-events] for a utility that
  returns the required formulas in translated form.)  Although the
  ~c[defabsstobj] event will fail if the required lemmas have not been proved,
  first it will print the ~ilc[defthm] forms that must be admitted in order to
  complete submission of the ~c[defabsstobj] event.

  The detailed theory explaining the need for these lemmas may be found in a
  comment in ACL2 source file ~c[other-events.lisp], in a comment entitled
  ``Essay on the Correctness of Abstract Stobjs''.  Here, we give an informal
  sense of the importance of these lemmas as we present examples of them.
  Fundamental is the notion of evaluation in the logic versus evaluation using
  live stobjs, where one imagines tracking the current value of each abstract
  stobj during each of these two evaluations.

  We start with the ~c[:CORRESPONDENCE] lemmas.  These guarantee that
  evaluation in the logic agrees with evaluation using live stobjs, in the
  sense that the only difference is between a logical stobj and a live stobj,
  where the two correspond in the sense of the function specified by
  ~c[:CORR-FN].  We start with the ~c[:CREATOR] function where the statement is
  quite simple, stating that the ~c[:CORR-FN] holds initially.
  ~bv[]
  (defthm create-st{correspondence}
    (st$corr (create-st$c) (create-st$a)))
  ~ev[]
  For the exported functions, there are essentially two cases.  If an exported
  function returns other than the new abstract stobj, then the theorem asserts
  the equality of the results of applying the ~c[:LOGIC] and ~c[:EXEC]
  functions for the exported function.  Hypotheses include the ~c[:CORR-FN]
  correspondence followed by the ~il[guard] for the ~c[:LOGIC] function, which
  is stated in terms of the formal parameters of the ~c[:EXEC] function except
  using the abstract stobj (here, ~c[st]) in place of the concrete stobj (here,
  ~c[st$c]).  The conclusion uses the ~c[:EXEC] formals, modified in the call
  of the ~c[:LOGIC] function (here, ~c[lookup$a]) to use the abstract stobj, as
  in the hypotheses.
  ~bv[]
  (defthm lookup{correspondence}
    (implies (and (st$corr st$c st)
                  (integerp i) (<= 0 i) (<= i 49)
                  (st$ap st))
             (equal (mem$ci i st$c)
                    (lookup$a i st)))
    :rule-classes nil)
  ~ev[]
  By contrast, if the exported function returns the new abstract stobj, then
  the conclusion uses the correspondence function insted of ~c[EQUAL], as in
  the following.
  ~bv[]
  (defthm update{correspondence}
    (implies (and (st$corr st$c st)
                  (integerp i) (<= 0 i) (<= i 49)
                  (integerp v) (<= 0 v)
                  (st$ap st)
                  (mem$c-entryp v))
             (st$corr (update-mem$ci i v st$c)
                      (update$a i v st)))
    :rule-classes nil)
  ~ev[]
  For exported functions that return multiple values, such conclusions are
  conjoined together over the returned values.

  The ~c[:PRESERVED] lemmas guarantee that updates to the abstract stobj
  preserve its recognizer.  The fact that every exported function has this
  property provides justification for an optimization performed by ACL2 during
  generation of proof obligations for ~il[guard] verification, by assuming that
  the recognizer always holds.  The ~c[:PRESERVED] lemma for the ~c[:CREATOR]
  shows that the recognizer holds initially.
  ~bv[]
  (defthm create-st{preserved}
    (st$ap (create-st$a)))
  ~ev[]
  Here is a typical such lemma, for the exported function ~c[update].  Note
  that there is no such lemma for ~c[lookup], since ~c[lookup] does not return
  ~c[st].
  ~bv[]
  (defthm update{preserved}
    (implies (and (integerp i) (<= 0 i) (<= i 49)
                  (integerp v) (<= 0 v)
                  (st$ap st)
                  (mem$c-entryp v))
             (st$ap (update$a i v st))))
  ~ev[]

  Finally, we consider the ~c[:GUARD-THM] lemmas.  These serve to guarantee
  that the ~il[guard] holds for each call of an ~c[:EXEC] function.  During
  guard verification, logical definitions are used; in particular, since each
  exported function is defined in the logic as the corresponding call of its
  ~c[:LOGIC] function, guard verification shows that each call of the
  ~c[:LOGIC] function for an exported function satisfies that function's guard.
  But why is this true for raw Lisp evaluation using live stobjs, where the
  ~c[:EXEC] function is called for an exported function?  The ~c[:GUARD-THM]
  lemmas provide the answer, as they state that if the ~c[:LOGIC] function's
  guard holds, then the ~c[:EXEC] function's guard holds.  Here is an example.
  Note that the hypotheses come from the correspondence of the concrete and
  abstract function as guaranteed by the ~c[:CORR] function, together with the
  guard of the ~c[:LOGIC] function; and the conclusion comes from the guard of
  the ~c[:EXEC] function.
  ~bv[]
  (defthm lookup{guard-thm}
    (implies (and (st$corr st$c c)
                  (integerp i)
                  (<= 0 i)
                  (<= i 49)
                  (st$ap st))
             (and (integerp i)
                  (<= 0 i)
                  (< i (mem$c-length st$c))))
    :rule-classes nil)
  ~ev[]

  We conclude this EXAMPLE section by showing a short form for the
  ~c[defabsstobj] form displayed above.
  ~bv[]
  (defabsstobj st
    :exports ((lookup :exec mem$ci)
              (update :exec update-mem$ci)
              misc update-misc))
  ~ev[]

  ~st[SUMMARY DOCUMENTATION]

  The General Form is as shown below, where the order of keywords is unimportant.
  Duplicate keywords are discouraged; while permitted, only the first
  (leftmost) occurrence of a given keyword is used.  Only the ~c[:exports]
  keyword is required.
  ~bv[]
  (defabsstobj st
    :concrete concrete
    :recognizer recognizer
    :creator creator
    :corr-fn corr-fn
    :congruent-to congruent-to
    :protect-default protect-default
    :exports (e1 ... ek)
    :doc doc)
  ~ev[]
  The keyword argument ~c[:EXPORTS] must be supplied, and missing or ~c[nil]
  keyword arguments have defaults as indicated below.  All arguments must
  satisfy the conditions below.

  Before we describe the arguments, we define a notion of a ``function spec''
  and its ``completion''.  A function spec is either a symbol or else a list of
  the form
  ~bv[]
  (fn ~c[:kwd1] val1 ... ~c[:kwdn] valn),
  ~ev[]
  that is, a symbol followed by a ~ilc[keyword-value-listp].  We view the case
  of a symbol, ~c[s], as the function spec ~c[(s)], with no keywords.  There
  must be no duplicate keywords.  In each case that we expect a function spec,
  the context provides a set of valid keywords for that function spec; it is an
  error to provide any other keyword in the function spec.  Each function spec
  is interpreted as its ``completion'', obtained by extending the function spec
  with a default value for each valid keyword as indicated below.  With that
  interpretation, the ``exported function'' of a function spec is its ~c[car],
  and that function symbol and each keyword value must be a guard-verified
  function symbol; and moreover, the ~c[:EXEC] function must not include the
  new abstract stobj name, ~c[st], among its formals.

  We are ready to describe the arguments of ~c[defabsstobj].
  ~bq[]
  ~c[St] is a symbol, which names the new abstract stobj.

  ~c[Concrete] is the name of an existing stobj that is not an abstract stobj,
  i.e., was introduced with ~ilc[defstobj] (not ~ilc[defabsstobj]).

  ~c[Recognizer] is a function spec (for the recognizer function).  The valid
  keywords are ~c[:LOGIC] and ~c[:EXEC].  The default for ~c[recognizer] is
  obtained by adding the suffix ~c[\"P\"] to ~c[name].  The default value for
  ~c[:LOGIC] is formed by adding the suffix ~c[\"$AP\"] to ~c[recognizer]; for
  ~c[:EXEC], by adding the suffix ~c[\"$CP\"].  The ~c[:EXEC] function must be
  the recognizer for the specified ~c[:CONCRETE] stobj.

  ~c[Creator] is a function spec (for the creator function).  The valid
  keywords are ~c[:LOGIC] and ~c[:EXEC].  The default for ~c[creator] is
  obtained by adding the prefix ~c[\"CREATE-\"] to ~c[name].  The default value
  for ~c[:LOGIC] is formed by adding the suffix ~c[\"$A\"] to ~c[creator]; for
  ~c[:EXEC], by adding the suffix ~c[\"$C\"].  The ~c[:CREATOR] function must
  be the creator for the specified ~c[:CONCRETE] stobj, as ACL2 checks that the
  ~c[:CREATOR] function takes no arguments and returns the ~c[:CONCRETE] stobj.

  ~c[Corr-fn] is a known function symbol that takes two arguments (for the
  correspondence theorems).  The default for ~c[corr-fn] is obtained by adding
  the suffix ~c[\"$CORR\"] to ~c[name].

  ~c[Congruent-to] should either be ~c[nil] (the default) or the name of an
  abstract stobj previously introduced (by ~ilc[defabsstobj]).  In the latter
  case, the current and previous abstract stobj should have the same concrete
  stobj (not merely congruent concrete stobjs), and their ~c[:EXPORTS] fields
  should have the same length and also correspond, as follows: the ith export
  of each should have the same ~c[:LOGIC] and ~c[:EXEC] symbols.  ~l[defstobj]
  for more about congruent stobjs.  Note that if two names are congruent, then
  they are either both ordinary stobjs or both abstract stobjs.

  ~c[Protect-default] should either be ~c[nil] (the default) or ~c[t].  It
  provides the value of keyword ~c[:PROTECT] for each member of ~c[exports]
  that does not explicitly specify ~c[:PROTECT].  See the discussion of
  ~c[exports] below.

  An important aspect of the ~c[congruent-to] parameter is that if it is not
  ~c[nil], then the checks for lemmas ~-[] ~c[{CORRESPONDENCE}],
  ~c[{GUARD-THM}], and ~c[{PRESERVED}] ~-[] are omitted.  Thus, the values of
  keyword ~c[:CORR-FN], and the values of keywords ~c[:CORRESPONDENCE],
  ~c[:GUARD-THM], and ~c[:PRESERVED] in each export (as we discuss next), are
  irrelevant; they are not inferred and they need not be supplied.

  The value of ~c[:EXPORTS] is a non-empty true list.  Each ~c[ei] is a
  function spec (for an exported function).  The valid keywords are ~c[:LOGIC],
  ~c[:EXEC], ~c[:CORRESPONDENCE], and ~c[:GUARD-THM], ~c[:PROTECT], and also
  ~c[:PRESERVED] if and only if the specified ~c[:EXEC] function returns the
  ~c[:CONCRETE] stobj.  The default values for all of these keywords except
  ~c[:PROTECT] are obtained by respectively adding the suffix ~c[\"$A\"]
  ~c[\"$C\"], ~c[\"{CORRESPONDENCE}\"], ~c[\"{GUARD-THM}\"], or
  ~c[\"{PRESERVED}\"].  For ~c[:PROTECT], the default is ~c[nil] unless the
  ~c[defabsstobj] event specifies ~c[:PROTECT-DEFAULT t].

  ~c[Doc], if non-~c[nil], is a ~il[documentation] string
  (~pl[doc-string]).~eq[]

  Not shown is the keyword, ~c[:MISSING]; the effect of ~c[:missing t] is to
  turn the call of ~c[defabsstobj] into a corresponding call of
  ~ilc[defabsstobj-missing-events].

  Note that a ~c[defabsstobj] event will fail if the required lemmas ~-[] that
  is, those for valid keywords ~c[:CORRESPONDENCE], ~c[:GUARD-THM], and
  ~c[:PRESERVED] ~-[] have not been proved, unless proofs are being skipped.
  The exemption when skipping proofs allows the supporting lemmas to be
  ~ilc[local] to ~il[books] and ~ilc[encapsulate] ~il[events].  If the ~ilc[ld]
  special ~ilc[ld-skip-proofsp] is ~c[t], then the missing ~il[events] are
  printed with a warning before the ~c[defabsstobj] event is admitted; but if
  ~c[ld-skip-proofsp] is the symbol ~c[INCLUDE-BOOK], then that warning is
  omitted.  (Also ~pl[skip-proofs] and ~pl[ld-skip-proofsp].)  If however
  proofs are not being skipped, then the ~c[defabsstobj] event will fail after
  printing the missing events.  Advanced users may wish to
  ~pl[defabsstobj-missing-events] for a utility that returns a data structure
  containing the missing lemmas.

  Let ~c[st] be an abstract stobj with corresponding concrete stobj ~c[st$c].
  let ~c[f] be an exported function for ~c[st] and let ~c[f$a] and ~c[f$c] be
  the corresponding ~c[:LOGIC] and ~c[:EXEC] functions, respectively.  The
  formals of ~c[f] are obtained by taking the formals of ~c[f$c] and replacing
  ~c[st$c] by ~c[st].  The ~il[guard] for ~c[f] is derived as follows from the
  guard of ~c[f$a].  First, the formals of ~c[f$a] are replaced by the formals
  of ~c[f] in the guard of ~c[f$a], to obtain a term we denote here as
  ~c[guard-pre].  Now for each exported function symbol ~c[g] of ~c[st] with
  corresponding ~c[:LOGIC] function ~c[g$a], form a functional substitution by
  consing ~c[g$a] with ~c[g].  Finally, apply that functional substitution to
  ~c[guard-pre]; the result is the guard of ~c[f].  That guard must satisfy the
  usual conditions of a guard: thus, it must return a single non-~il[stobj]
  value and satisfy normal syntactic restrictions, including
  single-threadedness in its handling of stobjs.

  ~c[Remark].  Because of how guards are created for exported functions, and in
  particular because ~c[:LOGIC] functions are replaced as discussed above, a
  good discipline is to define ~c[:LOGIC] functions that are not intended for
  general use, but are intended only for use as ~c[:LOGIC] functions of
  corresponding stobj primitives.  For example, suppose that you use ~c[length]
  as the ~c[:LOGIC] function for some stobj primitive, ~c[f] (as opposed to
  using your own function, say, ~c[foo-length] or ~c[foo$a]).  Then every call
  of ~c[length] will be replaced by ~c[f] when creating the guard of a stobj
  primitive from the guard of its ~c[:LOGIC] function.  This might not be what
  you intended if you were using ~c[length] in that guard simply to compute the
  length of an ordinary list.

  There are a few additional restrictions, as follows.

  ~bq[]
  All exported function names must be new (unless redefinition is on;
  ~pl[ld-redefinition-action]), and there must be no duplicates among them.

  The ~c[:CONCRETE] stobj name must be a formal parameter of the ~c[:EXEC] fn
  of every function spec, except for the ~c[:CREATOR] function spec.  Also the
  input signatures of the ~c[:LOGIC] and ~c[:EXEC] function for a function spec
  must agree, except perhaps at the position of that ~c[:CONCRETE] formal.

  For function specs other than the ~c[:CREATOR] function spec, the output
  signatures of the ~c[:LOGIC] and ~c[:EXEC] functions must have the same
  length and must agree, except perhaps at position ~c[p_out] of the
  ~c[:CONCRETE] stobj in the ~c[:EXEC] function's output.  If ~c[p_in] is the
  position of the ~c[:CONCRETE] stobj in the ~c[:EXEC] function's formals, then
  the ~c[:LOGIC] function's output at position ~c[p_out] should match the
  ~c[:LOGIC] function's formal at position ~c[p_in].

  The ~c[:PROTECT] keyword is something that you should ignore unless you get
  an error message about it, pertaining to modifying the concrete stobj
  non-atomically.  In that case, you can eliminate the error by providing
  ~c[:PROTECT t] in the function spec, or by providing ~c[defabsstobj] keyword
  argument ~c[:PROTECT-DEFAULT t] at the top level.  The above explanation is
  probably all you need to know about ~c[:PROTECT], but just below is a more
  complete explanation for those who desire it.  Further information is also
  available if you need it; ~pl[set-absstobj-debug], and see the example uses
  of these keywords in community book
  ~c[books/misc/defabsstobj-example-2.lisp].~eq[]

  For those who are interested, here is a more detailed discussion of
  ~c[:PROTECT] and ~c[:PROTECT-DEFAULT], as promised above.  It applies to any
  function spec for an export (hence not to the ~c[:CREATOR] function spec).
  If the ~c[:EXEC] function is a stobj primitive, then clearly the following
  property holds: any execution of a call of that function can only update the
  concrete stobj at most once ~-[] i.e., modification of the concrete stobj is
  atomic.  ACL2 can deduce this property not only for stobj primitives but for
  many other functions as well.  However, if ACL2 cannot deduce this property,
  then it will cause an error saying that the ~c[:EXEC] function ``appears
  capable of modifying the concrete stobj, ~c[<stobj_name>], non-atomically.''
  That message also explains how to eliminate this error: provide
  ~c[:PROTECT t] for the function spec.  Alternatively, all function specs
  without an explicit ~c[:PROTECT] keyword can be implicitly supplied
  ~c[:PROTECT t] by supplying the value ~c[t] for the ~c[:PROTECT-DEFAULT]
  keyword parameter of the ~c[defabsstobj] event.  However, beware that when
  ~c[:PROTECT] is ~c[t], the generated raw Lisp code runs slightly less
  efficiently ~-[] though perhaps with negligible efficiency loss if the
  ~c[:EXEC] function is not trivial.  Community books
  ~c[books/misc/defabsstobj-example-3.lisp] and
  ~c[books/misc/defabsstobj-example-4.lisp] provide related information.

  We conclude with some remarks.

  Unlike ~ilc[defstobj], there is no ~c[:renaming] argument.  Instead, the
  scheme described above provides a flexible way to assign names.

  Those who use the experimental extension ACL2(h), which includes function
  memoization (~pl[memoize]), may be aware that the memo table for a function
  is flushed whenever it is the case that one of its stobj inputs is updated.
  In fact, such flushing happens even when a stobj that is congruent to one of
  its stobj inputs is updated.  For that purpose, an abstract stobj is
  considered to be congruent to its corresponding concrete stobj.
  ~/"

  (declare (xargs :guard (and (symbolp name)
                              (booleanp protect-default))))
  (list 'defabsstobj-fn
        (list 'quote name)
        (list 'quote concrete)
        (list 'quote recognizer)
        (list 'quote creator)
        (list 'quote corr-fn)
        (list 'quote exports)
        (list 'quote protect-default)
        (list 'quote congruent-to)
        (list 'quote missing-only)
        (list 'quote doc)
        'state
        (list 'quote event-form)))

(defun concrete-stobj (st wrld)
  (let ((absstobj-info
         (getprop st 'absstobj-info nil 'current-acl2-world wrld)))
    (and absstobj-info
         (access absstobj-info
                 (getprop st 'absstobj-info nil 'current-acl2-world wrld)
                 :st$c))))

(defmacro defabsstobj-missing-events (&whole event-form
                                             name
                                             &key
                                             concrete recognizer creator
                                             corr-fn exports protect-default
                                             congruent-to doc)

  ":Doc-Section Events

  obtain the ~il[events] needed to admit a ~ilc[defabsstobj] event~/

  We assume familiarity with ~ilc[defabsstobj].  ~c[Defabsstobj-missing-events]
  is a macro is for advanced users (who, for example, understand the role of
  the ~c[translate] and ~c[untranslate] functions), who want programmatic
  access to the ~ilc[defthm] events required to admit a specific
  ~c[defabsstobj] event.~/

  This macro has the same syntax as ~ilc[defabsstobj] ~-[] to use it, just
  replace a call of ~ilc[defabsstobj] by a call of
  ~c[defabsstobj-missing-events] on the same arguments.  The result is an error
  triple ~c[(mv erp val state)].  If ~c[erp] is ~c[nil], then ~c[val] is the
  list of all objects ~c[(name formula . old-formula)], where a ~ilc[defthm]
  event named ~c[name] remains to be admitted whose translated formula is
  ~c[formula], and where ~c[old-formula] is ~c[nil] unless the indicated event
  already exists (hence with a different formula), in which case
  ~c[old-formula] is the existing translated formula.

  To build a ~ilc[defthm] event from the above value, ~c[val], we suggest
  evaluating a form like ~c[(untranslate formula t (w state))].~/"

  (declare (xargs :guard (symbolp name)))
  (list 'defabsstobj-fn1
        (list 'quote name)
        (list 'quote concrete)
        (list 'quote recognizer)
        (list 'quote creator)
        (list 'quote corr-fn)
        (list 'quote exports)
        (list 'quote protect-default)
        (list 'quote congruent-to)
        (list 'quote t) ; missing-only
        (list 'quote doc)
        (list 'quote (msg "( DEFABSSTOBJ-MISSING-EVENTS ~x0 ...)" name)) ; ctx
        'state
        (list 'quote event-form)))

(defun redundant-defabsstobjp (name event-form wrld)
  (and (getprop name 'stobj nil 'current-acl2-world 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 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 concrete 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 concrete 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 abstract and concrete 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 concrete 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-out logic exec
   correspondence preserved
   protect)
  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 (getprop fn 'stobj-function nil 'current-acl2-world wrld))
     :once)
    ((getprop fn 'recursivep nil 'current-acl2-world wrld)

; We can't predict how many updates fn will make to st.

     t)
    ((getprop fn 'constrainedp nil 'current-acl2-world wrld)

; Fn might be attachable, so we can't predict how many updates fn will make to
; st.

     t)
    (t (let ((body (getprop fn 'unnormalized-body nil 'current-acl2-world
                            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 !>(getprop 'foo 'unnormalized-body nil 'current-acl2-world (w state))
;   ((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 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)
  (and (member-eq st$c (stobjs-out name wrld))
       (eq t (fn-stobj-updates-p st$c name wrld))))

(defun translate-absstobj-field (st 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.

  (let* ((field0 field)
         (field (if (atom field) (list field) field))
         (name (car field))
         (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 name
                               :LOGIC logic
                               :EXEC exec
                               :PROTECT protect)))
             ((strip-keyword-list
               '(:LOGIC :EXEC :CORRESPONDENCE :PRESERVED :GUARD-THM :PROTECT)
               keyword-lst)
              (er-cmp ctx
                      "Unexpected keyword~#0~[~/s~], ~&0, in field ~x1.  ~@2"
                      (evens (strip-keyword-list
                              '(:LOGIC :EXEC :CORRESPONDENCE :PRESERVED :GUARD-THM)
                              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)))
                   (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 ~
                    concrete 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))
                      (posn-exec-out (position-eq st$c stobjs-out-exec))
                      (correspondence-required (not (eq type :RECOGNIZER)))
                      (preserved-required (and (not (eq type :RECOGNIZER))
                                               (member-eq st$c stobjs-out-exec))))
                 (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
                                  (not logic-p) (not exec-p)))
                         (and (eq type :CREATOR)
                              guard-thm-p))
                     (er-cmp ctx
                             "The keyword ~x0 for the ~@1.  ~@2"
                             type
                             (cond (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"))
                             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 concrete 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 :CONCRETE 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 concrete 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 st exec-formals)

; We form the formals of 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"
                             st exec field0 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 :CONCRETE 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
                           (and (equal (length stobjs-in-logic)
                                       (length stobjs-in-exec))
                                (equal (update-nth posn-exec nil stobjs-in-logic)
                                       (update-nth posn-exec nil stobjs-in-exec)))))
                     (er-cmp ctx
                             "The input signatures of the :LOGIC and :EXEC ~
                            functions for a field must agree except perhaps ~
                            at the position of the concrete stobj (~x0) in ~
                            the :EXEC function (which is zero-based position ~
                            ~x1).  However, this agreement fails for field ~
                            ~x2, as the input signatures are as ~
                            follows.~|~%~x3 (:LOGIC):~|~X47~|~%~x5 ~
                            (:EXEC):~|~X67~|~%~@8"
                             st$c posn-exec 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 (and (equal (length stobjs-out-logic)
                                           (length stobjs-out-exec))
                                    (equal stobjs-out-exec
                                           (if posn-exec-out
                                               (update-nth posn-exec-out
                                                           (assert$
                                                            posn-exec
                                                            (nth posn-exec
                                                                 stobjs-in-exec))
                                                           stobjs-out-logic)
                                             stobjs-out-logic)))))
                     (er-cmp ctx
                             "The output signatures of the :LOGIC and :EXEC ~
                            functions for a field must have the same length ~
                            and must agree at each position, except for the ~
                            position of concrete stobj (~x0) in the outputs ~
                            of the :EXEC function.  For that position, the ~
                            :LOGIC function should return the type of the ~
                            object (stobj or not) that is at the position of ~
                            ~x0 in the inputs of the :EXEC function.  ~
                            However, the criteria above are not all met for ~
                            field ~x1, as the output signatures are as ~
                            follows.~|~%~x2 (:LOGIC):~|~X36~|~%~x4 ~
                            (:EXEC):~|~X56~|~%~@7"
                             st$c field0
                             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 st exec-formals)))
                            (guard-pre (subcor-var (formals logic wrld)
                                                   formals
                                                   (guard logic nil wrld))))
                       (value-cmp
                        (make absstobj-method
                              :NAME 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 wrld)
                              :STOBJS-OUT
                              (substitute st st$c stobjs-out-exec)
                              :LOGIC logic
                              :EXEC exec
                              :CORRESPONDENCE correspondence
                              :PRESERVED preserved
                              :PROTECT protect))))))))))))))))))))

(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 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-iff-equiv-terms (x y)

; Warning: It would be best to keep this 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 weak version of Boolean equivalence of x and y, for use in
; chk-defabsstobj-method-lemmas or other places where we expect this to be
; sufficient.  For example, in the lambda case we could weaken the requirement
; that the args are equal by beta-reducing x and y, but that would be less
; efficient so we don't bother.

  (or (equal x y) ; common case
      (cond ((or (variablep x)
                 (fquotep x)
                 (variablep y)
                 (fquotep y))
             nil)
            ((flambda-applicationp x)
             (and (flambda-applicationp y)
                  (equal (lambda-formals x) (lambda-formals y))
                  (obviously-iff-equiv-terms (lambda-body x) (lambda-body y))
                  (equal (fargs x) (fargs y))))
            ((not (eq (ffn-symb x) (ffn-symb y)))
             nil)
            ((member-eq (ffn-symb x) '(implies iff))
             (and (obviously-iff-equiv-terms (fargn x 1) (fargn y 1))
                  (obviously-iff-equiv-terms (fargn x 2) (fargn y 2))))
            ((eq (ffn-symb x) 'not)
             (obviously-iff-equiv-terms (fargn x 1) (fargn y 1)))
            ((eq (ffn-symb x) 'if)
             (and (obviously-iff-equiv-terms (fargn x 1) (fargn y 1))
                  (obviously-iff-equiv-terms (fargn x 3) (fargn y 3))
                  (or (obviously-iff-equiv-terms (fargn x 2) (fargn y 2))

; Handle case that a term is of the form (or u v).

                      (cond ((equal (fargn x 2) *t*)
                             (equal (fargn y 2) (fargn y 1)))
                            ((equal (fargn y 2) *t*)
                             (equal (fargn x 2) (fargn x 1)))
                            (t nil)))))
            (t nil))))

(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 '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 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.  Note that fields begins with the
; recognizer and then the creator; 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 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 chk-acceptable-defabsstobj (name st$c recognizer st$ap creator corr-fn
                                        exports protect-default congruent-to doc
                                        see-doc ctx wrld state event-form)

; We return an error triple such that when there is no error, the value
; component is either 'redundant or 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))
   ((redundant-defabsstobjp name event-form wrld)
    (value 'redundant))
   ((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))
   ((getprop st$c 'absstobj-info nil 'current-acl2-world 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 :CONCRETE argument of ~
         DEFABSSTOBJ.  ~@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)
                   (getprop congruent-to 'absstobj-info nil 'current-acl2-world
                            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))
   (t
    (er-progn
     (chk-all-but-new-name name ctx 'stobj wrld state)
     (chk-legal-defstobj-name name state)

; We use translate-doc here just to check the string.  We throw away
; the section-symbol and citations returned.  We'll repeat this later.

     (translate-doc name doc ctx state)
     (er-let* ((wrld1 (chk-just-new-name name 'stobj nil ctx wrld state))
               (wrld2 (chk-just-new-name (the-live-var name) '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 (st$c methods)
  (cond
   ((endp methods) nil)
   (t (cons (let ((method (car methods)))
              (mv-let (name formals guard-post logic stobjs)
                      (mv (access absstobj-method method :NAME)
                          (access absstobj-method method :FORMALS)
                          (access absstobj-method method :GUARD-POST)
                          (access absstobj-method method :LOGIC)
                          (remove1 st$c (collect-non-x
                                         nil
                                         (access absstobj-method method
                                                 :STOBJS-IN-EXEC))))
                      `(,name ,formals
                              (declare (xargs ,@(and stobjs
                                                     `(:STOBJS ,stobjs))
                                              :GUARD ,guard-post))
                              (,logic ,@formals))))
            (defabsstobj-axiomatic-defs st$c (cdr methods))))))

(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))
         (body
          (cond
           ((null protect)
            `(cons ',exec args))
           (t ``(let* ((temp *inside-absstobj-update*)
                       (saved (svref temp 0)))
                  (declare (type simple-array temp))
                  (cond
                   ((eql saved 0)
                    (setf (svref temp 0) 1)
                    (our-multiple-value-prog1
                     ,(cons ',exec args)
                     (setf (svref temp 0) 0)))
                   ((typep saved 'fixnum)
                    (setf (svref temp 0)
                          (1+ (the fixnum saved)))
                    (our-multiple-value-prog1
                     ,(cons ',exec args)
                     (decf (the fixnum (svref temp 0)))))
                   (t

; If saved_var 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 saved_var 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.

                    (let ((sym ',',name))
                      (declare (type symbol sym))
                      (cond
                       ((eq nil saved)
                        (setf (svref temp 0) (the symbol sym))
                        (our-multiple-value-prog1
                         ,(cons ',exec args)
                         (setf (svref temp 0) nil)))
                       (t
                        (push (the symbol sym) saved)
                        (our-multiple-value-prog1
                         ,(cons ',exec args)
                         (pop (svref temp 0)))))))))))))
    `(,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)
  (cond ((null recognizer)
         (value (list (absstobj-name st-name :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)

; Note that the original :guard-pre term is the guard of a guard-verified
; function; hence its guard proof obligations are provable.   The guard proof
; obligations for the new :guard-post (created below using sublis-fn-simple) by
; replacing some functions with equal functions, and hence are also provable.
; Thus, the guard of the guard of an exported function, which comes from the
; :guard-post field of the corresponding method, has provable guard proof
; obligations, as we would expect for guard-of-the-guard, which is important
; for avoiding guard violations while checking the guard for a function call.

  (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)

; Warning: Keep this call of translate in sync with the call of
; translate-term-lst in chk-acceptable-defuns1.

  (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-logic-exec-pairs (methods)
  (cond ((endp methods) nil)
        (t (cons (cons (access absstobj-method (car methods) :logic)
                       (access absstobj-method (car methods) :exec))
                 (make-absstobj-logic-exec-pairs (cdr methods))))))

(defun defabsstobj-fn1 (st-name st$c recognizer creator corr-fn exports
                                protect-default congruent-to missing-only doc
                                ctx state event-form)
  (let* ((wrld0 (w state))
         (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))))
    (er-let* ((recognizer (expand-recognizer st-name recognizer see-doc ctx
                                             state))
              (st$ap (value (cadr (assoc-keyword :logic (cdr recognizer)))))
              (missing/methods/wrld1
               (chk-acceptable-defabsstobj
                st-name st$c recognizer st$ap creator corr-fn exports
                protect-default congruent-to doc see-doc ctx wrld0 state
                                event-form)))
      (cond
       ((eq missing/methods/wrld1 'redundant)
        (stop-redundant-event ctx state))
       ((and missing-only
             (not congruent-to)) ; else do check before returning missing
        (value (car missing/methods/wrld1)))
       (t
        (let* ((missing (car missing/methods/wrld1))
               (methods0 (cadr missing/methods/wrld1))
               (old-absstobj-info

; Note that if old-absstobj-info 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
                     (getprop congruent-to 'absstobj-info nil
                              'current-acl2-world wrld0)))
               (logic-exec-pairs (make-absstobj-logic-exec-pairs methods0)))
          (cond
           ((and congruent-to
                 (not (equal st$c
                             (access absstobj-info old-absstobj-info
                                     :st$c))))
            (er soft ctx
                "The value provided for :congruent-to, ~x0, is illegal, ~
                 because the concrete stobj associated with ~x0 is ~x1, while ~
                 the concrete stobj proposed for ~x2 is ~x3.  ~@4"
                congruent-to
                (access absstobj-info old-absstobj-info :st$c)
                st-name
                st$c
                see-doc))
           ((and congruent-to
                 (not (equal logic-exec-pairs
                             (access absstobj-info old-absstobj-info
                                     :logic-exec-pairs))))
            (er soft ctx
                "The value provided for :congruent-to, ~x0, is illegal.  ACL2 ~
                 requires that the :LOGIC and :EXEC 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 pairs (:LOGIC . :EXEC) for ~
                 each.~|~%For ~x1 (proposed):~|~Y24~%For ~x0:~|~Y34~%~|~@5"
                congruent-to
                st-name
                logic-exec-pairs
                (access absstobj-info old-absstobj-info
                        :logic-exec-pairs)
                nil
                see-doc))
           (missing-only
            (value missing))
           (t
            (er-progn
             (cond
              ((or (null missing)
                   (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.  ~@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 st$c 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)))
                (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 names) ; ee-entry
                     (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
                     ctx state)

; The processing above will install defun events but defers installation of raw
; Lisp definitions, just as for defstobj.

                    (er-let* ((doc-pair (translate-doc st-name doc ctx state)))
                      (let* ((wrld2 (w state))
                             (wrld3
                              (update-doc-database
                               st-name doc doc-pair
                               (putprop
                                st-name 'congruent-stobj-rep
                                (and congruent-to
                                     (congruent-stobj-rep congruent-to wrld2))
                                (putprop
                                 st-name 'absstobj-info
                                 (make absstobj-info
                                       :st$c st$c
                                       :logic-exec-pairs logic-exec-pairs)
                                 (putprop
                                  st-name 'symbol-class
                                  :common-lisp-compliant
                                  (put-absstobjs-in-and-outs
                                   st-name methods
                                   (putprop
                                    st-name 'stobj
                                    (cons the-live-var

; Names is in the right order; it does not need adjustment as is the case for
; corresponding code in defstobj-fn.  See the comment about
; chk-acceptable-defabsstobj1 in chk-acceptable-defabsstobj.

                                          names)
                                    (putprop-x-lst1
                                     names 'stobj-function st-name
                                     (putprop
                                      the-live-var 'stobj-live-var st-name
                                      (putprop
                                       the-live-var 'symbol-class
                                       :common-lisp-compliant
                                       wrld2)))))))))))
                        (pprogn
                         (set-w 'extension wrld3 state)
                         (er-progn
                          (chk-defabsstobj-guards methods congruent-to ctx
                                                  wrld3 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".

                          (install-event st-name
                                         event-form
                                         'defstobj
                                         (list* st-name
                                                the-live-var
                                                names) ; namex
                                         nil
                                         `(defabsstobj ,st-name
                                            ,the-live-var
                                            ,(defabsstobj-raw-init creator-name
                                               methods)
                                            ,raw-def-lst
                                            ,event-form
                                            ,ax-def-lst)
                                         t
                                         ctx
                                         wrld3
                                         state))))))))))))))))))))

(defun defabsstobj-fn (st-name st$c recognizer creator corr-fn exports
                               protect-default congruent-to missing-only doc
                               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
   (if (output-in-infixp state)
       event-form
     (msg "( DEFABSSTOBJ ~x0 ...)" st-name))
   (defabsstobj-fn1 st-name st$c recognizer creator corr-fn exports
     protect-default congruent-to missing-only doc ctx state event-form)))

(deflabel stobj
  :doc
  ":Doc-Section stobj

  single-threaded objects or ``von Neumann bottlenecks''~/

  In ACL2, a ``single-threaded object'' is a data structure whose use is so
  syntactically restricted that only one instance of the object need ever exist
  and its fields can be updated by destructive assignments.

  Note: Novices are advised to avoid using single-threaded objects, perhaps
  instead using community book ~c[books/data-structures/structures.lisp].  At
  the least, consider using ~c[(]~ilc[set-verify-guards-eagerness]~c[ 0)] to
  avoid ~il[guard] verification.

  The documentation in this section is laid out in the form of a tour that
  visits the documented topics in a reasonable order.  We recommend that you
  follow the tour the first time you read about stobjs.  The list of all stobj
  topics is shown below.  The tour starts immediately afterwards.  Also
  ~pl[defstobj] and, for so-called abstract stobjs, ~pl[defabsstobj].~/

  As noted, a ``single-threaded object'' is a data structure whose use is so
  syntactically restricted that only one instance of the object need ever
  exist.  Updates to the object must be sequentialized.  This allows us to
  update its fields with destructive assignments without wrecking the axiomatic
  semantics of update-by-copy.  For this reason, single-threaded objects are
  sometimes called ``von Neumann bottlenecks.''

  From the logical perspective, a single-threaded object is an ordinary ACL2
  object, e.g., composed of integers and conses.  Logically speaking, ordinary
  ACL2 functions are defined to allow the user to ``access'' and ``update'' its
  fields.  Logically speaking, when fields in the object, obj, are ``updated''
  with new values, a new object, obj', is constructed.

  But suppose that by syntactic means we could ensure that there were no more
  references to the ``old'' object, obj.  Then we could create obj' by
  destructively modifying the memory locations involved in the representation
  of obj.  The syntactic means is pretty simple but draconian: the only
  reference to obj is in the variable named ~c[OBJ].

  The consequences of this simple rule are far-reaching and require some
  getting used to.  For example, if ~c[OBJ] has been declared as a
  single-threaded object name, then the following consequences ensue (but see
  the discussion of congruent stobjs below for a slight relaxation).

  o ~c[OBJ] is a top-level global variable that contains the current object,
  obj.

  o If a function uses the formal parameter ~c[OBJ], the only ``actual
  expression'' that can be passed into that slot is the variable ~c[OBJ], not
  merely a term that ``evaluates to an obj''; thus, such functions can only
  operate on the current object.  So for example, instead of
  ~c[(FOO (UPDATE-FIELD1 3 ST))] write
  ~c[(LET ((ST (UPDATE-FIELD1 3 ST))) (FOO ST))].

  o The accessors and updaters have a formal parameter named ~c[OBJ], so by the
  rule just above, those functions can only be applied to the current object.
  The recognizer is the one exception to the rule: it may be applied either the
  ~c[OBJ] or to an ordinary (non-stobj) object.

  o The ACL2 primitives, such as ~c[CONS], ~c[CAR] and ~c[CDR], may not be
  applied to the variable ~c[OBJ].  Thus, for example, obj may not be consed
  into a list (which would create another pointer to it) or accessed or copied
  via ``unapproved'' means.

  o The updaters return a ``new ~c[OBJ] object'', i.e., obj'; thus, when an
  updater is called, the only variable which can hold its result is ~c[OBJ].

  o If a function calls an ~c[OBJ] updater, it must return an ~c[OBJ] object
  (either as the sole value returned, or in ~c[(mv ... OBJ ...)]; ~pl[mv]).

  o When a top-level expression involving ~c[OBJ] returns an ~c[OBJ] object,
  that object becomes the new current value of ~c[OBJ].

  There are other functional languages supporting single-threadedness, for
  example Haskell's ``monads'' and Clean's ``uniqueness type system''.  Of
  course, ACL2 provides a theorem prover that can prove theorems that involve
  such constructs.

  Note that the syntactic restrictions noted above are enforced only when
  single-threaded objects are encountered directly in the top-level loop or are
  used in function definitions; the accessor and update functions for
  single-threaded objects may be used without restriction in formulas to be
  proved.  Since function evaluation is sometimes necessary during proofs, ACL2
  must be able to evaluate these functions on logical constants representing
  the object, even when the constant is not ``the current object.''  Thus, ACL2
  supports both the efficient von Neumann semantics and the clean applicative
  semantics, and uses the first in contexts where execution speed is paramount
  and the second during proofs.

  ~ilc[Defstobj] and ~ilc[defabsstobj] ~il[events] introduce stobjs.
  ~l[defstobj] for more details about stobjs.  In particular, a relatively
  advanced notion of ``congruent stobjs'' is discussed there.  The idea is to
  allow a stobj, ~c[st2], of the same ``shape'' as a given stobj, ~c[st1], to
  be used in place of ~c[st1].  Other ~ilc[defstobj] keywords allow inlining
  and renaming of stobj accessors and updaters.

  But we are getting ahead of ourselves.  To start the stobj tour,
  ~pl[stobj-example-1].~/

  :cite defstobj
  :cite defabsstobj")

(deflabel stobj-example-1
  :doc
  ":Doc-Section stobj

  an example of the use of single-threaded objects~/

  Suppose we want to sweep a tree and (1) count the number of interior
  nodes, (2) count the number of tips and (3) keep a record of every
  tip we encounter that is an integer.  We could use a single-threaded
  object as our ``accumulator''.  Such an object would have three
  fields, one holding the number of nodes seen so far, one holding the
  number of tips, and one holding all the integer tips seen.~/

  The following event declares ~c[counters] to be a single-threaded object.
  ~bv[]
  (defstobj counters
    (NodeCnt     :type integer :initially 0)
    (TipCnt      :type integer :initially 0)
    (IntTipsSeen :type t       :initially nil))
  ~ev[]
  It has three fields, ~c[NodeCnt], ~c[TipCnt], and ~c[IntTipsSeen].
  (As always in ACL2, capitalization is irrelevant in simple symbol
  names, so the first name could be written ~c[nodecnt] or
  ~c[NODECNT], etc.) Those are the name of the accessor functions for
  the object.  The corresponding update functions are named
  ~c[update-NodeCnt], ~c[update-TipCnt] and ~c[update-IntTipsSeen].

  If you do not like the default function names chosen above, there is
  a feature in the ~ilc[defstobj] event that allows you to specify other
  names.

  If you want to see the ACL2 definitions of all the functions defined
  by this event, look at ~il[stobj-example-1-defuns].

  If, after this event, we evaluate the top-level ``global variable''
  ~c[counters] in the ACL2 read-eval-print loop we get:
  ~bv[]
  ACL2 !>counters
  <counters>
  ~ev[]
  Note that the value printed is ``~c[<counters>]''.  Actually, the
  value of ~c[counters] in the logic is ~c[(0 0 NIL)].  But ACL2 always prints
  single-threaded objects in this non-informative way because they are
  usually so big that to do otherwise would be unpleasant.

  Had you tried to evaluate the ``global variable'' ~c[counters] before
  declaring it a single-threaded object, ACL2 would have complained that
  it does not support global variables.  So a lesson here is that
  once you have declared a new single-threaded object your top-level
  forms can reference it.  In versions of ACL2 prior to Version  2.4
  the only variable enjoying this status was ~c[STATE].  single-threaded
  objects are a straightforward generalization of the long-implemented
  von Neumann ~ilc[state] feature of ACL2.

  We can access the fields of ~c[counters] as with:
  ~bv[]
  ACL2 !>(NodeCnt counters)
  0
  ACL2 !>(IntTipsSeen counters)
  NIL
  ~ev[]
  and we can set the fields of ~c[counters] as with:
  ~bv[]
  ACL2 !>(update-NodeCnt 3 counters)
  <counters>
  ACL2 !>(NodeCnt counters)
  3
  ~ev[]
  Observe that when we evaluate an expression that returns a
  counter object, that object becomes the ``current value'' of
  ~c[counters].

  Here is a function that ``converts'' the ~c[counters] object to its
  ``ordinary'' representation:
  ~bv[]
  (defun show-counters (counters)
    (declare (xargs :stobjs (counters)))
    (list (NodeCnt counters)
          (TipCnt counters)
          (IntTipsSeen counters)))
  ~ev[]
  Observe that we ~em[must] declare, at the top of the ~c[defun], that
  we mean to use the formal parameter ~c[counters] as a single-threaded
  object!  If we did not make this declaration, the body of
  ~c[show-counters] would be processed as though ~c[counters] were an
  ordinary object.  An error would be caused because the accessors
  used above cannot be applied to anything but the single-threaded
  object ~c[counters].  If you want to know why we insist on this
  declaration, ~pl[declare-stobjs].

  When ~c[show-counters] is admitted, the following message is printed:
  ~bv[]
  Since SHOW-COUNTERS is non-recursive, its admission is trivial.  We
  observe that the type of SHOW-COUNTERS is described by the theorem
  (AND (CONSP (SHOW-COUNTERS COUNTERS))
       (TRUE-LISTP (SHOW-COUNTERS COUNTERS))).
  We used primitive type reasoning.

  (SHOW-COUNTERS COUNTERS) => *.

  The guard conjecture for SHOW-COUNTERS is trivial to prove.
  SHOW-COUNTERS is compliant with Common Lisp.
  ~ev[]
  The line above containing the ``=>'' is called the ``signature'' of
  ~c[show-counters]; it conveys the information that the first argument
  is the single-threaded object ~c[counters] and the only result is an
  ordinary object.  Here is an example of another signature:
  ~bv[]
  (PROCESSOR * * COUNTERS) => (MV * COUNTERS)
  ~ev[]
  which indicates that the function ~c[PROCESSOR] (which we haven't
  shown you) takes three arguments, the third of which is the
  ~c[COUNTERS] stobj, and returns two results, the second of which
  is the modified ~c[COUNTERS].

  Returning to the admission of ~c[show-counters] above, the last
  sentence printed indicates that the ~ilc[guard] conjectures for the
  function were proved.  When some argument of a function is declared
  to be a single-threaded object via the ~c[xargs] ~c[:stobj], we
  automatically add (conjoin) to the guard the condition that the
  argument satisfy the recognizer for that single-threaded object.  In
  the case of ~c[show-counters] the guard is ~c[(countersp counters)].

  Here is an example of ~c[show-counters] being called:
  ~bv[]
  ACL2 !>(show-counters counters)
  (3 0 NIL)
  ~ev[]
  This is what we would see had we set the ~c[NodeCnt] field of the
  initial value of ~c[counters] to ~c[3], as we did earlier in this
  example.

  We next wish to define a function to reset the ~c[counters] object.
  We could define it this way:
  ~bv[]
  (defun reset-counters (counters)
    (declare (xargs :stobjs (counters)))
    (let ((counters (update-NodeCnt 0 counters)))
      (let ((counters (update-TipCnt 0 counters)))
        (update-IntTipsSeen nil counters))))
  ~ev[]
  which ``successively'' sets the ~c[NodeCnt] field to ~c[0], then the
  ~c[TipCnt] field to ~c[0], and then the ~c[IntTipsSeen] field to ~c[nil] and
  returns the resulting object.

  However, the nest of ~c[let] expressions is tedious and we use this
  definition instead.  This definition exploits a macro, here named
  ``~c[seq]'' (for ``sequentially'') which evaluates each of the forms
  given, binding their results successively to the stobj name given.
  ~bv[]
  (defun reset-counters (counters)
    (declare (xargs :stobjs (counters)))
    (seq counters
         (update-NodeCnt 0 counters)
         (update-TipCnt 0 counters)
         (update-IntTipsSeen nil counters)))
  ~ev[]
  This definition is syntactically identical to the one above, after macro
  expansion.  Our definition of ~c[seq] is shown below and is not part of
  native ACL2.
  ~bv[]
  (defmacro seq (stobj &rest rst)
    (cond ((endp rst) stobj)
          ((endp (cdr rst)) (car rst))
          (t `(let ((,stobj ,(car rst)))
               (seq ,stobj ,@(cdr rst))))))
  ~ev[]

  The signature printed for ~c[reset-counters] is
  ~bv[]
  (RESET-COUNTERS COUNTERS) => COUNTERS.
  ~ev[]

  Here is an example.
  ~bv[]
  ACL2 !>(show-counters counters)
  (3 0 NIL)
  ACL2 !>(reset-counters counters)
  <counters>
  ACL2 !>(show-counters counters)
  (0 0 NIL)
  ~ev[]

  Here finally is a function that uses ~c[counters] as a single-threaded
  accumulator to collect the desired information about the tree ~c[x].
  ~bv[]
  (defun sweep-tree (x counters)
    (declare (xargs :stobjs (counters)))
    (cond ((atom x)
           (seq counters
                (update-TipCnt (+ 1 (TipCnt counters)) counters)
                (if (integerp x)
                    (update-IntTipsSeen (cons x (IntTipsSeen counters))
                                    counters)
                  counters)))
          (t (seq counters
                  (update-NodeCnt (+ 1 (NodeCnt counters)) counters)
                  (sweep-tree (car x) counters)
                  (sweep-tree (cdr x) counters)))))
  ~ev[]
  We can paraphrase this definition as follows.  If ~c[x] is an atom,
  then increment the ~c[TipCnt] field of ~c[counters] and ~em[then],
  if ~c[x] is an integer, add ~c[x] to the ~c[IntTipsSeen] field, and
  return ~c[counters].  On the other hand, if ~c[x] is not
  an atom, then increment the ~c[NodeCnt] field of ~c[counters], and
  ~em[then] sweep the ~c[car] of ~c[x] and ~em[then] sweep the ~c[cdr]
  of ~c[x] and return the result.

  Here is an example of its execution.  We have displayed the input tree
  in full dot notation so that the number of interior nodes is just the
  number of dots.
  ~bv[]
  ACL2 !>(sweep-tree '((((a . 1) . (2 . b)) . 3)
                       . (4 . (5 . d)))
                     counters)
  <counters>
  ACL2 !>(show-counters counters)
  (7 8 (5 4 3 2 1))
  ACL2 !>(reset-counters counters)
  <counters>
  ACL2 !>(show-counters counters)
  (0 0 NIL)
  ~ev[]

  The ~c[counters] object has two integer fields and a field whose
  type is unrestricted.  single-threaded objects support other types of
  fields, such as arrays.  We deal with that in the ~il[stobj-example-2].
  But we recommend that you first consider the implementation issues for
  the ~c[counters] example (in ~il[stobj-example-1-implementation]) and
  then consider the proof issues (in ~il[stobj-example-1-proofs]).

  To continue the stobj tour, ~pl[stobj-example-2].~/")

(deflabel declare-stobjs
  :doc
  ":Doc-Section stobj

  declaring a formal parameter name to be a single-threaded object~/

  When a ~ilc[defun] uses one of its formals as a single-threaded object
  (~il[stobj]), the ~c[defun] ~em[must] include a declaration that the
  formal is to be so used.  An exception is the formal ``~ilc[state],'' which
  if not declared as explained below, may still be used provided an
  appropriate global ``declaration'' is issued:
  ~pl[set-state-ok].~/

  If the formal in question is ~c[counters] then an appropriate declaration
  is
  ~bv[]
  (declare (xargs :stobjs counters))
  ~ev[]
  or, more generally,
  ~bv[]
  (declare (xargs :stobjs (... counters ...)))
  ~ev[]
  where all the single-threaded formals are listed.

  For such a declaration to be legal it must be the case that all the names
  have previously been defined as single-threaded objects with ~ilc[defstobj].

  When an argument is declared to be single-threaded the guard of the
  function is augmented by conjoining to it the condition that the
  argument satisfy the recognizer for the single-threaded object.
  Furthermore, the syntactic checks done to enforce the legal use of
  single-threaded objects are also sufficient to allow these guard
  conjuncts to be automatically proved.

  The obvious question arises:  Why does ACL2 insist that you declare
  stobj names before using them in ~c[defun]s if you can only declare names
  that have already been defined with ~c[defstobj]?  What would go wrong if
  a formal were treated as a single-threaded object if and only if it had
  already been so defined?

  Suppose that one user, say Jones, creates a book in which ~c[counters]
  is defined as a single-threaded object.  Suppose another user, Smith,
  creates a book in which ~c[counters] is used as an ordinary formal
  parameter.  Finally, suppose a third user, Brown, wishes to use both
  books.  If Brown includes Jones' book first and then Smith's, then
  Smith's function treats ~c[counters] as single-threaded.  But if Brown
  includes Smith's book first, the argument is treated as ordinary.

  ACL2 insists on the declaration to ensure that the definition is
  processed the same way no matter what the context.~/")

(deflabel stobj-example-1-defuns
  :doc
  ":Doc-Section stobj

  the defuns created by the ~c[counters] stobj~/

  Consider the event shown in ~il[stobj-example-1]:
  ~bv[]
  (defstobj counters
    (NodeCnt     :type integer :initially 0)
    (TipCnt      :type integer :initially 0)
    (IntTipsSeen :type t       :initially nil))
  ~ev[]

  Here is a complete list of the defuns added by the event.~/

  The careful reader will note that the ~c[counters] argument below is
  ~em[not] declared with the ~c[:stobjs] ~c[xarg] even though we
  insist that the argument be a stobj in calls of these functions.
  This ``mystery'' is explained below.

  ~bv[]
  (defun NodeCntp (x)                 ;;; Recognizer for 1st field
    (declare (xargs :guard t :verify-guards t))
    (integerp x))

  (defun TipCntp (x)                  ;;; Recognizer for 2nd field
    (declare (xargs :guard t :verify-guards t))
    (integerp x))

  (defun IntTipsSeenp (x)             ;;; Recognizer for 3rd field
    (declare (xargs :guard t :verify-guards t) (ignore x))
    t)

  (defun countersp (counters)         ;;; Recognizer for object
    (declare (xargs :guard t :verify-guards t))
    (and (true-listp counters)
         (= (length counters) 3)
         (NodeCntp (nth 0 counters))
         (TipCntp (nth 1 counters))
         (IntTipsSeenp (nth 2 counters))
         t))

  (defun create-counters ()           ;;; Creator for object
    (declare (xargs :guard t :verify-guards t))
    (list '0 '0 'nil))

  (defun NodeCnt (counters)           ;;; Accessor for 1st field
    (declare (xargs :guard (countersp counters) :verify-guards t))
    (nth 0 counters))

  (defun update-NodeCnt (v counters)  ;;; Updater for 1st field
    (declare (xargs :guard
                    (and (integerp v)
                         (countersp counters))
                    :verify-guards t))
    (update-nth 0 v counters))

  (defun TipCnt (counters)            ;;; Accessor for 2nd field
    (declare (xargs :guard (countersp counters) :verify-guards t))
    (nth 1 counters))

  (defun update-TipCnt (v counters)   ;;; Updater for 2nd field
    (declare (xargs :guard
                    (and (integerp v)
                         (countersp counters))
                    :verify-guards t))
    (update-nth 1 v counters))

  (defun IntTipsSeen (counters)       ;;; Accessor for 3rd field
    (declare (xargs :guard (countersp counters) :verify-guards t))
    (nth 2 counters))

  (defun update-IntTipsSeen (v counters) ;;; Updater for 3rd field
    (declare (xargs :guard (countersp counters) :verify-guards t))
    (update-nth 2 v counters))
  ~ev[]

  Observe that there is a recognizer for each of the three fields and
  then a recognizer for the ~c[counters] object itself.  Then, for each
  field, there is an accessor and an updater.

  Observe also that the functions are guarded so that they expect a
  ~c[countersp] for their ~c[counters] argument and an appropriate value
  for the new field values.

  You can see all of the ~c[defuns] added by a ~c[defstobj] event by
  executing the event and then using the ~c[:pcb!] command on the stobj
  name.  E.g.,
  ~bv[]
  ACL2 !>:pcb! counters
  ~ev[]
  will print the defuns above.

  We now clear up the ``mystery'' mentioned above.  Note, for example
  in ~c[TipCnt], that the formal ~c[counters] is used.  From the
  discussion in ~il[stobj-example-1] it has been made clear that
  ~c[TipCnt] can only be called on the ~c[counters] object.  And yet,
  in that same discussion it was said that an argument is so treated
  only if it it declared among the ~c[:stobjs] in the definition of
  the function.  So why doesn't ~c[TipCnt] include something like
  ~c[(declare (xargs :stobjs (counters)))]?

  The explanation of this mystery is as follows.  At the time
  ~c[TipCnt] was defined, during the introduction of the ~c[counters]
  stobj, the name ``~c[counters]'' was not yet a single-threaded
  object.  The introduction of a new single-threaded object occurs in
  three steps: (1) The new primitive recognizers, accessors, and
  updaters are introduced as ``ordinary functions,'' producing their
  logical axiomatizations.  (2) The executable counterparts are
  defined in raw Lisp to support destructive updating.  (3) The new
  name is declared a single-threaded object to ensure that all future
  use of these primitives respects the single-threadedness of the
  object.  The functions defined as part of the introduction of a new
  single-threaded object are the only functions in the system that
  have undeclared stobj formals other than ~c[state].

  You may return to ~il[stobj-example-1] here.~/")

(deflabel stobj-example-1-implementation
  :doc
  ":Doc-Section stobj

  the implementation of the ~c[counters] stobj~/

  the event
  ~bv[]
  (defstobj counters
    (NodeCnt     :type integer :initially 0)
    (TipCnt      :type integer :initially 0)
    (IntTipsSeen :type t       :initially nil))
  ~ev[]
  discussed in ~il[stobj-example-1], creates a Common Lisp object to
  represent the current value of ~c[counters].  That object is created
  by evaluating either of the following ``raw'' (non-ACL2) Common Lisp
  forms:
  ~bv[]
  (create-counters)

  (vector (make-array 1 :element-type 'integer
                        :initial-element '0)
          (make-array 1 :element-type 'integer
                        :initial-element '0)
          'nil)
  ~ev[]
  and the value is stored in the Common Lisp global variable named
  ~c[*the-live-counters*].
  ~/

  Thus, the ~c[counters] object is an array of length three.  The first
  two elements are arrays of size 1 and are used to hold the
  ~c[NodeCnt] and ~c[TipCnt] fields.  The third element is the
  ~c[IntTipsSeen] field.  The first two fields are represented by
  arrays so that we can implement the ~c[integer] type specification
  efficiently.  Generally, integers are ``boxed'' in some Common Lisp
  implementations, for example, GCL.  Creating a new integer requires
  creating a new box to put it in.  But in some lisps, including GCL,
  the integers inside arrays of integers are not boxed.

  The function ~c[NodeCnt] is defined in raw Lisp as:
  ~bv[]
  (defun NodeCnt (counters)
    (the integer
         (aref (the (simple-array integer (1))
                    (svref counters 0))
               0)))
  ~ev[]
  Observe that the form ~c[(svref counters 0)] is evaluated to get
  an array of size 1, which is followed by a call of ~c[aref] to
  access the 0th element of that array.

  The function ~c[update-NodeCnt] is defined in raw Lisp as:
  ~bv[]
  (defun update-NodeCnt (v counters)
    (declare (type integer v))
    (progn
     (setf (aref (the (simple-array integer (1))
                      (svref counters 0))
                 0)
           (the integer v))
     counters))
  ~ev[]
  Note that when this function is called, it does not create a new
  vector of length three, but ``smashes'' the existing one.

  One way to see all the raw Lisp functions defined by a given ~c[defstobj] is
  to evaluate the ~c[defstobj] event and then evaluate, in the ACL2 loop, the
  expression ~c[(nth 4 (global-val 'cltl-command (w state)))].  Those functions
  that contain ~c[(DECLARE (STOBJ-INLINE-FN T))] will generate ~ilc[defabbrev]
  forms because the ~c[:inline] keyword of ~ilc[defstobj] was supplied the
  value ~c[t].  The rest will generate ~ilc[defun]s.

  We now recommend that you look at ~il[stobj-example-1-proofs].~/")

(deflabel stobj-example-1-proofs
  :doc
  ":Doc-Section stobj

  some proofs involving the ~c[counters] stobj~/

  Consider again the event
  ~bv[]
  (defstobj counters
    (NodeCnt     :type integer :initially 0)
    (TipCnt      :type integer :initially 0)
    (IntTipsSeen :type t       :initially nil))
  ~ev[]
  discussed in ~il[stobj-example-1], followed by the definition
  ~bv[]
  (defun reset-counters (counters)
    (declare (xargs :stobjs (counters)))
    (seq counters
         (update-NodeCnt 0 counters)
         (update-TipCnt 0 counters)
         (update-IntTipsSeen nil counters)))
  ~ev[]
  which, because of the ~c[seq] macro in ~il[stobj-example-1], is just
  syntactic sugar for
  ~bv[]
  (defun reset-counters (counters)
    (declare (xargs :stobjs (counters)))
    (let ((counters (update-NodeCnt 0 counters)))
      (let ((counters (update-TipCnt 0 counters)))
        (update-IntTipsSeen nil counters)))).
  ~ev[]

  Here is a simple theorem about ~c[reset-counters].

  ~bv[]
  (defthm reset-counters-is-constant
    (implies (countersp x)
             (equal (reset-counters x)
                    '(0 0 nil))))
  ~ev[]
  ~/
  Before we talk about how to prove this theorem, note that the theorem
  is unusual in two respects.

  First, it calls ~c[reset-counters] on an argument other than the
  variable ~c[counters]!  That is allowed in theorems; logically
  speaking, the stobj functions are indistinguishable from ordinary
  functions.  Their use is syntactically restricted only in
  ~c[defun]s, which might be compiled and run in raw Lisp.  Those
  restrictions allow us to implement stobj modification destructively.
  But logically speaking, ~c[reset-counters] and other stobj
  ``modifying'' functions just create new objects, constructively.

  Second, the theorem above explicitly provides the hypothesis that
  ~c[reset-counters] is being applied to an object satisfying
  ~c[countersp].  Such a hypothesis is not always required:
  ~c[reset-counters] is total and will do something no matter what
  ~c[x] is.  But in this particular case, the result is not ~c['(0 0 nil)]
  unless ~c[x] is, at least, a true-list of length three.

  To make a long story short, to prove theorems about stobj functions you
  behave in exactly the way you would to prove the same theorems about the
  same functions defined without the stobj features.

  How can we prove the above theorem?  Unfolding the definition of
  ~c[reset-counters] shows that ~c[(reset-counters x)] is equal to
  ~bv[]
  (update-IntTipsSeen nil
    (update-TipCnt 0
      (update-NodeCnt 0 x)))
  ~ev[]
  which in turn is
  ~bv[]
  (update-nth 2 nil
   (update-nth 1 0
    (update-nth 0 0 x))).
  ~ev[]
  Opening up the definition of ~c[update-nth] reduces this to
  ~bv[]
  (list* 0 0 nil (cdddr x)).
  ~ev[]
  This is clearly equal to ~c['(0 0 nil)], provided we know that ~c[(cdddr x)]
  is ~c[nil].

  Unfortunately, that last fact requires a lemma.  The most specific lemma we
  could provide is
  ~bv[]
  (defthm special-lemma-for-counters
    (implies (countersp x)
             (equal (cdddr x) nil)))
  ~ev[]
  but if you try to prove that lemma you will find that it requires some
  reasoning about ~c[len] and ~c[true-listp].  Furthermore, the special
  lemma above is of interest only for ~c[counters].

  The following lemma about ~c[len] is the one we prefer.
  ~bv[]
  (defthm equal-len-n
    (implies (syntaxp (quotep n))
             (equal (equal (len x) n)
                    (if (integerp n)
                        (if (< n 0)
                            nil
                          (if (equal n 0)
                              (atom x)
                            (and (consp x)
                                 (equal (len (cdr x)) (- n 1)))))
                      nil))))
  ~ev[]
  This lemma will simplify any equality in which a ~c[len] expression
  is equated to any explicitly given constant ~em[n], e.g.,
  ~c[3], reducing the equation to a conjunction of ~c[consp] terms
  about the first ~em[n] ~c[cdr]s.

  If the above lemma is available then ACL2 immediately proves
  ~bv[]
  (defthm reset-counters-is-constant
    (implies (countersp x)
             (equal (reset-counters x)
                    '(0 0 nil))))
  ~ev[]

  The point is presumably well made: proving theorems about
  single-threaded object accessors and updaters is no different than
  proving theorems about other recursively defined functions on lists.

  As we have seen, operations on ~il[stobj]s turn into definitions
  involving ~ilc[nth] and ~ilc[update-nth] in the logic.  Here are two lemmas
  that are useful for simplifying terms involving ~c[nth] and ~c[update-nth],
  which are therefore useful in reasoning about single-threaded objects.
  ~bv[]
  (defthm update-nth-update-nth-same
    (implies (equal (nfix i1) (nfix i2))
             (equal (update-nth i1 v1 (update-nth i2 v2 l))
                    (update-nth i1 v1 l))))

  (defthm update-nth-update-nth-diff
    (implies (not (equal (nfix i1) (nfix i2)))
             (equal (update-nth i1 v1 (update-nth i2 v2 l))
                    (update-nth i2 v2 (update-nth i1 v1 l))))
    :rule-classes ((:rewrite :loop-stopper ((i1 i2)))))
  ~ev[]
  These lemmas are due to Matt Wilding.  ~l[nu-rewriter] for a
  discussion of the efficient simplification of terms of the form
  ~c[(nth n (update-nth key val lst))], which can be critical in
  settings involving sequential bindings that commonly arise in
  operations involving stobjs.

  We now recommend that you ~pl[stobj-example-2].~/")

(deflabel stobj-example-2
  :doc
  ":Doc-Section stobj

  an example of the use of arrays in single-threaded objects~/

  The following event
  ~bv[]
  (defstobj ms
    (pcn  :type integer                  :initially 0)
    (mem  :type (array integer (100000)) :initially -1)
    (code :type t                        :initially nil))
  ~ev[]
  introduces a single-threaded object named ~c[ms] (which stands for
  ``machine state'').  The object has three fields, a ~c[pcn] or program
  counter, a ~c[mem] or memory, and a ~c[code] field.

  The ~c[mem] field is occupied by an object initially of type
  ~c[(array integer (100000))].  Logically speaking, this is a list of
  length ~c[100000], each element of which is an integer.  But in the
  underlying implementation of the ~c[ms] object, this field is occupied
  by a raw Lisp array, initially of size 100000.~/

  You might expect the above ~c[defstobj] to define the accessor function
  ~c[mem] and the updater ~c[update-mem].  ~em[That does not happen!].

  The above event defines the accessor function ~c[memi] and the updater
  ~c[update-memi].  These functions do not access/update the ~c[mem] field of
  the ~c[ms] object; they access/update the individual elements of the
  array in that field.

  In particular, the logical definitions of the two functions are:
  ~bv[]
  (defun memi (i ms)
    (declare (xargs :guard
                    (and (msp ms)
                         (integerp i)
                         (<= 0 i)
                         (< i (mem-length ms)))))
    (nth i (nth 1 ms)))

  (defun update-memi (i v ms)
    (declare (xargs :guard
                    (and (msp ms)
                         (integerp i)
                         (<= 0 i)
                         (< i (mem-length ms))
                         (integerp v))))
    (update-nth-array 1 i v ms))
  ~ev[]

  For example, to access the 511th (0-based) memory location of the
  current ~c[ms] you could evaluate:
  ~bv[]
  ACL2 !>(memi 511 ms)
  -1
  ~ev[]
  The answer is ~c[-1] initially, because that is the above-specified
  initial value of the elements of the ~c[mem] array.

  To set that element you could do
  ~bv[]
  ACL2 !>(update-memi 511 777 ms)
  <ms>
  ACL2 !>(memi 511 ms)
  777
  ~ev[]

  The raw Lisp implementing these two functions is shown below.
  ~bv[]
  (defun memi (i ms)
    (declare (type (and fixnum (integer 0 *)) i))
    (the integer
         (aref (the (simple-array integer (*))
                    (svref ms 1))
               (the (and fixnum (integer 0 *)) i))))

  (defun update-memi (i v ms)
    (declare (type (and fixnum (integer 0 *)) i)
             (type integer v))
    (progn
     (setf (aref (the (simple-array integer (*))
                      (svref ms 1))
                 (the (and fixnum (integer 0 *)) i))
           (the integer v))
     ms))
  ~ev[]

  If you want to see the raw Lisp supporting a ~c[defstobj], execute the
  ~c[defstobj] and then evaluate the ACL2 form
  ~c[(nth 4 (global-val 'cltl-command (w state)))].

  To continue the stobj tour, ~pl[stobj-example-3].~/")

(deflabel stobj-example-3
  :doc
  ":Doc-Section stobj

  another example of a single-threaded object~/

  The event
  ~bv[]
  (defstobj $s
    (x :type integer :initially 0)
    (a :type (array (integer 0 9) (3)) :initially 9 :resizable t))
  ~ev[]
  introduces a stobj named ~c[$S].  The stobj has two fields, ~c[X] and
  ~c[A].  The ~c[A] field is an array.  The ~c[X] field contains an
  integer and is initially 0.  The ~c[A] field contains a list of
  integers, each between 0 and 9, inclusively.  (Under the hood, this
  ``list'' is actually implemented as an array.)  Initially, the ~c[A]
  field has three elements, each of which is 9.~/

  This event introduces the following sequence of function definitions:
  ~bv[]
  (DEFUN XP (X) ...)               ; recognizer for X field
  (DEFUN AP (X) ...)               ; recognizer of A field
  (DEFUN $SP ($S) ...)             ; top-level recognizer for stobj $S
  (DEFUN CREATE-$S NIL ...)        ; creator for stobj $S
  (DEFUN X ($S) ...)               ; accessor for X field
  (DEFUN UPDATE-X (V $S) ...)      ; updater for X field
  (DEFUN A-LENGTH ($S) ...)        ; length of A field
  (DEFUN RESIZE-A (K $S) ...)      ; resizer for A field
  (DEFUN AI (I $S) ...)            ; accessor for A field at index I
  (DEFUN UPDATE-AI (I V $S) ...)   ; updater for A field at index I
  ~ev[]

  Here is the definition of ~c[$SP]:
  ~bv[]
  (DEFUN $SP ($S)
    (DECLARE (XARGS :GUARD T :VERIFY-GUARDS T))
    (AND (TRUE-LISTP $S)
         (= (LENGTH $S) 2)
         (XP (NTH 0 $S))
         (AP (NTH 1 $S))
         T))
  ~ev[]
  This reveals that in order to satisfy ~c[$SP] an object must be
  a true list of length 2 whose first element satisfies ~c[XP] and whose
  second satisfies ~c[AP].  By printing the definition of ~c[AP] one
  learns that it requires its argument to be a true list, each element
  of which is an integer between 0 and 9.

  The initial value of stobj ~c[$S] is given by zero-ary ``creator''
  function ~c[CREATE-$S].  Creator functions may only be used in limited
  contexts.  ~l[with-local-stobj].

  Here is the definition of ~c[UPDATE-AI], the updater for the ~c[A] field
  at index ~c[I]:
  ~bv[]
  (DEFUN UPDATE-AI (I V $S)
    (DECLARE (XARGS :GUARD
                    (AND ($SP $S)
                         (INTEGERP I)
                         (<= 0 I)
                         (< I (A-LENGTH $S))
                         (AND (INTEGERP V) (<= 0 V) (<= V 9)))
                    :VERIFY-GUARDS T))
    (UPDATE-NTH-ARRAY 1 I V $S))
  ~ev[]
  By definition ~c[(UPDATE-NTH-ARRAY 1 I V $S)] is
  ~c[(UPDATE-NTH 1 (UPDATE-NTH I V (NTH 1 $S)) $S)].
  This may be a little surprising but should be perfectly clear.

  First, ignore the guard, since it is irrelevant in the logic.
  Reading from the inside out, ~c[(UPDATE-AI I V $S)] extracts ~c[(NTH 1 $S)],
  which is array ~c[a] of ~c[$S].  (Recall that ~ilc[NTH] is
  0-based.)  The next higher expression in the definition above,
  ~c[(UPDATE-NTH I V a)], ``modifies'' ~c[a] by setting its ~c[I]th
  element to ~c[V].  Call this ~c[a'].  The next higher expression,
  ~c[(UPDATE-NTH 1 a' $S)], ``modifies'' ~c[$S] by setting its 1st
  component to ~c[a'].  Call this result ~c[$s'].  Then ~c[$s'] is
  the result returned by ~c[UPDATE-AI].

  So the first useful observation is that from the perspective of the
  logic, the type ``restrictions'' on stobjs are irrelevant.  They
  are ``enforced'' by ACL2's guard mechanism, not by the definitions
  of the updater functions.

  As one might also imagine, the accessor functions do not really
  ``care,'' logically, whether they are applied to well-formed stobjs
  or not.  For example, ~c[(AI I $S)] is defined to be ~c[(NTH I (NTH 1 $S))].

  Thus, you will not be able to prove that (AI 2 $S) is an
  integer.  That is,
  ~bv[]
  (integerp (AI 2 $S))
  ~ev[]
  is not a theorem, because ~c[$S] may not be well-formed.

  Now ~c[(integerp (AI 2 $S))] will always evaluate to ~c[T] in the
  top-level ACL2 command loop, because we insist that the current value of
  the stobj ~c[$S] always satisfies ~c[$SP] by enforcing the guards on
  the updaters, independent of whether guard checking is on or off;
  ~pl[set-guard-checking].  But in a theorem ~c[$S] is just
  another variable, implicitly universally quantified.

  So ~c[(integerp (AI 2 $S))] is not a theorem because it is not true when
  the variable ~c[$S] is instantiated with, say,
  ~bv[]
  '(1 (0 1 TWO))
  ~ev[]
  because, logically speaking, ~c[(AI 2 '(1 (0 1 TWO)))] evaluates to
  the symbol ~c[TWO].  That is,
  ~bv[]
  (equal (AI 2 '(1 (0 1 TWO))) 'TWO)
  ~ev[]
  is true.

  However,
  ~bv[]
  (implies (and ($SP $S) (< 2 (A-LENGTH $S))) (integerp (AI 2 $S)))
  ~ev[]
  is a theorem.  To prove it, you will have to prove a lemma about
  ~c[AP].  The following will do:
  ~bv[]
  (defthm ap-nth
    (implies (and (AP x)
                  (integerp i)
                  (<= 0 i)
                  (< i (len x)))
             (integerp (nth i x)))).
  ~ev[]

  Similarly,
  ~bv[]
  (implies (and (integerp i)
                (<= 0 i)
                (< i (A-LENGTH $S))
                (integerp v)
                (<= 0 v)
                (<= v 9))
           ($SP (UPDATE-AI i v $S)))
  ~ev[]
  is not a theorem until you add the additional hypothesis ~c[($SP $S)].
  To prove the resulting theorem, you will need a lemma such as the
  following.
  ~bv[]
  (defthm ap-update-nth
    (implies (and (AP a)
                  (integerp v)
                  (<= 0 v)
                  (<= v 9)
                  (integerp i)
                  (<= 0 i)
                  (< i (len a)))
             (AP (update-nth i v a))))
  ~ev[]

  The moral here is that from the logical perspective, you must
  provide the hypotheses that, as a programmer, you think are
  implicit on the structure of your stobjs, and you must prove their
  invariance.  This is a good area for further support, perhaps in
  the form of a library of macros.

  ~em[Resizing Array Fields]

  Recall the specification of the array field, ~c[A] for the stobj ~c[$S]
  introduced above:
  ~bv[]
  (a :type (array (integer 0 9) (3)) :initially 9 :resizable t)
  ~ev[]
  Logically, this field is a list, initially of length 3.  Under the
  hood, this field is implemented using a Common Lisp array with 3
  elements.  In some applications, one may wish to lengthen an array
  field, or even (to reclaim space) to shrink an array field.  The
  ~ilc[defstobj] event provides functions to access the current length
  of an array field and to change the array field, with default names
  obtained by suffixing the field name with ``~c[LENGTH-]'' or prefixing
  it with ``~c[RESIZE-],'' respectively.  The following log shows the uses
  of these fields in the above example.
  ~bv[]
  ACL2 !>(A-LENGTH $S)
  3
  ACL2 !>(RESIZE-A 10 $S) ; change length of A to 10
  <$s>
  ACL2 !>(A-LENGTH $S)
  10
  ACL2 !>(AI 7 $S)        ; new elements get value from :initially
  9
  ACL2 !>(RESIZE-A 2 $S)  ; truncate A down to first 2 elements
  <$s>
  ACL2 !>(A-LENGTH $S)
  2
  ACL2 !>(AI 7 $S)        ; error:  access past array bound


  ACL2 Error in TOP-LEVEL:  The guard for the function symbol AI, which
  is (AND ($SP $S) (INTEGERP I) (<= 0 I) (< I (A-LENGTH $S))), is violated
  by the arguments in the call (AI 7 $S).

  ACL2 !>
  ~ev[]
  Here are the definitions of the relevant functions for the above
  example; also ~pl[resize-list].
  ~bv[]
  (DEFUN A-LENGTH ($S)
    (DECLARE (XARGS :GUARD ($SP $S) :VERIFY-GUARDS T))
    (LEN (NTH 1 $S)))

  (DEFUN RESIZE-A (K $S)
    (DECLARE (XARGS :GUARD ($SP $S) :VERIFY-GUARDS T))
    (UPDATE-NTH 1
                (RESIZE-LIST (NTH 1 $S) K 9)
                $S))
  ~ev[]

  It is important to note that the implementation of array resizing in
  ACL2 involves copying the entire array into a newly allocated space
  and thus can be quite costly if performed often.  This approach was
  chosen in order to make array access and update as efficient as
  possible, with the suspicion that for most applications, array
  access and update are considerably more frequent than resizing
  (especially if the programmer is aware of the relative costs
  beforehand).

  It should also be noted that computations of lengths of stobj array
  fields should be fast (constant-time) in all or most Common Lisp
  implementations.

  Finally, if ~c[:resizable t] is not supplied as shown above, then
  an attempt to resize the array will result in an error.  If you do
  not intend to resize the array, it is better to omit the ~c[:resizable]
  option (or to supply ~c[:resizable nil]), since then the length
  function will be defined to return a constant, namely the initial
  length, which can simplify guard proofs (compare with the definition
  of ~c[A-LENGTH] above).

  This completes the tour through the documentation of ~il[stobj]s.
  However, you may now wish to read the documentation for the event
  that introduces a new single-threaded object; ~pl[defstobj].~/")

(defdoc resize-list
  ":Doc-Section Stobj

  list resizer in support of stobjs~/

  ~c[(Resize-list lst n default-value)] takes a list, ~c[lst], and a desired
  length, ~c[n], for the result list, as well as a ~c[default-value] to use
  for the extra elements if ~c[n] is greater than the length of ~c[lst].~/

  ~c[Resize-list] has a guard of ~c[t].  This function is called in the body
  of function, ~c[resize-<a>] where ~c[<a>] is an array field of a ~il[stobj].
  ~l[stobj] and ~pl[defstobj].~/")

#-acl2-loop-only
(defun-one-output mv-let-for-with-local-stobj (mv-let-form st creator flet-fns w)

; If w is not nil, then it is the current ACL2 world and we are to oneify the
; appropriate subforms.

; It was tempting to have an acl2-loop-only version of the body below as well,
; which would omit the binding of the live var.  But if someone were to
; verify-termination of this function, we could presumably prove nil using the
; discrepancy between the two versions.  So we take the attitude that
; with-local-stobj is a special form, like let, that is not defined.

; In the case that st is STATE, this form does not take responsibility for
; restoring state, for example by restoring values of state global variables
; and by closing channels that may have been created during evaluation of the
; producer form.  A with-local-state form thus needs to take responsibility for
; restoring state; see for example the definition of channel-to-string.

  (let ((producer (caddr mv-let-form))
        (rest (cdddr mv-let-form)))
    `(mv-let ,(cadr mv-let-form)
             (let* (,@(and (not (eq st 'state))
                           `((,st (,creator))))

; We bind the live var so that user-stobj-alist-safe can catch misguided
; attempts to use functions like trans-eval in inappropriate contexts.

                    ,@(cond ((eq st 'state)
                             '((*file-clock* *file-clock*)
                               (*t-stack* *t-stack*)
                               (*t-stack-length* *t-stack-length*)
                               (*32-bit-integer-stack* *32-bit-integer-stack*)
                               (*32-bit-integer-stack-length*
                                *32-bit-integer-stack-length*)))
                            (t `((,(the-live-var st) ,st)))))
               ,(let ((p (if w (oneify producer flet-fns w) producer)))
                  (if (eq st 'state)

; We should lock this computation when #+acl2-par, even though special
; variables that are let-bound (including those bound above) are thread-local.

                      `(if (f-get-global 'parallel-execution-enabled
                                         *the-live-state*)

; Parallelism wart: this isn't really the right check for ACL2(p), because
; we've effectively disallowed the use of with-local-state, even when we're not
; executing in parallel!  This bothers Rager, because he wants to use
; with-local-state in code that isn't executing in parallel (in his
; dissertation's supporting evidence, for reading in files that contain
; performance results).  Instead, we should be calling
; warn-about-parallelism-hazard (similar to what we do in the definition of
; state-global-let*).

                           (er hard! 'with-local-state
                               "The use of with-local-state ~
                                (or, with-local-stobj where STATE is the ~
                                stobj) is disallowed with parallelism enabled.")
                         ,p)
                    p)))
             (declare (ignore ,st))
             ,@(if w
                   (if (cdr rest) ; rest is ((declare (ignore ...)) body)
                       (list (car rest) (oneify (cadr rest) flet-fns w))
                     (list (oneify (car rest) flet-fns w)))
                 rest))))

#-acl2-loop-only ; see the comment in mv-let-for-with-local-stobj
(defmacro with-local-stobj (&rest args)

; Below are some tests of local stobjs.

;  (defstobj foo bar xxx)
;
;  (thm (equal (create-foo) '(nil nil))) ; succeeds
;
;  (defun up1 (x foo)
;    (declare (xargs :stobjs foo))
;    (update-bar x foo))
;
;  (bar foo) ; nil
;
;  (up1 3 foo) ; <foo>
;
;  (bar foo) ; 3
;
;  (defun test (x) ; should fail; must use with-local-stobj explicitly
;    (mv-let (a b foo)
;            (let ((foo (create-foo)))
;              (let ((foo (up1 (1+ x) foo)))
;                (mv (bar foo) (xxx foo) foo)))
;            (declare (ignore foo))
;            (mv a b x)))
;
;  (defun test (x)
;    (declare (xargs :guard (acl2-numberp x) :verify-guards nil))
;    (with-local-stobj
;     foo
;     (mv-let (a b foo)
;             (let ((foo (up1 (1+ x) foo)))
;               (mv (bar foo) (xxx foo) foo))
;             (mv a b x))))
;
;  (test 17) ; (18 NIL 17)
;
;  (bar foo) ; 3
;
;  (thm (equal (test x) (list (1+ x) nil x))) ; succeeds
;
;  (thm (equal (test x) (list (1+ x) nil x)) ; succeeds
;       :hints (("Goal"
;                :in-theory
;                (enable
;                 (:executable-counterpart create-foo)))))
;
;  (thm (equal (test x) (list (1+ x) nil x)) ; fails, creating (NOT (NTH 1 (HIDE (CREATE-FOO))))
;       :hints (("Goal"
;                :in-theory
;                (set-difference-theories
;                 (enable
;                  (:executable-counterpart create-foo))
;                 '(create-foo)))))
;
;  (verify-guards test)
;
;  (test 17) ; (18 nil 17)
;
;  (bar foo) ; 3
;
;  (defun test2 (x)
;    (with-local-stobj
;     foo
;     (mv-let (a foo)
;             (let ((foo (up1 (1+ x) foo))) (mv (bar foo) foo))
;             (mv a x))))
;
;  (test2 12) ; (13 12)
;
;  (bar foo) ; 3
;
;  (thm (equal (test x) (mv-let (x y) (test2 x) (mv x nil y)))) ; succeeds
;
;  (create-foo) ; should get graceful error
;
;  (defun test3 (x) ; Should be OK.
;    (with-local-stobj
;     foo
;     (mv-let (a foo)
;             (let ((foo (up1 (1+ x) foo))) (mv (bar foo) foo))
;             a)))
;
;  (test3 11) ; 12
;
;  (bar foo) ; 3
;
;  (defun test4 (x foo) ; Should be OK.
;    (declare (xargs :stobjs foo
;                    :verify-guards nil))
;    (let* ((x+1
;           (with-local-stobj
;            foo
;            (mv-let (a foo)
;                    (let ((foo (up1 (1+ x) foo))) (mv (bar foo) foo))
;                    a)))
;           (foo (up1 92 foo)))
;      (mv x+1 foo)))
;
;  (test4 19 foo) ; (20 <foo>)
;
;  (bar foo) ; 92
;
;  (defun test5 (x foo) ; Should be OK.
;    (declare (xargs :stobjs foo
;                    :verify-guards nil))
;    (let* ((foo (up1 23 foo))
;           (x+1
;            (with-local-stobj
;             foo
;             (mv-let (a foo)
;                     (let ((foo (up1 (1+ x) foo))) (mv (bar foo) foo))
;                     a))))
;      (mv x+1 foo)))
;
;  (test5 35 foo) ; (36 <foo>)
;
;  (bar foo) ; 23
;
;  (with-local-stobj ; should get macroexpansion error or the equivalent
;   foo
;   (mv foo 3))
;
;  (defun trans-eval-test (x foo state) ; this part is ok
;    (declare (xargs :stobjs (foo state)
;                    :mode :program))
;    (mv-let (erp val state)
;            (trans-eval '(update-bar (cons 3 (bar foo)) foo) 'top state t)
;            (declare (ignore erp val))
;            (mv x foo state)))
;
;  (with-local-stobj ; should fail; cannot use with-local-stobj in top level loop
;   foo
;   (mv-let (x foo state)
;           (trans-eval-test 3 foo state t)
;           (mv x state)))
;
;  (pprogn
;   (with-local-stobj ; should fail with create-foo error
;    foo
;    (mv-let (x foo state)
;            (trans-eval-test 3 foo state t)
;            (declare (ignore x))
;            state))
;   (mv 3 state))
;
;  (defun test6 (a state)
;    (declare (xargs :mode :program :stobjs state))
;    (with-local-stobj
;     foo
;     (mv-let (x foo state)
;             (trans-eval-test a foo state t)
;             (mv x state))))
;
;  (test6 100 state) ; should get trans-eval error:  user-stobj-alist mismatch
;
;  (bar foo) ; 23, still -- trans-eval did not affect global state

; Below are some more tests, contributed by Rob Sumners.

;  (defstobj foo foo-fld)
;  (defstobj bar bar-fld)
;
;  (defun test-wls1 (x)
;    (with-local-stobj
;     foo
;     (mv-let (result foo)
;             (let ((foo (update-foo-fld 2 foo)))
;               (mv (with-local-stobj
;                    bar
;                    (mv-let (result bar)
;                            (let ((bar (update-bar-fld 3 bar)))
;                              (mv x bar))
;                            result))
;                   foo))
;             result)))
;
;  (test-wls1 129) ; 129
;
;  :comp t
;
;  (test-wls1 '(adjka 202)) ; '(ADJKA 202)
;
;  (thm (equal (test-wls1 x) x))
;
;  (defun test-wls2 (x)
;    (with-local-stobj
;     foo
;     (mv-let (result foo)
;             (let ((foo (update-foo-fld 2 foo)))
;               (mv (with-local-stobj
;                    foo
;                    (mv-let (result foo)
;                            (let ((foo (update-foo-fld 3 foo)))
;                              (mv x foo))
;                            result))
;                   foo))
;             result)))
;
;  (test-wls2 129) ; 129
;
;  :comp t
;
;  (test-wls2 '(adjka 202)) ; (ADJKA 202)
;
;  (thm (equal (test-wls2 x) x))
;
;  (defun test-wls3 (x)
;    (if (atom x) x
;      (with-local-stobj
;       foo
;       (mv-let (result foo)
;               (mv (cons (car x)
;                         (test-wls3 (cdr x)))
;                   foo)
;               (let ((x result))
;                 (if (atom x) x (cons (car x) (cdr x))))))))
;
;  (test-wls3 129) ; 129
;
;  :comp t
;
;  (test-wls3 '(adjka 202)) ; (ADJKA 202)
;
;  (thm (equal (test-wls3 x) x))

  (mv-let (erp st mv-let-form creator)
          (parse-with-local-stobj args)
          (if (or erp
                  (not (and (true-listp mv-let-form)
                            (<= 3 (length mv-let-form)))))
              (er hard 'with-local-stobj
                  "Macroexpansion of a with-local-stobj call caused an error. ~
                   See :DOC with-local-stobj.")
            (mv-let-for-with-local-stobj mv-let-form st creator nil nil))))

(deflabel with-local-stobj
  :doc
  ":Doc-Section Stobj

  locally bind a single-threaded object~/

  ~l[stobj] for an introduction to single-threaded objects.
  ~bv[]
  Example Form:
  (with-local-stobj
   st
   (mv-let (result st)
           (compute-with-st x st)
           result))
  ~ev[]
  ~c[With-local-stobj] can be thought of as a macro, where the example
  form above expands as follows.
  ~bv[]
  (mv-let (result st)
          (let ((st (create-st)))
            (compute-with-st x st))
          (declare (ignore st))
          result)
  ~ev[]
  However, ACL2 expects you to use ~c[with-local-stobj], not its
  expansion.  More precisely, stobj creator functions are not allowed
  except (implicitly) via ~c[with-local-stobj] and in logic-only
  situations (like theorems and hints).  Moreover, neither
  ~c[with-local-stobj] nor its expansions are legal when typed directly at
  the top-level loop.  ~l[top-level] for a way to use ~c[with-local-stobj]
  in the top-level loop.~/
  ~bv[]
  General Forms:
  (with-local-stobj stobj-name mv-let-form)
  (with-local-stobj stobj-name mv-let-form creator-name)
  ~ev[]
  where ~c[stobj-name] is the name of a ~il[stobj], ~c[mv-let-form] is a call
  of ~ilc[mv-let], and if ~c[creator-name] is supplied then it should be the
  name of the creator function for ~c[stobj-name]; ~pl[defstobj].  For the
  example form above, its expansion would use ~c[creator-name], if supplied, in
  place of ~c[create-st].  Note that ~c[stobj-name] must not be ~ilc[state]
  (the ACL2 state), except in special situations probably of interest only to
  system developers; ~pl[with-local-state].

  ~c[With-local-stobj] can be useful when a stobj is used to memoize
  intermediate results during a computation, yet it is desired not to
  make the ~c[stobj] a formal parameter for the function and its
  callers.

  ACL2 can reason about these ``local stobjs,'' and in particular
  about stobj creator functions.  For technical reasons, ACL2 will not
  allow you to enable the ~c[:EXECUTABLE-COUNTERPART] ~il[rune] of a stobj
  creator function.

  Finally, here is a small example concocted in order to illustrate that
  ~c[with-local-stobj] calls can be nested.
  ~bv[]
  (defstobj st fld1)

  (defun foo ()
    (with-local-stobj
     st ; Let us call this the ``outer binding of st''.
     (mv-let (val10 val20 st)
       (let ((st (update-fld1 10 st)))
         ;; At this point the outer binding of st has fld1 = 10.
         (let ((result (with-local-stobj
                        st ; Let us call this the ``inner binding of st''.
                        (mv-let (val st)
                          (let ((st (update-fld1 20 st)))
                            ;; Now fld1 = 20 for the inner binding of st.
                            (mv (fld1 st) st))
                          val))))
           ;; So result has been bound to 20 above, but here we are once again
           ;; looking at the outer binding of st, where fld1 is still 10.
           (mv (fld1 st) result st)))
       (mv val10 val20))))

  (thm (equal (foo) (mv 10 20))) ; succeeds
  ~ev[]~/")

(defun create-state ()
  (declare (xargs :guard t))
  (coerce-object-to-state *default-state*))

(defmacro with-local-state (mv-let-form)

  ":Doc-Section Stobj

  locally bind state~/

  This is an advanced topic, probably of interest only to system developers.

  Consider the following example form:
  ~bv[]
  (with-local-state
   (mv-let (result state)
           (compute-with-state x state)
           result))
  ~ev[]
  This is equivalent to the following form.
  ~bv[]
  (with-local-stobj
   state
   (mv-let (result state)
           (compute-with-state x state)
           result))
  ~ev[]
  By default, this form is illegal, because ACL2 does not have a way to unwind
  all changes to the ACL2 ~il[state]; we say more on this issue below.  There
  may however be situations where you are willing to manage or overlook this
  issue.  In that case you may execute the following form to enable the use of
  ~c[with-local-state], by enabling the use of ~ilc[with-local-stobj] on
  ~c[state]; but note that it requires an active trust tag (~pl[defttag]).
  ~bv[]
  (remove-untouchable create-state t)
  ~ev[]

  Please be aware that no local ~il[state] is actually created, however!  In
  particular, users of ~c[with-local-state] need either to ensure that channels
  are closed and state global variables are returned to their original values,
  or else be willing to live with changes made to state that are not justified
  by the code that has been evaluated.  You are welcome to look in the the ACL2
  source code at the definition of macro ~c[channel-to-string], which employs
  ~c[with-local-state] to create a local ~il[state] for the purpose of creating
  a string.~/

  Here is an example use of ~c[with-local-state].  Notice the use of
  ~ilc[defttag] ~-[] and indeed, please understand that we are just hacking
  here, and in general it takes significant effort to be sure that one is using
  ~c[with-local-state] correctly!
  ~bv[]
  (defttag t)

  (remove-untouchable create-state t)

  (set-state-ok t)

  (defun foo (state)
    (declare (xargs :mode :program))
    (mv-let
     (channel state)
     (open-input-channel \"my-file\" :object state)
     (mv-let (eofp obj state)
             (read-object channel state)
             (declare (ignore eofp))
             (let ((state (close-input-channel channel state)))
               (mv obj state)))))

  (defun bar ()
    (declare (xargs :mode :program))
    (with-local-state (mv-let (result state)
                              (foo state)
                              result)))

  ; Multiple-value return version:

  (defun foo2 (state)
    (declare (xargs :mode :program))
    (mv-let
     (channel state)
     (open-input-channel \"my-file\" :object state)
     (mv-let (eofp obj state)
             (read-object channel state)
             (let ((state (close-input-channel channel state)))
               (mv eofp obj state)))))

  (defun bar2 ()
    (declare (xargs :mode :program))
    (with-local-state (mv-let (eofp result state)
                              (foo2 state)
                              (mv eofp result))))
  ~ev[]~/"

  `(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.  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 must be a symbol or a (possibly
; quoted) natural number -- after all, there would be a waste of computation
; otherwise, since we do updates at the end.  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 concrete (not abstract) 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

(defdoc nested-stobjs

; WARNING: This documentation contains examples from community book
; misc/nested-stobj-tests.lisp.  If you change those examples here, change them
; also in that book.

  ":Doc-Section stobj

  using ~il[stobj]s that contain stobjs~/

  For this topic we assume that you already understand the basics of
  single-threaded objects in ACL2.  ~l[stobj], and in particular,
  ~pl[defstobj].  The latter topic defers discussion of the ability to specify
  a stobj field that is itself a stobj or an array of stobjs.  That discussion
  is the subject of the present ~il[documentation] topic.

  Our presentation is in four sections.  First we augment the documentation for
  ~ilc[defstobj] by explaining how stobjs may be specified for fields in a new
  stobj definition.  Then we explain an aliasing problem, which accounts for a
  prohibition against making direct calls to accessors and updaters involving
  stobj fields of stobjs.  Next, we introduce an ACL2 primitive, ~c[stobj-let],
  which provides the only way to read and write stobj components of stobjs.
  The final section provides precise documentation for ~c[stobj-let].

  See also ACL2 community book ~c[demos/modeling/nested-stobj-toy-isa.lisp] for
  a worked example, which applies nested stobj structures to defining
  interpreters.  A variety of small additional examples may be found in ACL2
  community book ~c[misc/nested-stobj-tests.lisp].  For further discussion, you
  are welcome to read the ``Essay on Nested Stobjs'', a long comment in ACL2
  source file ~c[other-events.lisp].  However, this documentation topic is
  intended to be self-contained for those familiar with ~il[stobj]s.

  SECTION: Extension of ~ilc[defstobj] to permit ~il[stobj]s within stobjs

  Recall that the ~c[:type] keyword of a ~ilc[defstobj] field descriptor can be
  a ``type-indicator'' that specifies the type of the field as a
  type-spec (~pl[type-spec]).  For example, the following specifies an integer
  field and a field that is an array of bytes.
  ~bv[]
    (defstobj st
      (int-field :type integer :initially 0)
      (ar-field :type (array unsigned-byte (10)) :initially 0))
  ~ev[]
  But the ~c[:type] of a stobj field descriptor may instead be based on a
  stobj.  For example, the following sequence of three ~il[events] is legal.
  The first field descriptor of ~c[top], named ~c[sub1-field], illustrates one
  new kind of value for ~c[:type]: the name of a previously-introduced stobj,
  which here is ~c[sub1]. The second field descriptor of ~c[top], named
  ~c[sub2-ar-field], illustrates the other new kind of value for ~c[:type]: an
  array whose elements are specified by the name of a previously-introduced
  stobj, in this case, the stobj ~c[sub2].
  ~bv[]
    (defstobj sub1 fld1)
    (defstobj sub2 fld2)
    (defstobj top
      (sub1-field :type sub1)
      (sub2-ar-field :type (array sub2 (10))))
  ~ev[]
  The ~c[:initially] keyword is illegal for fields whose ~c[:type] is a stobj
  or an array of stobjs.  Each such initial value is provided by a
  corresponding call of the stobj creator for that stobj.  In particular, in
  the case of an array of stobjs, the stobj creator is called once for each
  element of the array, so that the array elements are distinct.  For example,
  each element of ~c[sub2-ar-field] in the example above is initially provided
  by a separate call of ~c[create-sub2].  Each initial element is thus unique,
  and in particular is distinct from the initial global value of the stobj.
  Similarly, the initial global stobj for ~c[sub1] is distinct from the initial
  ~c[sub1-field] field of the global stobj for ~c[top], as these result from
  separate calls of ~c[create-sub1].

  When a stobj is used in a field of another stobj, we may refer to the former
  field as a ``child stobj'' and the latter stobj as a ``parent stobj''.  So in
  the example above, ~c[sub1-field] is a child stobj of type ~c[sub1] for
  parent stobj ~c[top], and ~c[sub2-ar-field] is an array of child stobjs of
  type ~c[sub2] for parent stobj ~c[top].  A child stobj has the same
  structural shape as the global stobj of its type, but as explained above,
  these are distinct structures.  We follow standard terminology by saying
  ``isomorphic'' to indicate the same structural shape.  So for example, (the
  value of) ~c[sub1-field] is isomorphic to ~c[sub1], though these are distinct
  structures.

  SECTION: An aliasing problem

  Before introducing ~c[stobj-let] below, we provide motivatation for this
  ACL2 primitive.

  Consider the following ~il[events].
  ~bv[]
    (defstobj child fld)
    (defstobj parent
      (fld2 :type child))
  ~ev[]
  Now suppose we could evaluate the following code, to be run immediately after
  admitting the two ~ilc[defstobj] events above.
  ~bv[]
    (let* ((child (fld2 parent))
           (child (update-fld 3 child)))
      (mv child parent))
  ~ev[]
  Now logically there is no change to ~c[parent]: ~c[parent] is passed through
  unchanged.  We can indeed prove that fact!
  ~bv[]
    (thm (equal (mv-nth 1
                        (let* ((child (fld2 parent))
                               (child (update-fld 3 child)))
                          (mv child parent)))
                parent))
  ~ev[]
  But recall that stobjs are updated with destructive assignments.  That is, we
  really are updating ~c[(fld2 parent)] to be the new value of ~c[child],
  whether this is explained logically or not.  Thus, evaluation of the above
  ~ilc[let*] form does in fact change the actual global stobj, ~c[parent].

  (Aside: Here is an explanation involving raw Lisp, for those who might find
  this useful.  We escape to raw Lisp and execute the following; note that
  ~c[*the-live-parent*] is the Lisp variable representing the global value of
  ~c[parent].
  ~bv[]
  (let ((parent *the-live-parent*))
    (let* ((child (fld2 parent))
           (child (update-fld 4 child)))
      (mv child parent)))
  ~ev[]
  Then, in raw Lisp, ~c[(fld (fld2 *the-live-parent*))] evaluates to ~c[4],
  illustrating the destructive update.  End of Aside.)

  Such aliasing can permit a change to a child stobj to cause a
  logically-inexplicable change to the parent stobj.  Similarly, unfettered
  accessing of stobj fields can result in logically inexplicable changes to the
  child stobj when the parent stobj is changed.  Thus, ACL2 disallows direct
  calls of stobj accessors and updaters for fields whose ~c[:type] is a stobj
  or an array of stobjs.  Instead, ACL2 provides ~c[stobj-let] for reading and
  writing such fields in a sound manner.

  SECTION: Accessing and updating stobj fields of stobjs using ~c[stobj-let]

  ACL2 provides a primitive, ~c[stobj-let], to access and update stobj fields
  of stobjs, in a manner that avoids the aliasing problem discussed above.  In
  this section we provide an informal introduction to ~c[stobj-let], using
  examples, to be followed in the next section by precise documentation.

  We begin by returning to a slight variant of the example above.
  ~bv[]
    (defstobj child fld)
    (defstobj parent
      (fld2 :type child)
      fld3)
  ~ev[]
  The following form returns the result of updating the ~c[fld2] field of
  ~c[parent], which is a stobj isomorphic to ~c[child], to have a value of 3.
  Below we explain the terms ``bindings'', ``producer variables'',
  ``producer'', and ``consumer'', as well as how to understand this form.
  ~bv[]
    (stobj-let
     ((child (fld2 parent)))  ; bindings
     (child)                  ; producer variable(s)
     (update-fld 3 child)     ; producer
     (update-fld3 'a parent)) ; consumer
  ~ev[]
  The four lines under ``~c[stobj-let]'' just above can be understood as
  follows.
  ~bf[]
  o Bindings:
      Bind ~c[child] to ~c[(fld2 parent)].
  o Producer variable(s) and producer:
      Then bind the variable, ~c[child], to
      the value of the producer, ~c[(update-fld 3 child)].
  o Implicit update of parent:
      Update ~c[fld2] of ~c[parent] with the producer variable, ~c[child].
  o Consumer:
      Finally, return ~c[(update-fld3 'a parent)].
  ~ef[]
  Thus, the logical expansion of the ~c[stobj-let] form above is the following
  expression, though this is approximate (see below).
  ~bv[]
    (let ((child (fld2 parent))) ; bindings
      (let ((child (update-fld 3 child))) ; bind producer vars to producer
        (let ((parent (update-fld2 child parent))) ; implicit update of parent
          (update-fld3 'a parent))))
  ~ev[]
  The bindings always bind distinct names to child stobjs of a unique parent
  stobj, where the child stobj corresponds to the ~c[:type] associated with the
  indicated accessor in the ~ilc[defstobj] form for the parent stobj.  Thus in
  this case, for the unique binding, variable ~c[child] is bound to the stobj
  of `type' ~c[child] for accessor ~c[fld2] of the parent stobj, ~c[parent].
  We refer to ~c[child] from the bindings as a ``stobj-let-bound variable''.
  Note also that the ``implicit extra step'' mentioned above is generated by
  macroexpansion of ~c[stobj-let]; it logically updates the parent with new
  child values, just before calling the consumer.  Implementation note:
  Destructive updating in raw Lisp lets us omit this implicit extra step.

  The form above is equivalent to the form displayed just below, which differs
  only in specifying an explicit stobj updater corresponding to the stobj
  accessor, ~c[fld2].  Here we show the default updater name, whose name has
  ~c[\"UPDATE-\"] prepended to the name of the accessor.  But if the
  ~c[:RENAMING] field of the ~c[defstobj] event specified a different updater
  name corresponding to ~c[fld2], then that would need to be included where we
  have added ~c[update-fld2] below.
  ~bv[]
    (stobj-let
     ((child (fld2 parent) update-fld2)) ; bindings, including updater(s)
     (child)                  ; producer variables
     (update-fld 3 child)     ; producer
     (update-fld3 'a parent)) ; consumer
  ~ev[]

  You can experiment using ~c[:]~ilc[trans1] to see the single-step
  macroexpansion of a ~c[stobj-let] form in the logic.  For example, here is
  how that works for a ~c[stobj-let] form that binds three fields and updates
  two of them.  Notice that because more than one field is updated, an
  ~ilc[mv-let] form is generated to bind the two fields to their values
  returned by the producer, rather than a ~ilc[let] form as previously
  generated.  First, let's introduce some events.

  ~bv[]
  (defstobj child1 child1-fld)
  (defstobj child2 child2-fld)
  (defstobj child3 child3-fld)
  (defstobj mom
    (fld1 :type child1)
    (fld2 :type child2)
    (fld3 :type child3))
  ; Silly stub:
  (defun update-last-op (op mom)
    (declare (xargs :stobjs mom))
    (declare (ignore op))
    mom)
  (defun new-mom (mom)
    (declare (xargs :stobjs mom))
    (stobj-let
     ((child1 (fld1 mom))
      (child2 (fld2 mom))
      (child3 (fld3 mom)))
     (child1 child3)
     (let* ((child1 (update-child1-fld 'one child1))
            (child3 (update-child3-fld 'three child3)))
       (mv child1 child3))
     (update-last-op 'my-compute mom)))
  ~ev[]
  Now let's look at the single-step macroexpansion of the above ~c[stobj-let]
  form.
  ~bv[]
  ACL2 !>:trans1 (stobj-let
                  ((child1 (fld1 mom))
                   (child2 (fld2 mom))
                   (child3 (fld3 mom)))
                  (child1 child3)
                  (let* ((child1 (update-child1-fld 'one child1))
                         (child3 (update-child3-fld 'three child3)))
                    (mv child1 child3))
                  (update-last-op 'my-compute mom))
   (PROGN$
    (LET
     ((CHILD1 (FLD1 MOM))
      (CHILD2 (FLD2 MOM))
      (CHILD3 (FLD3 MOM)))
     (DECLARE (IGNORABLE CHILD1 CHILD2 CHILD3))
     (MV-LET
        (CHILD1 CHILD3)
        (CHECK-VARS-NOT-FREE (MOM)
                             (LET* ((CHILD1 (UPDATE-CHILD1-FLD 'ONE CHILD1))
                                    (CHILD3 (UPDATE-CHILD3-FLD 'THREE CHILD3)))
                                   (MV CHILD1 CHILD3)))
        (LET* ((MOM (UPDATE-FLD1 CHILD1 MOM))
               (MOM (UPDATE-FLD3 CHILD3 MOM)))
              (CHECK-VARS-NOT-FREE (CHILD1 CHILD2 CHILD3)
                                   (UPDATE-LAST-OP 'MY-COMPUTE MOM))))))
  ACL2 !>
  ~ev[]

  If you try to evaluate a ~c[stobj-let] form directly in the top-level loop,
  rather than from within a function body, you will get an error.  The example
  above illustrates how ~c[stobj-let] may be used in function bodies; here is
  another example, presented using an edited log.
  ~bv[]
    ACL2 !>(defstobj child fld)

    Summary
    Form:  ( DEFSTOBJ CHILD ...)
    Rules: NIL
    Time:  0.02 seconds (prove: 0.00, print: 0.00, other: 0.02)
     CHILD
    ACL2 !>(defstobj parent
             (fld2 :type child)
             fld3)

    Summary
    Form:  ( DEFSTOBJ PARENT ...)
    Rules: NIL
    Time:  0.02 seconds (prove: 0.00, print: 0.00, other: 0.02)
     PARENT
    ACL2 !>(defun f (parent)
             (declare (xargs :stobjs parent))
             (stobj-let
              ((child (fld2 parent)))   ; bindings
              (child)                   ; producer variables
              (update-fld 3 child)      ; producer
              (update-fld3 'a parent))) ; consumer
    [[output omitted]]
     F
    ACL2 !>(f parent)
    <parent>
    ACL2 !>(defun check-f (parent)
             ; returns the value of the field of the child stobj
             (declare (xargs :stobjs parent))
             (stobj-let
              ((child (fld2 parent))) ; bindings
              (val)                   ; producer variables
              (fld child)             ; producer
              val))                   ; consumer
    [[output omitted]]
     CHECK-F
    ACL2 !>(check-f parent)
    3
    ACL2 !>
  ~ev[]

  Notice that the second function defined above, ~c[check-f], uses a
  ~c[stobj-let] form that returns an ordinary value: it reads a value from a
  child stobj, but does not write to the child stobj, as indicated by the lack
  of a child stobj among the producer variables.  So for that ~c[stobj-let]
  form, there is no implicit extra step.

  We labeled a ~c[stobj-let] expansion above as ``approximate'' for two
  reasons, which we give here informally.  (Now you know how to apply
  ~c[:]~ilc[trans1] to that ~c[stobj-let] call to see the precise expansion.)
  First, ~c[stobj-let] declares the stobj-let-bound variables to be
  ~c[ignorable] for the top ~c[let] bindings.  Second, and more importantly,
  ~c[stobj-let] imposes the following restrictions on the producer and
  consumer, to avoid the aliasing problem: it disallows references to the
  parent stobj in the producer and it also disallows references to any bound
  stobj (i.e., bound in the bindings) in the consumer.

  We conclude this section with examples based on a slight variation of the
  nested stobj example from the first section above.  These events can also be
  found in ACL2 community book ~c[misc/nested-stobj-tests.lisp], immediately
  under the following comment:
  ~bv[]
  ; As promised in :doc stobj-let, we begin with an example from that :doc.
  ~ev[]
  Note that some lemmas were needed in order to complete the ~il[guard] proof
  for the function ~c[update-top], which may be found in the above file; they
  are omitted below.

  First we introduce three stobjs.
  ~bv[]
    (defstobj kid1 fld1)
    (defstobj kid2 fld2)
    (defstobj mom
      (kid1-field :type kid1)
      (kid2-ar-field :type (array kid2 (5)))
      last-op)
  ~ev[]
  The next function takes a given index and a ~c[mom] stobj, and swaps the
  value stored in the stobj in ~c[mom]'s ~c[kid2-ar-field] array at that index
  with the value stored in the stobj in ~c[mom]'s ~c[kid1-field] field.
  ~bv[]
    (defun mom-swap-fields (index mom)
      (declare (xargs :stobjs mom
                      :guard (and (natp index)
                                  (< index (kid2-ar-field-length mom)))))
      (stobj-let
       ((kid1 (kid1-field mom))
        (kid2 (kid2-ar-fieldi index mom)))
       (kid1 kid2)
       (let* ((val1 (fld1 kid1))
              (val2 (fld2 kid2))
              (kid1 (update-fld1 val2 kid1))
              (kid2 (update-fld2 val1 kid2)))
         (mv kid1 kid2))
       (update-last-op 'swap mom)))
  ~ev[]
  Function ~c[mom.kid1-fld1] stores a given value in the given ~c[mom]'s
  ~c[kid1-fld1] field.
  ~bv[]
    (defun mom.kid1-fld1 (val mom)
      (declare (xargs :stobjs mom))
      (stobj-let
       ((kid1 (kid1-field mom)))
       (kid1)
       (update-fld1 val kid1)
       (update-last-op val mom)))
  ~ev[]
  We next combine the two functions above, according to an ~c[op] argument, as
  indicated by the following definition.
  ~bv[]
    (defun update-mom (op mom)
      (declare (xargs :stobjs mom))
      (cond ((and (consp op)
                  (eq (car op) 'swap)
                  (natp (cdr op))
                  (< (cdr op) (kid2-ar-field-length mom)))
             (mom-swap-fields (cdr op) mom))
            (t (mom.kid1-fld1 op mom))))
  ~ev[]
  The following checker function uses a ~c[stobj-let] form like the ones above,
  a major difference being that the producer variable is not a stobj, since it
  does not modify the input stobj, ~c[mom].
  ~bv[]
    (defun check-update-mom (index val1 val2 last-op mom)
        (declare (xargs :stobjs mom
                        :mode :program
                        :guard
                        (or (null index)
                            (and (natp index)
                                 (< index (kid2-ar-field-length mom))))))
        (and (equal (last-op mom) last-op)
             (stobj-let
              ((kid1 (kid1-field mom))
               (kid2 (kid2-ar-fieldi index mom)))
              (val) ; producer variables
              (and (equal val1 (fld1 kid1))
                   (equal val2 (fld2 kid2)))
              val)))
  ~ev[]
  Now let us run our update function to populate some fields within the ~c[mom]
  stobj.
  ~bv[]
    (let* ((mom ; set mom to (3 (x0 x1 x2 x3 x4))
             (update-mom 3 mom))
            (mom ; set mom to (x1 (x0 3 x2 x3 x4))
             (update-mom '(swap . 1) mom))
            (mom ; set mom to (7 (x0 3 x2 x3 x4))
             (update-mom 7 mom))
            (mom ; set mom to (x0 (7 3 x2 x3 x4))
             (update-mom '(swap . 0) mom))
            (mom ; set mom to (5 (7 3 x2 x3 x4))
             (update-mom 5 mom))
            (mom ; set mom to (7 (5 3 x2 x3 x4))
             (update-mom '(swap . 0) mom)))
       mom)
  ~ev[]
  Are the above values of 7, 5, and 3 as expected, with a last operation being
  a swap?  Yes!
  ~bv[]
    ACL2 !>(and (check-update-mom 0 7 5 'swap mom)
                (check-update-mom 1 7 3 'swap mom))
    T
    ACL2 !>
  ~ev[]
  Notice that above, we never tried to access two different entries of the
  array.  This can be done, but we need to bind two different stobjs to those
  fields.  Fortunately, congruent stobjs make this possible; ~pl[defstobj], in
  particular the discussion of congruent stobjs.  Since we want to bind two
  stobjs to values in the array that are isomorphic to the stobj ~c[kid2], we
  introduce a stobj congruent to ~c[kid2].
  ~bv[]
    (defstobj kid2a fld2a :congruent-to kid2)
  ~ev[]
  Then we can define our swapping function as follows.  The ~il[guard] proof
  obligation includes the requirement that the two indices be distinct, again
  to avoid an aliasing problem.
  ~bv[]
    (defun mom-swap-indices (i1 i2 mom)
      (declare (xargs :stobjs mom
                      :guard (and (natp i1)
                                  (< i1 (kid2-ar-field-length mom))
                                  (natp i2)
                                  (< i2 (kid2-ar-field-length mom))
                                  (not (equal i1 i2)))))
      (stobj-let
       ((kid2 (kid2-ar-fieldi i1 mom))
        (kid2a (kid2-ar-fieldi i2 mom)))
       (kid2 kid2a)
       (let* ((val2 (fld2 kid2))
              (val2a (fld2 kid2a))
              (kid2 (update-fld2 val2a kid2))
              (kid2a (update-fld2 val2 kid2a)))
         (mv kid2 kid2a))
       mom))
  ~ev[]
  The aforementioned community book, ~c[misc/nested-stobj-tests.lisp], contains
  a corresponding checker immediately following this definition.

  SECTION: Precise documentation for ~c[stobj-let]

  ~bv[]
  General Form:
  (stobj-let
   BINDINGS
   PRODUCER-VARIABLES
   PRODUCER
   CONSUMER)
  ~ev[]
  where ~c[PRODUCER-VARIABLES] is a non-empty true list of legal variable names
  without duplicates, ~c[PRODUCER] and ~c[CONSUMER] are expressions, and
  ~c[BINDINGS] is a list subject to the following requirements.

  ~c[BINDINGS] is a non-empty true list of tuples, each of which has the form
  ~c[(VAR ACCESSOR)] or ~c[(VAR ACCESSOR UPDATER)].  There is a stobj name,
  ~c[ST], previously introduced by ~ilc[defstobj] (not ~ilc[defabsstobj]), such
  that each ~c[accessor] is of the form ~c[(ACC ST)] or ~c[(ACCi I ST)], with
  the same stobj name (~c[ST]) for each binding.  In the case ~c[(ACC ST)],
  ~c[ACC] is the accessor for a non-array field of ~c[ST].  In the case
  ~c[(ACCi I ST)], ~c[ACCi] is the accessor for an array field of ~c[ST], and
  ~c[I] is either a variable, a natural number, a list ~c[(quote N)] where
  ~c[N] is a natural number, or a symbol introduced by ~ilc[defconst].  If
  ~c[UPDATER] is supplied, then it is a symbol that is the name of the stobj
  updater for the field of ~c[ST] accessed by ~c[ACCESSOR].  If ~c[UPDATER] is
  not supplied, then for the discussion below we consider it to be, implicitly,
  the symbol in the same package as the function symbol of ~c[ACCESSOR] (i.e.,
  ~c[ACC] or ~c[ACCi]), obtained by prepending the string ~c[\"UPDATE-\"] to
  the ~ilc[symbol-name] of that function symbol.  Finally, ~c[ACCESSOR] has a
  ~il[signature] specifying a return value that is either ~c[ST] or is stobj
  that is congruent to ~c[ST].

  If the conditions above are met, then the General Form expands to the one of
  the following expressions, depending on whether the list
  ~c[PRODUCER-VARIABLES] has one member or more than one member, respectively.
  (But see below for extra code that may be inserted if there are stobj array
  accesses in ~c[BINDINGS].)  Here we write ~c[STOBJ-LET-BOUND-VARS] for the
  list of variables ~c[VAR] discussed above, i.e., for
  ~c[(strip-cars BINDINGS)].  And, we write ~c[UPDATES] for the result of
  mapping through ~c[PRODUCER-VARIABLES] and, for each variable ~c[VAR] that
  has a binding ~c[(VAR ACCESSOR UPDATER)] in ~c[BINDINGS] (where ~c[UPDATER]
  may be implicit, as discussed above), collect into ~c[UPDATES] the tuple
  ~c[(ST (UPDATER VAR ST))].

  For ~c[PRODUCER-VARIABLES] = ~c[(PRODUCER-VAR)]:
  ~bv[]
    (let BINDINGS
      (declare (ignorable . STOBJ-LET-BOUND-VARIABLES))
      (let ((PRODUCER-VAR PRODUCER))
        (let* UPDATES
          CONSUMER)))
  ~ev[]

  Otherwise:
  ~bv[]
    (let BINDINGS
      (declare (ignorable . STOBJ-LET-BOUND-VARIABLES))
      (mv-let PRODUCER-VARS
              PRODUCER
              (let* UPDATES
                CONSUMER)))
  ~ev[]
  Moreover, ACL2 places restrictions on the resulting expression: ~c[ST] must
  not occur free in ~c[PRODUCER], and every variable in
  ~c[STOBJ-LET-BOUND-VARIABLES] must not occur free in ~c[CONSUMER].

  ~c[Stobj-let] forms can be evaluated using ordinary objects in theorem
  contexts, much as any form.  They can also, of course, appear in function
  bodis.  However, a ~c[stobj-let] form cannot be evaluated directly in the
  top-level loop or other top-level contexts for execution (such as during
  ~ilc[make-event] expansion).

  Finally, let ~c[FORM] denote the form displayed above (either case).  We
  explain how ~c[FORM] is actually replaced by an expression of the form
  ~c[(PROGN$ ... FORM)].  This expression generates an extra ~il[guard] proof
  obligation, which guarantees that no aliasing occurs from binding two
  stobj-let-bound variables to the same array access.  So fix a stobj array
  accessor ~c[ACCi] for which some stobj is bound to ~c[(ACCi I ST)] in
  ~c[BINDINGS]; we define an expression ~c[ACCi-CHECK] as follows.  Collect up
  all such index expressions ~c[I], where if ~c[I] is of the form ~c[(quote N)]
  then replace ~c[I] by ~c[N].  If the resulting list of index expressions for
  ~c[ACCi] consists solely of distinct numbers, or if it is of length 1, then
  no extra check is generated for ~c[ACCi].  Otherwise, let ~c[ACCi-CHECK] be
  the form ~c[(chk-no-duplicatesp (list I1 ... Ik))], where ~c[I1], ..., ~c[Ik]
  are the index expressions for ~c[ACCi].  Note: ~c[chk-no-duplicatesp] is a
  function that returns nil, but has a ~il[guard] that its argument is an
  ~ilc[eqlable-listp] that satisfies ~ilc[no-duplicatesp].  Finally, ~c[FORM]
  is replaced by ~c[(PROGN$ CHK1 ... CHKn FORM)], where the ~c[CHKm] range over
  all of the above ~c[ACCi-CHECK].~/~/")

(defmacro stobj-let (&whole x &rest args)
  (declare (ignore args))
  #+acl2-loop-only
  (stobj-let-fn x)
  #-acl2-loop-only
  (stobj-let-fn-raw x))

(link-doc-to stobj-let stobj nested-stobjs)

(defun push-untouchable-fn (name fn-p state doc 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 (output-in-infixp state)
       event-form
     (cond ((symbolp name)
            (cond ((null doc)
                   (msg "( PUSH-UNTOUCHABLE ~x0 ~x1)" name fn-p))
                  (t (msg "( PUSH-UNTOUCHABLE ~x0 ~x1 ...)" name fn-p))))
           ((null doc) "( PUSH-UNTOUCHABLE ...)")
           (t "( PUSH-UNTOUCHABLE ... ...)")))
   (let ((wrld (w state))
         (event-form (or event-form
                         (list* 'push-untouchable name fn-p
                                (if doc
                                    (list :doc doc)
                                  nil))))
         (names (if (symbolp name) (list name) name))
         (untouchable-prop (cond (fn-p 'untouchable-fns)
                                 (t 'untouchable-vars))))
     (er-let*
      ((doc-pair (translate-doc nil doc ctx state)))

; With no name to hang it on, we don't permit a formatted doc string.
; So the above causes an error if the string is formatted.  Otherwise,
; we ignore doc-pair.

      (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
        (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 doc 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 (output-in-infixp state)
       event-form
     (cond ((symbolp name)
            (cond ((null doc)
                   (msg "( REMOVE-UNTOUCHABLE ~x0 ~x1)" name fn-p))
                  (t (msg "( REMOVE-UNTOUCHABLE ~x0 ~x1 ...)" name fn-p))))
           ((null doc) "( REMOVE-UNTOUCHABLE ...)")
           (t "( REMOVE-UNTOUCHABLE ... ...)")))
   (let ((wrld (w state))
         (event-form (or event-form
                         (list* 'remove-untouchable name fn-p
                                (if doc
                                    (list :doc doc)
                                  nil))))
         (names (if (symbolp name) (list name) name))
         (untouchable-prop (cond (fn-p 'untouchable-fns)
                                 (t 'untouchable-vars))))
     (er-let*
      ((doc-pair (translate-doc nil doc ctx state)))

; With no name to hang it on, we don't permit a formatted doc string.
; So the above causes an error if the string is formatted.  Otherwise,
; we ignore doc-pair.

      (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)

  ":Doc-Section Miscellaneous

  show the potential definition bodies~/
  ~bv[]
  Examples:
  (show-bodies foo)
  :show-bodies foo
  ~ev[]
  A definition made using ~ilc[defun] installs a so-called ``body'' of a
  function symbol, as do certain ~c[:]~ilc[definition] rules.  Such bodies are
  used in a number of ways, including the application of ~c[:expand]
  ~il[hints]; ~pl[definition], in particular the discussion of ``body'' there,
  and ~pl[hints] for a discussion of the ~c[:expand] hint.  Also ~pl[set-body]
  for how to change which of the available definitions (among the original
  definition and appropriate ~c[:]~ilc[definition] rules) is the one that
  provides the body.  The ~c[show-bodies] command displays the available such
  bodies in an appropriate format, starting with the one that is currently used
  as the body.

  ~bv[]
  General Forms:
  (show-bodies function-symbol)
  :show-bodies function-symbol
  ~ev[]~/~/"

  (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
                      (getprop fn 'def-bodies nil 'current-acl2-world wrld)
                      (getprop fn 'lemmas nil 'current-acl2-world 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 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
   (if (output-in-infixp state)
       event-form
     (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
           (getprop fn 'def-bodies nil 'current-acl2-world 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

(defdoc trace
  ":Doc-Section Trace

  tracing functions in ACL2~/

  ACL2 provides a trace utility, ~ilc[trace$], with corresponding reverse
  operation ~ilc[untrace$].  These can be used without any dependence on the
  underlying Lisp utility, and are the tracing utilities of choice in ACL2;
  ~pl[trace$] and ~pl[untrace$].

  However, for advanced users we note that the underlying host Lisp may also
  provide a trace utility, ~c[trace], and corresponding ~c[untrace].  Moreover,
  these have been modified in the case that the host Lisp is GCL, Allegro CL,
  or CCL (OpenMCL), to provide limited support for ~c[:entry], ~c[:exit], and
  perhaps ~c[:cond] keywords, to hide certain large data structures (world,
  enabled structure, rewrite constant), and to trace executable counterparts.
  See source files ~c[*-trace.lisp].  For the above Lisps, you can invoke the
  original ~c[trace] and ~c[untrace] by invoking ~c[old-trace] and
  ~c[old-untrace], respectively, in raw Lisp rather than in the normal ACL2
  loop.~/~/

  :cite acl2::time-tracker
  :cited-by acl2::other
  :cited-by acl2::programming")

#-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.

         (getprop name 'stobjs-out nil 'current-acl2-world (w state))))
    (and stobjs-out
         (length stobjs-out))))

(defun first-trace-printing-column (state)

; This returns the first column after the trace prompt ("n> " or "<n ").

; Warning: Keep this in sync with custom-trace-ppr.

  (cond ((< (f-get-global 'trace-level state) 10)
         (1+ (* 2 (f-get-global 'trace-level state))))
        ((< (f-get-global 'trace-level state) 100)
         22)
        ((< (f-get-global 'trace-level state) 1000)
         23)
        ((< (f-get-global 'trace-level state) 10000)
         24)
        (t 25)))

(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 state))
        (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 state global
; '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 state global '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)
      (increment-trace-level))
    (let ((trace-level (f-get-global 'trace-level *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)
             (format *trace-output* "~s~%" x))
            (t (trace-ppr x evisc-tuple msgp *the-live-state*)))
      (when (not (eq direction :in))
        (f-put-global 'trace-level
                      (1-f trace-level)
                      *the-live-state*))
      (finish-output *trace-output*))))

(defun *1*defp (trace-spec wrld)
  (let ((fn (car trace-spec)))
    (not (eq (getprop fn 'formals t 'current-acl2-world 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 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 (caar user-stobj-alist) nil))
                 (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)

  ":Doc-Section Trace

  set the trace evisc tuple~/

  A trace evisc-tuple, which is set by this utility, provides a means to
  restrict printing during tracing.  ~l[evisc-tuple] for an introduction to
  evisc-tuples; also ~pl[set-evisc-tuple] and ~pl[set-iprint].

  By default the ACL2 ~il[trace] mechanism, ~ilc[trace$], automatically deals
  with stobjs, the logical world, and certain other large structures.
  ~l[trace$], in particular the documentation of ~c[trace$] option ~c[:hide].
  However, even with that default behavior you may want to restrict what is
  printed according to the print-level and print-length of an evisc-tuple;
  ~pl[evisc-tuple].

  ~bv[]
  Examples:

  ; Set trace evisc tuple to a standard value, using current Lisp *print-level*
  ; and *print-length* variables:
  (set-trace-evisc-tuple t state)

  ; Set trace evisc tuple back to its default:
  (set-trace-evisc-tuple nil state)

  ; Set trace evisc tuple to restrict print-level to 3 and print-length to 4,
  ; while hiding the logical world and suitably printing stobjs even if trace$
  ; option ``:hide nil'' is used.  (Note: calling ~c[trace-evisceration-alist]
  ; directly requires removing this function as `untouchable', which requires a
  ; trust tag; ~pl[remove-untouchable].)
  (set-trace-evisc-tuple
   (evisc-tuple 3 4 (trace-evisceration-alist state) nil)
   state)~/

  General Forms:

  (set-trace-evisc-tuple nil state) ; trace evisc-tuple set to standard value
  (set-trace-evisc-tuple   t state) ; trace evisc-tuple set to hide the logical
                                    ;   world and deal with stobjs even when
                                    ;   trace$ option ``:hide nil'' is supplied
  (set-trace-evisc-tuple evisc-tuple state)
                                    ; tracing set to use indicated evisc-tuple
  ~ev[]

  ~l[trace$] for a discussion of ACL2 tracing.  The ~il[evisc-tuple] used by
  that trace utility is the one last installed by ~c[set-trace-evisc-tuple]
  (or by ~ilc[set-evisc-tuple] for the trace-evisc-tuple) ~-[] initially to the
  default of ~c[nil] ~-[] unless overriden by trace option ~c[:evisc-tuple].

  ~st[Remark].  If you use value ~c[t], then ACL2 will ensure that the logical
  world and stobjs are kept up-to-date in the trace evisc-tuple."

  #+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)

(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 arglist state))
                                  (:exit
                                   '(traced-fn 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$."
                        vars
                        kwd))
                   (t (value nil))))))

(defun trace$-value-msgp (x)
  (and (consp x)
       (keywordp (car x))
       (or (and (member-eq (car x) '(:fmt :fmt!))
                (consp (cdr x))
                (null (cddr x)))
           (er hard 'trace$
               "Illegal :ENTRY value.  A legal :ENTRY value starting with a ~
                keyword must be of the form (:FMT x).  The :ENTRY value ~x0 ~
                is therefore illegal."
               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))
                  (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))
                  (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 'memoize-off))

(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))
         #+hons (memo-entry (memoizedp-raw fn)))
    #+hons
    (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)
      #+hons
      (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
                (delete-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~s."
              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 increment-trace-level ()
  (f-put-global 'trace-level
                (1+f (f-get-global 'trace-level *the-live-state*))
                *the-live-state*))

#-acl2-loop-only
(defun trace$-def (arglist def trace-options predefined multiplicity ctx)
  #-hons (declare (ignore ctx))
  (let* ((state-bound-p (member-eq 'state arglist))
         (fn (car def))
         (cond-tail (assoc-keyword :cond trace-options))
         (cond (cadr cond-tail))
         (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 (if entry-msgp (cadr entry) entry))
         (exit  (or (cadr (assoc-keyword :exit  trace-options))
                    (list 'cons (kwote fn) 'values)))
         (exit-msgp (trace$-value-msgp exit))
         (exit (if exit-msgp (cadr exit) exit))
         (notinline-tail (assoc-keyword :notinline trace-options))
         (notinline-nil (and notinline-tail
                             (null (cadr notinline-tail))))
         #+hons (memo-entry (memoizedp-raw fn))
         (notinline-fncall
          (cond (notinline-tail
                 #+hons (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))))
                 #-hons (eq (cadr notinline-tail) :fncall))
                #+hons
                (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)))))
    #+hons
    (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.

; Note by the way that under memoize-off, tracing will be defeated.  If this
; presents a big problem then we can reconsider the design of how tracing and
; memoization interact.

      (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))
                                (declare (ignorable traced-fn arglist))
                                ,cond))))
           ,(trace$-when-gcond
             gcond
             `(let ((arglist ,garglist)
                    (traced-fn ',fn))
                (declare (ignorable traced-fn arglist))
                (custom-trace-ppr :in
                                  ,(if hide
                                       `(trace-hide-world-and-state ,entry)
                                     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 and TRACED-FN be bound in the
; right order.  For example, if we bind ARGLIST before VALUES but ARGLIST is a
; formal, then the 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.

                   #+acl2-mv-as-values
                   (multiple-value-list ,new-body)
                   #-acl2-mv-as-values
                   (cons ,new-body
                         ,(cond ((eql multiplicity 1) nil)
                                (t `(mv-refs ,(1- multiplicity))))))

; 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))
             (declare (ignorable value values traced-fn arglist))
             ,(trace$-when-gcond
               gcond
               `(custom-trace-ppr :out
                                  ,(if hide
                                       `(trace-hide-world-and-state ,exit)
                                     exit)
                                  ,(or gevisc-tuple evisc-tuple)
                                  ,exit-msgp))
             #+acl2-mv-as-values
             (values-list values)
             #-acl2-mv-as-values
             (mv ,@(mv-nth-list 'values 0 multiplicity))))))))

#-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))
    #+hons
    (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 (getprop fn 'stobj-function nil
                                  'current-acl2-world wrld))
         (form (cltl-def-from-name1 fn stobj-function t wrld)))
    (oneify-cltl-code
     (cond ((or (getprop fn 'constrainedp nil 'current-acl2-world wrld)
                (getprop fn 'non-executablep nil 'current-acl2-world 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
               (getprop fn 'stobj-function nil 'current-acl2-world 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 (getprop fn 'constrainedp nil 'current-acl2-world wrld)
                       (let ((formals (getprop fn 'formals t
                                               'current-acl2-world 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
                               (getprop fn 'formals t 'current-acl2-world
                                        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)
          (getprop fn 'predefined nil 'current-acl2-world wrld)))
    (cond
     ((eq def :macro)
      (assert$
       stobj-function
       (cond
        ((getprop stobj-function 'absstobj-info nil 'current-acl2-world 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)
      (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

; ACL2 has redefined the underlying Lisp trace for GCL and Allegro CL so that
; they recognize the :exit keyword, and we take advantage of that here.  ACL2
; has also redefined the :exit keyword for CCL, but since CCL uses feature
; acl2-mv-as-values, there is no need to specify :exit here.

                        #+(or gcl allegro)
                        (let ((multiplicity
                               (or (cadr (assoc-keyword :multiplicity
                                                        trace-options))
                                   (trace-multiplicity fn state))))
                          (cond
                           ((and multiplicity
                                 (not (assoc-keyword :exit trace-options)))
                            (append `(:exit
                                      (cons (car values)
                                            (mv-refs ,(1- multiplicity))))
                                    trace-options-1))
                           (t trace-options-1)))
                        #-(or gcl allegro)
                        (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 all-keywords-p (keywords)
  (if (consp keywords)
      (and (keywordp (car keywords))
           (all-keywords-p (cdr keywords)))
    (null keywords)))

(defun first-assoc-keyword (keys x)
  (declare (xargs :guard (and (keyword-value-listp x)
                              (all-keywords-p 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)

  ":Doc-Section Trace

  trace function evaluations~/
  ~bv[]
  Examples:
  (trace$ foo bar)     ; trace foo and bar
  (trace$)             ; return current trace info (no new tracing specified)
  (trace$ (foo :entry  ; trace foo, printing first actual parameter upon entry
               (car arglist)))
  (trace$ (foo :exit   ; trace foo, using fmt to print upon exit
               (:fmt (msg \"Exiting FOO with ~~x0\"
                          value))))
  (trace$ (foo :native t))

  General Forms:
  (trace$ spec1 spec2 ... specn) ; n >= 1
  (trace$)
  ~ev[]
  where the ~c[speci] are trace specs, as described below.

  ~c[Trace$] installs alternate code for the indicated functions that prints
  information upon entry to, and exit from, calls of the functions.  For an
  alternate tracing utility used for educational purposes in ACL2s
  (~url[http://acl2s.ccs.neu.edu/acl2s/doc/]), see community book
  ~c[books/misc/trace-star.lisp].

  From a logical perspective all trace printing is a fiction.  (But ~pl[trace!]
  for a way to get around this and modify ~il[state].)  For a related fiction,
  ~pl[cw].  ~c[(Trace$)] returns the list of currently-active trace specs,
  while the application of ~c[trace$] to at least one argument returns the list
  of its arguments that are successfully acted on.

  Output from ~ilc[trace$] normally goes to the screen, i.e., to
  ~ilc[standard-co].  But it can be redirected to a file;
  ~pl[open-trace-file].

  ~l[untrace$] for how to undo the effect of ~ilc[trace$].  Also ~pl[trace] for
  mention of modifications made to raw Lisp trace, which is accessible (as
  described below) using the ~c[:native] keyword.

  Note that when ~c[trace$] is applied to a function without option
  ~c[:native], that function's declarations and documentation are discarded.~/

  Next, we introduce tracing with some examples.  After that, we provide
  reference documentation for individual trace options allowed in a trace spec.
  Note that although our example focuses on user-defined functions, ~c[trace$]
  can also be applied to built-in functions, though perhaps only system hackers
  should take advantage of this observation.

  We begin by illustrating the simplest sort of trace spec: a function symbol.
  For example, the form ~c[(trace$ foo bar)] directs the tracing of functions
  ~c[foo] and ~c[bar] by virtue of the two trace specs ~c[foo] and ~c[bar].  We
  can see tracing in action by first defining:
  ~bv[]
  (defun f (x)
    (cons x x))

  (defun g (x)
    (list (f x) 3))
  ~ev[]

  The following log then illustrates tracing of these two functions.  Notice
  that before ~il[guard]s have been verified, the so-called ``*1*'' functions
  (sometimes called ``executable counterpart functions'' or ``logic
  functions'') are called but the corresponding raw Lisp functions are not; but
  after guard verification of ~c[f], the raw Lisp counterpart of ~c[f] is
  indeed called.  (~l[guard] and ~pl[guard-evaluation-examples-log].)
  ~bv[]
  ACL2 !>(trace$ f g)
   ((F) (G))
  ACL2 !>(g 7)
  1> (ACL2_*1*_ACL2::G 7)
    2> (ACL2_*1*_ACL2::F 7)
    <2 (ACL2_*1*_ACL2::F (7 . 7))
  <1 (ACL2_*1*_ACL2::G ((7 . 7) 3))
  ((7 . 7) 3)
  ACL2 !>(verify-guards f)

  Computing the guard conjecture for F....

  The guard conjecture for F is trivial to prove.  F is compliant with
  Common Lisp.

  Summary
  Form:  ( VERIFY-GUARDS F)
  Rules: NIL
  Warnings:  None
  Time:  0.00 seconds (prove: 0.00, print: 0.00, other: 0.00)
   F
  ACL2 !>(g 7)
  1> (ACL2_*1*_ACL2::G 7)
    2> (ACL2_*1*_ACL2::F 7)
      3> (F 7)
      <3 (F (7 . 7))
    <2 (ACL2_*1*_ACL2::F (7 . 7))
  <1 (ACL2_*1*_ACL2::G ((7 . 7) 3))
  ((7 . 7) 3)
  ACL2 !>
  ~ev[]

  The following example introduces trace specs other than function symbols.
  Consider the following definition.
  ~bv[]
  (defun fact (n)
    (declare (xargs :guard (natp n)))
    (if (zp n)
        1
      (* n (fact (1- n)))))
  ~ev[]
  The following log illustrates the use of trace options ~c[:cond] (condition
  for entering trace), ~c[:entry] (what to print on entry), and ~c[:exit] (what
  to print on exit).  The reason for two calls on argument 4 is that we are
  seeing such calls for the executable counterpart of ~c[fact] and also its raw
  Lisp function.
  ~bv[]
  ACL2 !>(trace$ (fact :cond (evenp (car arglist))
                       :entry (cons 'factorial-call arglist)
                       :exit (car values)))
   ((FACT :COND (EVENP (CAR ARGLIST))
          :ENTRY (CONS 'FACTORIAL-CALL ARGLIST)
          :EXIT (CAR VALUES)))
  ACL2 !>(fact 4)
  1> (FACTORIAL-CALL 4)
    2> (FACTORIAL-CALL 4)
      3> (FACTORIAL-CALL 2)
        4> (FACTORIAL-CALL 0)
        <4 1
      <3 2
    <2 24
  <1 24
  24
  ACL2 !>
  ~ev[]
  Notice that ~c[VALUES] above is the list of all values returned, which is a
  one-element list unless ~ilc[mv] return is used, as illustrated in the
  following example, after defining: ~c[(defun two-vals (x) (mv x 7))].
  ~bv[]
  ACL2 !>(trace$ two-vals)
   ((TWO-VALS))
  ACL2 !>(two-vals 3)
  1> (ACL2_*1*_ACL2::TWO-VALS 3)
  <1 (ACL2_*1*_ACL2::TWO-VALS 3 7)
  (3 7)
  ACL2 !>(verify-guards two-vals)

  Computing the guard conjecture for TWO-VALS....

  The guard conjecture for TWO-VALS is trivial to prove, given the :executable-
  counterpart of CONS.  TWO-VALS is compliant with Common Lisp.

  Summary
  Form:  ( VERIFY-GUARDS TWO-VALS)
  Rules: ((:EXECUTABLE-COUNTERPART CONS))
  Warnings:  None
  Time:  0.00 seconds (prove: 0.00, print: 0.00, other: 0.00)
   TWO-VALS
  ACL2 !>(two-vals 3)
  1> (ACL2_*1*_ACL2::TWO-VALS 3)
    2> (TWO-VALS 3)
    <2 (TWO-VALS 3 7)
  <1 (ACL2_*1*_ACL2::TWO-VALS 3 7)
  (3 7)
  ACL2 !>
  ~ev[]

  We now document all of the options that may appear in a trace spec.  A trace
  spec with options is of the form
  ~bv[]
  (fn :kwd1 val1 :kwd2 val2 ... :kwdn valn)
  ~ev[]
  and here we document each legal keyword ~c[:kwdi] and corresponding expected
  value ~c[vali].  Note that ~c[trace$] is intended primarily for functions
  defined in the ACL2 command loop (~pl[lp]).  If you want to trace a function
  that defined in raw Lisp, then you can use option ~c[:native] (see below),
  but then many other ~c[trace$] options will not be available to you: all of
  them except ~c[:multiplicity] and ~c[:native] itself will be passed directly
  to the ~c[trace] utility of the underlying Common Lisp.

  ~c[:COND], ~c[:ENTRY], and ~c[:EXIT]

  ~st[Introduction].  For each of these three options, the value is a
  (user-level) term, except that for ~c[:entry] and ~c[:exit] the value can be
  of the form ~c[(:fmt u)] or ~c[(:fmt! u)], where ~c[u] is a user-level term.
  We skip these two latter cases for now and return to them later.  Then the
  indicated term is evaluated as indicated in the next paragraph, and if the
  ~c[:cond] term is omitted or evaluates to non-~c[nil], then the value of the
  ~c[:entry] term is printed on entry and the value of the ~c[:exit] term is
  printed on exit.  By default, where ~c[:entry] is omitted or is specified as
  ~c[nil], the value printed for ~c[:entry] is the list obtained by consing the
  calling function symbol onto the list of actual parameters: in the notation
  described below, this is ~c[(cons TRACED-FN ARGLIST)].  Similarly, the
  default for printing at the exit of the function call, i.e. where ~c[:exit]
  is omitted or is specified as ~c[nil], is ~c[(cons TRACED-FN VALUES)] where
  ~c[VALUES] is the list of values returned as described below.

  In the evaluations of the term described below upon a call of ~c[fn], each
  formal parameter of the definition of ~c[fn] will be bound to the
  corresponding actual of the call, the variable ~c[ARGLIST] will be bound to
  the list of actuals, and the variable ~c[TRACED-FN] will be bound to the
  function being called (either ~c[fn] or its executable counterpart function;
  see above).  Additionally in the case of ~c[:exit], the variable ~c[VALUES]
  will be bound to the multiple values returned (thus, a one-element list if
  ~ilc[mv] is not used in the return).  Also for ~c[:exit], we bind ~c[VALUE]
  to the logical value returned, i.e., to the suitable list of values returned
  in the ~ilc[mv] case and otherwise to the single value returned.  So in the
  ~c[mv] case, ~c[VALUE] is the same as ~c[VALUES], and otherwise ~c[VALUE] is
  ~c[(car VALUES)].  Other than these variables and ~ilc[STATE], no other
  variable may occur in the term, whose value must be a single non-~ilc[stobj]
  value, unless there is an active trust tag (~pl[defttag]).

  Now suppose ~c[fn] is called.  First: If ~c[:cond] is supplied and the result
  of evaluating the ~c[:cond] term is ~c[nil], then no tracing is done.
  Otherwise tracing proceeds as follows.  First the ~c[:entry] form is
  evaluated, and the result is printed.  Then the call of ~c[fn] is evaluated.
  Finally the ~c[:exit] term is evaluated and the result is printed.  As
  indicated above, the default for the ~c[:entry] term if omitted or explicitly
  ~c[nil] is ~c[(cons TRACED-FN ARGLIST)], and the default for the ~c[:exit]
  term if omitted or explicitly ~c[nil] is ~c[(cons TRACED-FN VALUES)].

  Note that if the function has a formal named ~c[ARGLIST], then ~c[ARGLIST]
  will nevertheless refer to the entire list of formals, not the single formal
  named ~c[ARGLIST]; similarly for ~c[TRACED-FN], and additionally for
  ~c[VALUE] and ~c[VALUES] in the case of ~c[:exit].

  As mentioned above, for each of ~c[:entry] and ~c[:exit], a value of ~c[nil]
  specifies the default behavior.  If you really want a value of ~c[nil], use a
  non-~c[nil] form that evaluates to ~c[nil], for example ~c[(car nil)] or
  ~c['nil].  However, for ~c[:cond] a value of ~c[nil] means what it says: do
  not evaluate the ~c[:entry] or ~c[:exit] forms.

  Finally we discuss the case that the ~c[:entry] or ~c[:exit] term is of the
  form ~c[(:fmt u)] or ~c[(:fmt! u)].  In these cases, the term ~c[u] is
  evaluated as described above to produce a value, say ~c[msg], but instead of
  printing ~c[msg] directly, ACL2 calls ~c[fmt1] using the string ~c[\"~~@0\"]
  and the alist that binds just character ~c[#\\0] to ~c[msg].  The following
  example illustrates this point, where ~c[fact] is defined as above.  Also
  ~pl[fmt].  Note that ~c[(msg string . vals)] produces a value suitable for a
  ~c[\"~~@\"] directive to the ~c[fmt] family of print functions.
  ~bv[]
  ACL2 !>(trace$
          (fact
           :entry (:fmt (msg \"Tracing ~~x0 on ~~x1\" traced-fn arglist))
           :exit (car values)))
   ((FACT :ENTRY (:FMT (MSG \"Tracing ~~x0 on ~~x1\" TRACED-FN ARGLIST))
          :EXIT (CAR VALUES)))
  ACL2 !>(fact 3)
  1> Tracing ACL2_*1*_ACL2::FACT on (3)
    2> Tracing FACT on (3)
      3> Tracing FACT on (2)
        4> Tracing FACT on (1)
          5> Tracing FACT on (0)
          <5 1
        <4 1
      <3 2
    <2 6
  <1 6
  6
  ACL2 !>
  ~ev[]
  If ~c[:fmt!] is used instead of ~c[:fmt], then indentation as is the prefix
  string, ~c[\"n> \"] or ~c[\"<n \"].  The following example illustrates the
  use of ~c[:fmt!].
  ~bv[]
  ACL2 !>(trace$
          (fact
           :entry (:fmt! (msg \"Tracing ~~x0 on ~~x1\" traced-fn arglist))
           :exit (:fmt! (msg \"From input ~~x0: ~~x1\"
                             (car arglist) (car values)))))
   ((FACT :ENTRY (:FMT! (MSG \"Tracing ~~x0 on ~~x1\" TRACED-FN ARGLIST))
          :EXIT (:FMT! (MSG \"From input ~~x0: ~~x1\" (CAR ARGLIST)
                            (CAR VALUES)))))
  ACL2 !>(fact 3)
  Tracing ACL2_*1*_ACL2::FACT on (3)
  Tracing FACT on (3)
  Tracing FACT on (2)
  Tracing FACT on (1)
  Tracing FACT on (0)
  From input 0: 1
  From input 1: 1
  From input 2: 2
  From input 3: 6
  From input 3: 6
  6
  ACL2 !>
  ~ev[]
  Here is the same example, with user-managed indentation.
  ~bv[]
  ACL2 !>(trace$
          (fact
           :entry (:fmt! (msg \"~~t0Tracing ~~x1 on ~~x2\"
                              (+ 3 (* 2 (@ trace-level)))
                              traced-fn arglist))
           :exit (:fmt! (msg \"~~t0From input ~~x1: ~~x2\"
                             (1+ (* 2 (@ trace-level)))
                             (car arglist) (car values)))))
   ((FACT :ENTRY (:FMT! (MSG \"~~t0Tracing ~~x1 on ~~x2\"
                             (+ 3 (* 2 (@ TRACE-LEVEL)))
                             TRACED-FN ARGLIST))
          :EXIT (:FMT! (MSG \"~~t0From input ~~x1: ~~x2\"
                            (1+ (* 2 (@ TRACE-LEVEL)))
                            (CAR ARGLIST)
                            (CAR VALUES)))))
  ACL2 !>(fact 3)
     Tracing ACL2_*1*_ACL2::FACT on (3)
       Tracing FACT on (3)
         Tracing FACT on (2)
           Tracing FACT on (1)
             Tracing FACT on (0)
             From input 0: 1
           From input 1: 1
         From input 2: 2
       From input 3: 6
     From input 3: 6
  6
  ACL2 !>
  ~ev[]

  ~st[ADVANCED OPTIONS] (alphabetical list)

  ~c[:COMPILE]

  The tracing of ~c[fn] installs a substitute definition of ~c[fn] that prints
  trace information.  If the ~c[:compile] option is omitted or has value
  ~c[:same], then the new definition will be compiled if and only if the
  existing definition is already compiled.  Otherwise, the new definition will
  be compiled exactly when the value of ~c[:compile] is not ~c[nil].

  ~c[:DEF], ~c[:MULTIPLICITY]

  ACL2's ~c[trace$] mechanism often needs to know the number of outputs of a
  traced function, in the sense of ~ilc[mv].  If you trace a function that was
  not defined inside the ACL2 loop (hence you are using the ~c[:native]
  option), or if you provide an alternative definition using option ~c[:def]
  (see below) and the new definition changes the number of values returned,
  then a natural number value for ~c[:multiplicity] informs the trace utility
  of the number of expected outputs of the function being traced.  In the case
  that ~c[:native] is supplied, the effect of a non-~c[nil] ~c[:multiplicity]
  value depends on the host Lisp.  In the case of Lisps for which ACL2 uses the
  built-in Lisp mechanism for returning multiple values (~pl[mv]), which are
  CCL and threaded SBCL as of June, 2010, ~c[:multiplicity] is not needed and
  is ignored with ~c[:native t].  For GCL and Allegro CL, ~c[:multiplicity] is
  used to generate a suitable ~c[:exit] form if the ~c[:exit] keyword was not
  already supplied.  For the other Lisps, the ~c[:multiplicity] value is
  treated essentially as 1 whether it is supplied or not, because we do not
  know how to pass suitable information based on this value to the host Lisp's
  built-in tracing mechanism.

  Note that even supplying a ~c[:multiplicity] option does not change the
  meaning of the variable ~c[values].  See the discussion of ~c[:native]
  below.

  A useful option can be to supply a definition as the value of ~c[:def].
  (Again, note that if ~c[:native] is used, then all options other than
  ~c[:multiplicity] are passed directly to the underlying Lisp; in particular,
  ~c[:def] will have no effect with ~c[:native] except in the unlikely case
  that the raw Lisp provides some sort of support for ~c[:def].)  Note that
  this definition should be like a ~ilc[defun] form, but without the leading
  ~c[defun] symbol; and it should define the function symbol being traced, with
  the same formal parameter list.  However, tracing of the so-called
  ``executable counterpart'' of a function (sometimes referred to as the ``*1*
  function'', for evaluation in the ACL2 loop; ~pl[guards] for related
  discussion) is not sensitive to the ~c[:def] option; rather, if a function
  has an executable counterpart then that executable counterpart is traced.

  ~c[:EVISC-TUPLE]

  The printing described above is, by default, done using the current default
  trace evisc-tuple, which can be set using ~ilc[set-trace-evisc-tuple] (for
  the shape of this tuple, ~pl[evisc-tuple]); ~pl[set-trace-evisc-tuple].
  This tuple is based by default on the raw Lisp variables ~c[*print-level*]
  and ~c[*print-length*], and will hide the ACL2 ~c[world] and handle
  ~il[stobj]s appropriately.  You may override this default by supplying an
  evisc tuple with the ~c[:evisc-tuple] argument in your trace spec.  Be
  careful to supply a valid evisc-tuple, or you may get a raw Lisp error!

  A special value, ~c[:print], is useful if you are doing system hacking that
  can produce objects that are not valid ACL2 objects, such as raw Lisp arrays
  or objects in supporting packages not visible in the ACL2 read-eval-print
  loop.  If you supply ~c[:evisc-tuple :print], then the printing described
  above will be done with raw Lisp printing rather than ACL2 printing:
  specifically, with ~c[(format *trace-output* \"~s~%\" x)], where ~c[x] is the
  value to be printed.

  A second special value for ~c[:evisc-tuple], ~c[:no-print], avoids printing
  the values of the ~c[:entry] and ~c[:exit] forms (or their defaults, if not
  specified).  This option is of use for side effects; for an example see
  community book ~c[books/misc/wet.lisp].

  Note that if ~c[:evisc-tuple X] is supplied, then the form ~c[X] will be
  evaluated before the function body is entered.  You can thus pull some tricks
  to print extra information before the ~c[:entry] form is evaluated, for
  example as follows for a factorial function, ~c[fact].
  ~bv[]
  ACL2 !>(trace$ (fact :evisc-tuple
                       (prog2$ (cw \"~~|**** HERE IS CW ****~~|\")
                               nil)))
   ((FACT :EVISC-TUPLE (PROG2$ (CW \"~~|**** HERE IS CW ****~~|\")
                               NIL)))
  ACL2 !>(fact 3)
  **** HERE IS CW ****
  1> (ACL2_*1*_ACL2::FACT 3)
  **** HERE IS CW ****
    2> (ACL2_*1*_ACL2::FACT 2)
  **** HERE IS CW ****
      3> (ACL2_*1*_ACL2::FACT 1)
  **** HERE IS CW ****
        4> (ACL2_*1*_ACL2::FACT 0)
        <4 (ACL2_*1*_ACL2::FACT 1)
      <3 (ACL2_*1*_ACL2::FACT 1)
    <2 (ACL2_*1*_ACL2::FACT 2)
  <1 (ACL2_*1*_ACL2::FACT 6)
  6
  ACL2 !>
  ~ev[]

  ~c[:FORMALS]

  Normally ACL2 can figure out the formals for a given function.  This is
  always the case for functions defined in the ACL2 command loop and when
  option ~c[:def] is supplied.  If neither of these cases applies then you can
  still trace a function (even without using the ~c[:native] option) by
  supplying option ~c[:notinline :fncall], but you will still need to supply
  the list of formal parameters.  The value of the ~c[:formals] option should
  be the list of formals in this case.

  ~c[:HIDE]

  The default value for this advanced option is ~c[t], which causes ~il[stobj]s
  and the logical ~il[world] to be printed as single symbols, along with
  certain large structures of interest to developers (rewrite contants, enabled
  structures, and event and command index structures).  If however the value
  ~c[nil] is supplied, then this default behavior is defeated.  In that case,
  you can still arrange to print the logical world as a symbol and to print
  ~il[stobj]s without breaking the trace printing: ~pl[set-trace-evisc-tuple]
  for how to do this globally, or similarly use the ~c[:evisc-tuple] option to
  ~c[trace$] to do this with a single trace spec.  Note however that with value
  ~c[nil] specified for ~c[:hide], such use of an evisc-tuple will not deal
  properly with local stobjs (~pl[with-local-stobj]) or stobjs bound by
  ~ilc[stobj-let], or with the aforementioned large structures other than the
  logical ~il[world].

  ~c[:NATIVE]

  If ~c[:native] is supplied with a non-~c[nil] value, then the trace spec is
  passed to the native Lisp trace (after removing the ~c[:native] option).  A
  trust tag (~pl[defttag]) is required in order to use this option, because no
  syntactic check is made on the ~c[:cond], ~c[:entry], or ~c[:exit] forms --
  arbitrary raw Lisp may occur in them!

  Note that by ``native Lisp trace'' we mean the currently installed ~c[trace].
  As discussed briefly elsewhere (~pl[trace]), ACL2 has modified that trace to
  be more useful if the underlying host Lisp is GCL, Allegro CL, or CCL
  (OpenMCL).  If you need the original trace utility supplied for those Lisps,
  quit the ACL2 loop with ~c[:q] and call ~c[old-trace] and ~c[old-untrace] in
  raw Lisp where you would otherwise call ~c[trace] and ~c[untrace].  Note that
  the original trace utility supplied with a given Lisp will not hide the ACL2
  logical ~il[world] or give special treatment to ~il[stobj]s.

  It is important to understand that if ~c[:native t] is specified, then all
  other options are interpreted by the native Lisp trace.  For example, that
  trace probably has no understanding of the use of ~c[:fmt] described above
  for ~c[:entry] or ~c[:exit].  Indeed, the native trace may not even accept
  any of ~c[:cond], ~c[:entry] or ~c[:exit], let alone any of the advanced
  options!  Moreover, if ~c[:native t] is specified, then even a
  ~c[:multiplicity] option does not provide the meaning of the variable
  ~c[values] that one might desire.  In GCL for example, in the case of an
  ~ilc[mv] return of a function defined only in raw Lisp (not in ACL2), this
  variable will be bound to a list containing only the first result.

  ~c[:NOTINLINE]

  By default, a new definition installed by ~c[trace$] will include a
  ~c[notinline] declaration so that recursive calls will always be traced.  To
  avoid this declaration, supply value ~c[nil].

  A special value for ~c[:notinline], ~c[:fncall], will cause the traced
  function to call its original definition.  Without this special value, the
  new installed definition for the traced function will include the body of the
  original definition.  This ~c[:fncall] behavior is the default only in the
  following cases:
  ~bq[]
  o for functions whose definitions are built into ACL2;

  o for functions that have been added (using a trust tag, an advanced feature,
  so most users can probably ignore this case) to either of the ~ilc[state]
  global variables ~c[program-fns-with-raw-code] or
  ~c[logic-fns-with-raw-code];

  o (`HONS' extension only; ~pl[hons-and-memoization]) for ~ilc[memoize]d
  functions.~eq[]

  The legal values for ~c[:notinline] are ~c[t] (the default for other than the
  cases displayed above), ~c[nil], and ~c[:fncall].  (Except: For the 'HONS'
  extension, only ~c[:fncall] is legal.)

  ~st[Remarks].

  (1) If some of the given trace specs have errors, then ~c[trace$] will
  generally print error messages for those but will still process those that do
  not have errors.  The value returned will indicate the trace specs that were
  processed successfully.

  (2) If you certify or include a book that redundantly defines a function that
  is currently traced, then tracing behavior may disappear if a compiled
  definition is installed for the function or its in-the-logic (so-called
  `*1*') counterpart.

  (3) Some predefined functions are called during tracing.  In order to avoid
  infinite loops, such calls of traced predefined functions will be made using
  the original predefined functions, not using their code installed by
  ~c[trace$].~/"

  (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)
        (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)
                      (state-global-let*
                       ((inhibit-output-lst ; eliminate output from :ubt!
                         (add-to-set-eq 'temporary
                                        (f-get-global 'inhibit-output-lst
                                                      state))))
                       (ubt! ',label)))
                    :ld-verbose nil
                    :ld-prompt nil
                    :ld-post-eval-print nil
                    :ld-error-action :error))
               (value :invisible))))

(defmacro trace! (&rest fns)

  ":Doc-Section Trace

  trace the indicated functions after creating an active trust tag~/
  ~bv[]
  Example:
  (trace! (fact :native t :entry *foo*))~/

  General Form:
  (trace! spec1 ... specn)
  ~ev[]
  where the ~c[fni] are suitable arguments to ~ilc[trace$].

  ~c[Trace!] is a version of ~ilc[trace$] that avoids the need for an
  already-active trust tag (or ``ttag''; ~pl[defttag]), as explained below.
  ~l[trace$] for when a trust tag can be necessary.

  ~l[untrace$] for how to undo the effect of ~ilc[trace!].

  The evaluation of a ~c[trace!] form causes temporary creation of an active
  trust tag, ~c[:trace!], followed by the corresponding ~c[trace$] form.  The
  trust tag will disappear when the call to ~c[trace!] completes.  Even though
  ~c[trace!] will remove its temporary ttag, it will still print a
  ``~c[TTAG NOTE]'', which indicates that the session is suspect.  ~l[defttag]
  and ~pl[ttags-seen] for further remarks on this issue.

  Because of the active trust tag, it is possible to do things with ~c[trace!]
  that are useful but without logical justification.  Below is an example of
  how to use ~c[trace!] to cause a function call to change ~il[state], even
  though the function does not take ~ilc[state] as a parameter.

  ~bv[]
  ACL2 !>(defun fact (n)
           (declare (xargs :guard (natp n) :verify-guards nil))
           (if (zp n)
               1
             (* n (fact (1- n)))))

  The admission of FACT is trivial, using the relation O< (which is known
  to be well-founded on the domain recognized by O-P) and the measure
  (ACL2-COUNT N).  We observe that the type of FACT is described by the
  theorem (AND (INTEGERP (FACT N)) (< 0 (FACT N))).  We used the :compound-
  recognizer rule ZP-COMPOUND-RECOGNIZER and primitive type reasoning.

  Summary
  Form:  ( DEFUN FACT ...)
  Rules: ((:COMPOUND-RECOGNIZER ZP-COMPOUND-RECOGNIZER)
          (:FAKE-RUNE-FOR-TYPE-SET NIL))
  Warnings:  None
  Time:  0.00 seconds (prove: 0.00, print: 0.00, other: 0.00)
   FACT
  ACL2 !>(defun update-foo (n value state)
           (declare (xargs :stobjs state :verify-guards nil))
           (assign foo (cons (cons n value) (@ foo))))

  Since UPDATE-FOO is non-recursive, its admission is trivial.  We observe
  that the type of UPDATE-FOO is described by the theorem
  (AND (CONSP (UPDATE-FOO N VALUE STATE))
       (TRUE-LISTP (UPDATE-FOO N VALUE STATE))).
  We used primitive type reasoning.

  (UPDATE-FOO * * STATE) => (MV * * STATE).

  Summary
  Form:  ( DEFUN UPDATE-FOO ...)
  Rules: ((:FAKE-RUNE-FOR-TYPE-SET NIL))
  Warnings:  None
  Time:  0.00 seconds (prove: 0.00, print: 0.00, other: 0.00)
   UPDATE-FOO
  ACL2 !>(trace! (fact :exit (update-foo n value state)))

  TTAG NOTE: Adding ttag :TRACE! from the top level loop.
   ((FACT :EXIT (UPDATE-FOO N VALUE STATE)))
  ACL2 !>(assign foo nil)
   NIL
  ACL2 !>(fact 7)
  1> (ACL2_*1*_ACL2::FACT 7)
    2> (ACL2_*1*_ACL2::FACT 6)
      3> (ACL2_*1*_ACL2::FACT 5)
        4> (ACL2_*1*_ACL2::FACT 4)
          5> (ACL2_*1*_ACL2::FACT 3)
            6> (ACL2_*1*_ACL2::FACT 2)
              7> (ACL2_*1*_ACL2::FACT 1)
                8> (ACL2_*1*_ACL2::FACT 0)
                <8 NIL
              <7 NIL
            <6 NIL
          <5 NIL
        <4 NIL
      <3 NIL
    <2 NIL
  <1 NIL
  5040
  ACL2 !>(@ foo)
  ((7 . 5040)
   (6 . 720)
   (5 . 120)
   (4 . 24)
   (3 . 6)
   (2 . 2)
   (1 . 1)
   (0 . 1))
  ACL2 !>(verify-guards fact)

  Computing the guard conjecture for FACT....

  The guard conjecture for FACT is trivial to prove, given the :compound-
  recognizer rules NATP-COMPOUND-RECOGNIZER and ZP-COMPOUND-RECOGNIZER,
  primitive type reasoning and the :type-prescription rule FACT.  FACT
  is compliant with Common Lisp.

  Summary
  Form:  ( VERIFY-GUARDS FACT)
  Rules: ((:COMPOUND-RECOGNIZER NATP-COMPOUND-RECOGNIZER)
          (:COMPOUND-RECOGNIZER ZP-COMPOUND-RECOGNIZER)
          (:FAKE-RUNE-FOR-TYPE-SET NIL)
          (:TYPE-PRESCRIPTION FACT))
  Warnings:  None
  Time:  0.00 seconds (prove: 0.00, print: 0.00, other: 0.00)
   FACT
  ACL2 !>(assign foo nil)
   NIL
  ACL2 !>(fact 7)
  1> (ACL2_*1*_ACL2::FACT 7)
    2> (FACT 7)
      3> (FACT 6)
        4> (FACT 5)
          5> (FACT 4)
            6> (FACT 3)
              7> (FACT 2)
                8> (FACT 1)
                  9> (FACT 0)
                  <9 NIL
                <8 NIL
              <7 NIL
            <6 NIL
          <5 NIL
        <4 NIL
      <3 NIL
    <2 NIL
  <1 NIL
  5040
  ACL2 !>(@ foo)
  ((7 . 5040)
   (7 . 5040)
   (6 . 720)
   (5 . 120)
   (4 . 24)
   (3 . 6)
   (2 . 2)
   (1 . 1)
   (0 . 1))
  ACL2 !>(trace! (fact :exit (progn (update-foo n value state)
                                    (cons traced-fn values))))

  TTAG NOTE: Adding ttag :TRACE! from the top level loop.
   ((FACT :EXIT (PROGN (UPDATE-FOO N VALUE STATE)
                       (CONS TRACED-FN VALUES))))
  ACL2 !>(assign foo nil)
   NIL
  ACL2 !>(fact 7)
  1> (ACL2_*1*_ACL2::FACT 7)
    2> (FACT 7)
      3> (FACT 6)
        4> (FACT 5)
          5> (FACT 4)
            6> (FACT 3)
              7> (FACT 2)
                8> (FACT 1)
                  9> (FACT 0)
                  <9 (FACT 1)
                <8 (FACT 1)
              <7 (FACT 2)
            <6 (FACT 6)
          <5 (FACT 24)
        <4 (FACT 120)
      <3 (FACT 720)
    <2 (FACT 5040)
  <1 (ACL2_*1*_ACL2::FACT 5040)
  5040
  ACL2 !>(@ foo)
  ((7 . 5040)
   (7 . 5040)
   (6 . 720)
   (5 . 120)
   (4 . 24)
   (3 . 6)
   (2 . 2)
   (1 . 1)
   (0 . 1))
  ACL2 !>
  ~ev[]

  Finally, we remark that the use ~c[trace!] can cause errors in situations
  where tracing is automatically suspended and re-introduced.  This is likely
  to be a rare occurrence, but consider the following example.
  ~bv[]
  (trace! (lexorder :native t :multiplicity 1))
  (certify-book \"foo\" 0 t)
  ~ev[]
  If the certify-book causes compilation, you may see an error such as the
  following.
  ~bv[]

  ACL2 Error in (CERTIFY-BOOK \"foo\" ...):  The keyword :NATIVE cannot
  be used in a trace spec unless there is an active trust tag.  The trace
  spec (LEXORDER :NATIVE T :MULTIPLICITY 1) is thus illegal.  Consider
  using trace! instead.  The complete list of keywords that require a
  trust tag for use in a trace spec is: (:NATIVE :DEF :MULTIPLICITY).

  ~ev[]
  This error is harmless.  The function will appear, when calling ~c[(trace$)],
  to remain traced, but in fact there will be no tracing behavior, so you may
  want to call ~ilc[untrace$] on the function symbol in question.
  ~/"

  (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))
    #+acl2-loop-only
    form))

(defmacro untrace$ (&rest fns)

  ":Doc-Section Trace

  untrace functions~/
  ~bv[]
  Examples:
  (untrace$)         ; untrace all functions previously
                     ; traced (e.g. with trace$ or trace!)
  (untrace$ foo bar) ; as above, except only untrace foo and bar~/

  General Forms:
  (untrace$)                 ; untrace all (as noted above)
  (untrace$ fn1 fn2 ... fnk) ; untrace the indicated functions
  ~ev[]
  where the ~c[fni] were previously traced (e.g. with ~ilc[trace$] or
  ~ilc[trace!]).

  ~c[Untrace$] undoes the effect of ~ilc[trace$].  ~l[trace$].  The value
  returned by ~c[untrace$] gives the list of functions for which tracing is
  being removed.~/"

  `(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)

  ":Doc-Section Trace

  redirect trace output to a file~/
  ~bv[]
  Example:
  (open-trace-file \"foo\") ; trace output will go to file foo~/

  General Form:
  (open-trace-file filename) ; trace output will go to file filename
  ~ev[]

  Output from ~ilc[trace$] normally goes to the screen, i.e.,
  ~ilc[standard-co].  But it can be redirected to a file as shown above.
  ~l[close-trace-file] for how to send trace output back to the screen.~/"

  (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 ()

  ":Doc-Section Trace

  stop redirecting trace output to a file~/
  ~bv[]
  General Form:
  (close-trace-file) ; trace output is no longer redirected to a file~/
  ~ev[]

  Output from ~ilc[trace$] normally goes to the screen, or more precisely,
  ~ilc[standard-co].  It can be redirected to a file; ~pl[open-trace-file].
  Use ~c[close-trace-file] to redirect trace output to ~ilc[standard-co].~/"

  '(close-trace-file-fn nil state))

(defmacro break-on-error (&optional (on 't))

; It should suffice to trace error1 and not illegal, since raw-ev-fncall turns
; hard errors into soft errors (mv t msg latches), which in turn cause calls of
; error1 in trans-eval.  We trace on exit so that the error message will be
; printed.

  ":Doc-Section Trace

  break when encountering a hard or soft error caused by ACL2~/
  ~bv[]
  General forms:
  (break-on-error t)    ; installs a trace causing a continuable error (break)
                        ;   when an error is invoked by ACL2.
  (break-on-error)      ; same as above
  (break-on-error :all) ; same as above, but even when inside the prover
  (break-on-error nil)  ; uninstall any above trace
  ~ev[]
  ~c[(Break-on-error)] generates a suitable trace of error functions.  Evaluate
  ~c[(trace$)] after ~c[(break-on-error)] if you want to see the specific trace
  forms (which you can modify and then submit directly to ~c[trace$], if you
  wish).  This ~il[trace] should cause entry to the Lisp debugger whenever ACL2
  calls its error routines, except for certain errors when inside the theorem
  prover, and also at those times if option :all is supplied.

  NOTE: For technical reasons, you may see some error messages more than once.

  Finally, note that you are welcome to define your own version of
  ~c[break-on-error] by modifying a copy of the source definition (search for
  ``~c[(defmacro break-on-error]'' in ACL2 source file other-events.lisp).
  Please feel free to send your version of ~c[break-on-error] to the ACL2
  implementors, for possible inclusion into ACL2.

  ~c[Break-on-error] is implmented using ACL2 ~ilc[trace$].  ~l[trace!] if you
  want an explanation of the ``~c[TTAG NOTE]'' that is printed.

  The argument, if supplied, is evaluated and must evaluate to ~c[t], ~c[nil],
  or ~c[:all].

  Also ~pl[set-debugger-enable] for how to get raw-Lisp backtrace information
  when an error occurs as a result of ~c[break-on-error], or even of a raw Lisp
  error, by calling ~c[set-debugger-enable] with argument ~c[:bt],
  ~c[:bt-break], or ~c[:break-bt].  Note that for ACL2 errors (as opposed to
  raw Lisp errors), i.e. errors affected by ~c[break-on-error], all three of
  those keyword values are treated equivalently (and, all are ignored for
  non-ANSI GCL; ~pl[set-debugger-enable]).~/~/"

  (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
                                              "~|[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))
         (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 *the-live-state*)
                                     (user-stobj-alist *the-live-state*))))
                    0 *standard-co* *the-live-state*
                    "~|~%")
                   (maybe-print-call-history *the-live-state*)
                   (break$)))))
    `(let ((on ,on))
       (er-progn
        (case on
          (:all  (trace! ,error1-trace-form
                         ,er-cmp-fn-trace-form
                         ,throw-raw-ev-fncall-trace-form))
          ((t)   (trace! ,error1-trace-form
                         ,er-cmp-fn-trace-form
                         (,@throw-raw-ev-fncall-trace-form
                          :cond
                          (not (f-get-global 'in-prove-flg
                                             *the-live-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)))))

(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 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
        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))
            (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))
               (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))
                  (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))
                     (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))
                        (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))
                           (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
                               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))))
       ((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))
         ((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
                                  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))))
       (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
                                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)
  (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))

(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
                                            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)
          (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 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 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 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 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)

  ":Doc-Section Events

  attach a terminating executable function to a definition~/

  Suppose you define a function ~c[(fn x)] with a ~il[guard] of
  ~c[(good-input-p x)], and you know that when the guard holds, the measure
  decreases on each recursive call.  Unfortunately, the definitional principle
  (~pl[defun]) ignores the guard.  For example, if the definition has the form
  ~bv[]
  (defun fn (x)
    (declare (xargs :guard (good-input-p x)))
    (if (not-done-yet x)
        (... (fn (destr x)) ...)
      ...))
  ~ev[]
  then in order to admit this definition, ACL2 must prove the appropriate
  formula asserting that ~c[(destr x)] is ``smaller than'' ~c[x] under the
  assumption ~c[(not-done-yet x)] but without the assumption
  ~c[(good-input-p x)], even if ~c[(not-done-yet x)] is true.  In essence, it
  may be necessary to submit instead the following definition.
  ~bv[]
  (defun fn (x)
    (declare (xargs :guard (good-input-p x)))
    (if (good-input-p x)
        (if (not-done-yet x)
            (... (fn (destr x)) ...)
          ...)
      nil)
  ~ev[]
  But it is unfortunate that when calls of ~c[fn] are evaluated, for example
  when ~c[fn] is applied to an explicit constant during a proof, then a call of
  ~c[good-input-p] must now be evaluated on each recursive call.

  Fortunately, ~c[defexec] provides a way to keep the execution efficient.  For
  the example above we could use the following form.
  ~bv[]
  (defexec fn (x)
    (declare (xargs :guard (good-input-p x)))
    (mbe :logic (if (good-input-p x)
                    (if (not-done-yet x)
                        (... (fn (destr x)) ...)
                      ...)
                  nil)
         :exec  (if (not-done-yet x)
                    (... (fn (destr x)) ...)
                  ...)))
  ~ev[]
  Here ``~ilc[mbe]'' stands for ``must be equal'' and, roughly speaking, its
  call above is logically equal to the ~c[:logic] form but is evaluated using
  the ~c[:exec] form when the guard holds.  ~l[mbe].  The effect is thus to
  define ~c[fn] as shown in the ~ilc[defun] form above, but to cause execution
  of ~c[fn] using the ~c[:exec] body.  The use of ~c[defexec] instead of
  ~ilc[defun] in the example above causes a termination proof to be performed,
  in order to guarantee that evaluation always theoretically terminates, even
  when using the ~c[:exec] form for evaluation.
  ~bv[]
  Example:

  ; Some of the keyword arguments in the declarations below are irrelevant or
  ; unnecessary, but they serve to illustrate their use.

  (defexec f (x)
    (declare (xargs :measure (+ 15 (acl2-count x))
                    :ruler-extenders :basic
                    :hints ((\"Goal\" :in-theory (disable nth)))
                    :guard-hints ((\"Goal\" :in-theory (disable last)))
                    :guard (and (integerp x) (<= 0 x) (< x 25)))
             (exec-xargs
                    :test (and (integerp x) (<= 0 x))
                    :default-value 'undef ; defaults to nil
                    :measure (nfix x)
                    :ruler-extenders :basic
                    :well-founded-relation o<))
    (mbe :logic (if (zp x)
                    1
                  (* x (f (- x 1))))
         :exec  (if (= x 0)
                    1
                  (* x (f (- x 1))))))
  ~ev[]
  The above example macroexpands to the following.
  ~bv[]
  (ENCAPSULATE ()
   (LOCAL
    (ENCAPSULATE ()
     (SET-IGNORE-OK T)
     (SET-IRRELEVANT-FORMALS-OK T)
     (LOCAL (DEFUN F (X)
              (DECLARE
               (XARGS :VERIFY-GUARDS NIL
                      :HINTS ((\"Goal\" :IN-THEORY (DISABLE NTH)))
                      :MEASURE (NFIX X)
                      :RULER-EXTENDERS :BASIC
                      :WELL-FOUNDED-RELATION O<))
              (IF (AND (INTEGERP X) (<= 0 X))
                  (IF (= X 0) 1 (* X (F (- X 1))))
                  'UNDEF)))
     (LOCAL (DEFTHM F-GUARD-IMPLIES-TEST
              (IMPLIES (AND (INTEGERP X) (<= 0 X) (< X 25))
                       (AND (INTEGERP X) (<= 0 X)))
              :RULE-CLASSES NIL))))
   (DEFUN F (X)
     (DECLARE (XARGS :MEASURE (+ 15 (ACL2-COUNT X))
                     :RULER-EXTENDERS :BASIC
                     :HINTS ((\"Goal\" :IN-THEORY (DISABLE NTH)))
                     :GUARD-HINTS ((\"Goal\" :IN-THEORY (DISABLE LAST)))
                     :GUARD (AND (INTEGERP X) (<= 0 X) (< X 25))))
     (MBE :LOGIC
          (IF (ZP X) 1 (* X (F (- X 1))))
          :EXEC
          (IF (= X 0) 1 (* X (F (- X 1)))))))
  ~ev[]
  Notice that in the example above, the ~c[:]~ilc[hints] in the ~ilc[local]
  definition of ~c[F] are inherited from the ~c[:hints] in the ~ilc[xargs] of
  the ~c[defexec] form.  We discuss such inheritance below.

  ~sc[Caveat]: Termination is not considered for calls of ~ilc[mbe] under the
  top-level call.  Moreover, the ~c[:exec] part of an ~ilc[mbe] call under the
  ~c[:logic] part of any superior ~c[mbe] call is completely ignored.

  ~bv[]
  General Form:
  (defexec fn (var1 ... varn) doc-string dcl ... dcl
    (mbe :LOGIC logic-body
         :EXEC  exec-body))
  ~ev[]
  where the syntax is identical to the syntax of ~ilc[defun] where the body is
  a call of ~c[mbe], with the exceptions described below.  Thus, ~c[fn] is the
  symbol you wish to define and is a new symbolic name and ~c[(var1 ... varn)]
  is its list of formal parameters (~pl[name]).  The first exception is that at
  least one ~c[dcl] (i.e., ~ilc[declare] form) must specify a ~c[:guard],
  ~c[guard].  The second exception is that one of the ~c[dcl]s is allowed to
  contain an element of the form ~c[(exec-xargs ...)].  The ~c[exec-xargs]
  form, if present, must specify a non-empty ~ilc[keyword-value-listp] each of
  whose keys is one of ~c[:test], ~c[:default-value], or one of the standard
  ~ilc[xargs] keys of ~c[:measure], ~c[:ruler-extenders],
  ~c[:well-founded-relation], ~c[:hints], or ~c[:stobjs].  Any of these five
  standard ~c[xargs] keys that is present in an ~c[xargs] of some ~c[dcl] but
  is not specified in the (possibly nonexistent) ~c[exec-xargs] form is
  considered to be specified in the ~c[exec-xargs] form, as illustrated in the
  example above for ~c[:hints].  (So for example, if you want ~c[:hints] in the
  final, non-local definition but not in the local definition, then specify the
  ~c[:hints] in the ~c[xargs] but specify ~c[:hints nil] in the
  ~c[exec-xargs].)  If ~c[:test] is specified and not ~c[nil], let ~c[test] be
  its value; otherwise let ~c[test] default to ~c[guard].  If
  ~c[:default-value] is specified, let ~c[default-value] be its value; else
  ~c[default-value] is ~c[nil].  ~c[Default-value] should have the same
  ~il[signature] as ~c[exec-body]; otherwise the ~c[defexec] form will fail to
  be admitted.

  The above General Form's macroexpansion is of the form
  ~c[(PROGN encap final-def)], where ~c[encap] and ~c[final-def] are as
  follows.  ~c[Final-def] is simply the result of removing the ~c[exec-xargs]
  declaration (if any) from its ~ilc[declare] form, and is the result of
  evaluating the given ~c[defexec] form, since ~c[encap] is of the following
  form.
  ~bv[]
  ; encap
  (ENCAPSULATE ()
    (set-ignore-ok t)             ; harmless for proving termination
    (set-irrelevant-formals-ok t) ; harmless for proving termination
    (local local-def)
    (local local-thm))
  ~ev[]
  The purpose of ~c[encap] is to ensure the the executable version of ~c[name]
  terminates on all arguments.  Thus, ~c[local-def] and ~c[local-thm] are as
  follows, where the ~c[xargs] of the ~ilc[declare] form are the result of
  adding ~c[:VERIFY-GUARDS NIL] to the result of removing the ~c[:test] and
  (optional) ~c[:default-value] from the ~c[exec-xargs].
  ~bv[]
  ; local-def
  (DEFUN fn formals
    (DECLARE (XARGS :VERIFY-GUARDS NIL ...))
    (IF test
        exec-body
      default-value))

  ; local-thm
  (DEFTHM fn-EXEC-GUARD-HOLDS
    (IMPLIES guard test)
    :RULE-CLASSES NIL)
  ~ev[]
  We claim that if the above ~c[local-def] and ~c[local-thm] are admitted, then
  all evaluations of calls of ~c[fn] terminate.  The concern is that the use
  of ~ilc[mbe] in ~c[final-def] allows for the use of ~c[exec-body] for a call
  of ~c[fn], as well as for subsequent recursive calls, when ~c[guard] holds
  and assuming that the guards have been verified for ~c[final-def].  However,
  by ~c[local-thm] we can conclude in this case that ~c[test] holds, in which
  case the call of ~c[fn] may be viewed as a call of the version of ~c[fn]
  defined in ~c[local-def].  Moreover, since guards have been verified for
  ~c[final-def], then guards hold for subsequent evaluation of ~c[exec-body],
  and in particular for recursive calls of ~c[fn], which can thus continue to
  be viewed as calls using ~c[local=def].~/~/

  :cited-by mbe"

  (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)
            (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-checker 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-checker, 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))
             (or (eq geneqv :none)
                 (geneqv-refinementp (access rewrite-rule lemma :equiv)
                                     geneqv
                                     wrld)))
        (mv-let
         (flg alist)
         (one-way-unify (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 (nvariablep hyp)
              (not (fquotep hyp))
              (eq (ffn-symb hyp) 'synp))
         (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
                                        :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)
                 (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-checker 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)

; This function is adapted from ACL2 function relieve-hyps1-iter.

  (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).

; When keep-unify-subst 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 true 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 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-checker 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 (eq keep-unify-subst t)
                                         (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
                    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 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-checker.

  (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
              "~ ~ ~#c~[New term~/Conclusion~]: ~Y3t~|~
               ~ ~ Hypotheses: ~#b~[<none>~/~Y4t~]~|~
               ~#c~[~ ~ Equiv: ~ye~|~/~]~
               ~#s~[~/~ ~ 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.~]~|"))
         (pprogn
          (cond
           ((and show-more pl-p) ; then just show more
            state)
           (t
            (fms fmt-string
                 (list (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 #\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)))
          (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 #\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 #\5 (if (eql (length free-2) 1)
                                           1
                                         2))
                             (cons #\6 free-2)
                             (cons #\n (if (null free-2)
                                           "[none]"
                                         ""))
                             (cons #\7 (if (member-eq nil subst-hyps-2)
                                           1
                                         0))
                             (cons #\t (term-evisc-tuple nil state)))
                       (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-checker.

  (cond
   ((null app-rules)
    state)
   (t
    (pprogn
     (let ((sar (car app-rules)))
       (let ((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)
                (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 (set-difference-assoc-eq
                         result-and-hyps-vars
                         unify-subst)))
             (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
               (set-difference-assoc-eq
                result-and-hyps-vars
                unify-subst-2)
               result abbreviations term-id-iff ens enabled-only-flg
               (and (eq caller 'show-rewrites)
                    (access sar sar :equiv))
               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-checker.

  (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 :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 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)
               (fquotep current-term)
               (flambdap (ffn-symb current-term))))
      (fms "It is only possible to apply ~#0~[rewrite rules to terms~/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))
      (fms "It is only possible to apply ~#0~[rewrite rules to terms~/linear ~
            rules for triggers~] that are applications of function symbols ~
            other than IF.  However, the current term is~|~ ~ ~y0.~|"
           (list (cons #\0 (if (eq caller 'show-rewrites) 0 1))
                 (cons #\1 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-checker
         (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
                     (getprop (ffn-symb current-term) 'lemmas nil
                              'current-acl2-world w)
                     1 (or name rune) index w))
                   (t
                    (applicable-linear-rules1
                     current-term
                     (getprop (ffn-symb current-term) 'linear-lemmas nil
                              'current-acl2-world 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 state)
  (cond ((and (nvariablep term)
              (not (fquotep term))
              (not (flambdap (ffn-symb term))))
         (let ((wrld (w state)))
           (show-meta-lemmas1 (getprop (ffn-symb term) 'lemmas nil
                                       'current-acl2-world wrld)
                              rule-id term wrld (ens state) 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 (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)))
              (not (eq (ffn-symb term) '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-checker
              (fms "*** Contradiction in the hypotheses! ***~%The S command ~
                    should complete this goal.~|"
                   nil (standard-co state) state nil))
             (t (show-type-prescription-rules1
                 (getprop (ffn-symb term) 'type-prescriptions nil
                          'current-acl2-world wrld)
                 term rule-id hyps-type-alist abbreviations wrld ens
                 state))))))
        (t

; Presumably we are inside the proof-checker, 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 state)))
    (er-let*
     ((term (translate form t t nil caller (w state) 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)
                     (fquotep term)
                     (flambdap (ffn-symb term))
                     (eq (ffn-symb term) 'if))
                 (mv t (remove-guard-holders term)))
                (t (mv nil term)))
          (cond ((or (variablep term1)
                     (fquotep term1)
                     (flambdap (ffn-symb term1))
                     (eq (ffn-symb term1) 'if))
                 (er soft caller
                     "~@0 must represent a term that is not a variable or a ~
                      constant, which is not a LET (or LAMBDA application), ~
                      and whose function symbol is not IF.  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
                                                                   (w state))))
                                      (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-rewrites-linears-fn
                       'show-linears rule-id nil ens term nil nil nil :none t
                       state)
                      (show-meta-lemmas term rule-id state)
                      (show-type-prescription-rules term rule-id nil nil
                                                    ens state)
                      (value :invisible)))))))))))

(defun pl-fn (name state)
  (cond
   ((symbolp name)
    (let* ((wrld (w state))
           (ens (ens state))
           (name (deref-macro-name name (macro-aliases wrld))))
      (cond
       ((function-symbolp name wrld)
        (print-info-for-rules
         (append
          (info-for-lemmas
           (getprop name 'lemmas nil 'current-acl2-world wrld)
           t ens wrld)
          (info-for-linear-lemmas
           (getprop name 'linear-lemmas nil 'current-acl2-world wrld)
           t ens wrld)
          (info-for-type-prescriptions
           (getprop name 'type-prescriptions nil 'current-acl2-world wrld)
           t ens wrld)
          (info-for-forward-chaining-rules
           (getprop name 'forward-chaining-rules nil 'current-acl2-world wrld)
           t ens wrld)
          (let ((elim-rule (getprop name 'eliminate-destructors-rule nil
                                    'current-acl2-world wrld)))
            (and elim-rule
                 (info-for-eliminate-destructors-rule
                  elim-rule t ens wrld)))
          (info-for-induction-rules
           (getprop name 'induction-rules nil 'current-acl2-world 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 or else a macro that is associated ~
               with a function symbol (see :DOC add-macro-alias).")))))
   (t (pl2-fn name nil 'pl state))))

(defmacro pl (name)

  ":Doc-Section History

  print the rules for the given name or term~/
  ~bv[]
  Examples:
  :pl foo     ; prints rules that rewrite some call of foo
  :pl (+ x y) ; prints rules that rewrite (+ x y)
  ~ev[]~/

  Also ~pl[pl2], which restricts output to rules that you specify for a given
  term.

  ~c[Pl] takes one argument, which should be a symbol or a term.

  First suppose that the argument is a symbol.  Then it should be either a
  function symbol or else a macro alias for a function symbol
  (~pl[macro-aliases-table]), which is treated as the corresponding function
  symbol.  In this case ~c[:pl] displays rules that apply to terms whose top
  function symbol is the one specified, specifically, rules of class
  ~c[:]~ilc[rewrite], ~c[:]~ilc[definition], ~c[:]~ilc[meta],
  ~c[:]~ilc[linear], ~c[:]~ilc[type-prescription], ~c[:]~ilc[forward-chaining],
  ~c[:]~ilc[elim], and ~c[:]~ilc[induction].

  Otherwise the argument should be a term (in user syntax, so that for example
  macros are permitted).  In this case, ~c[:pl] displays the
  ~c[:]~ilc[rewrite], ~c[:]~ilc[definition], and ~c[:meta] rules that rewrite
  the specified term, followed by the applicable ~c[:]~ilc[type-prescription]
  rules.  Each rule is displayed with additional information, such as the
  hypotheses that remain after applying some simple techniques to discharge
  them that are likely to apply in any context.  Note that for ~c[:]~ilc[meta]
  rules, only those are displayed that meet two conditions: the application of
  the metafunction returns a term different from the input term, and if there
  is a hypothesis metafunction then it also returns a term.  (A subtlety: In
  the case of extended metafunctions (~pl[extended-metafunctions]), a trivial
  metafunction context is used for the application of the metafunction.)

  Note that some rule classes are not handled by ~c[:pl].  In particular, if
  you want to see all ~c[:]~ilc[clause-processor] rules, issue the command
  ~c[:print-clause-processor-rules], and for trusted clause-processors,
  ~c[(table trusted-clause-processor-table)]; ~pl[clause-processor] and
  ~pl[define-trusted-clause-processor].~/"

  (list 'pl-fn name 'state))

(defmacro pl2 (form rule-id)

  ":Doc-Section History

  print rule(s) for the given form~/
  ~bv[]
  Examples:
  :pl2 (+ x y) nil ; prints rules that apply to (+ x y)
  :pl2 (+ x y) foo ; prints rules named foo that apply to (+ x y)
  :pl2 (+ x y) (:rewrite foo) ; if the rule with rune (:rewrite foo) applies
                              ;   to (+ x y), then print it
  :pl2 (+ x y) (:type-prescription foo)
                              ; as above, but for the indicated
                              ;   type-prescription rule
  ~ev[]~/

  ~c[Pl2] takes two arguments.  The first is a term.  The second is either
  ~c[nil] or a ``rule-id'' that is either a symbol or a ~il[rune].  The result
  is to print rules of class ~c[:]~ilc[rewrite], ~c[:]~ilc[definition],
  ~c[:meta], ~c[:]~ilc[linear], and ~c[:]~ilc[type-prescription] that apply to
  the given term.  Indeed, ~c[:pl2] prints exactly what is printed by applying
  ~c[:]~ilc[pl] to the first argument ~-[] ~pl[pl] ~-[] except that if the
  second argument is not ~c[nil] then it is used to filter the rules printed,
  as follows.~bq[]

  If the rule-id is a symbol, then only rules whose name is that symbol will be
  printed.

  If the rule-id is a ~il[rune], then at most one rule will be printed: the
  rule named by that rune (if the rule would be printed by
  ~c[:]~ilc[pl]).~eq[]~/"

  (list 'pl2-fn form rule-id ''pl2 'state))

; Essay on Include-book-dir-alist

; The :include-book-dir-alist field of the acl2-defaults-table supports the
; :dir argument of include-book and ld, by associating keywords (used as values
; of :dir) with absolute directory pathnames.  The macro add-include-book-dir
; provides a way to extend that field.  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 and include-book in raw Lisp.

; Therefore we maintain for raw Lisp a variant of the acl2-defaults-table's
; include-book-dir-alist, namely state global 'raw-include-book-dir-alist.  The
; value of this variable is initially :ignore, meaning that we are to use the
; acl2-defaults-table's include-book-dir-alist.  But when the value is not
; :ignore, then it is an alist that is used as the include-book-dir-alist.  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 anyhow, 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 (generally) raw-mode, and should remain :ignore when not in
; those contexts.  When the value 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.  And 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).

; In order to be able to rely on the above scheme, we disallow any direct table
; update 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
; delete-include-book-dir.  We insist that it be non-nil in chk-table-guard.
; We considered doing it 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 add-include-book-dir-fn (keyword dir state)

; See the Essay on Include-book-dir-alist.

  (declare (xargs :guard (state-p state)
                  :mode :program))
  (let ((ctx 'add-include-book-dir))
    (cond ((or (not (keywordp keyword))
               (eq keyword :SYSTEM))
           (er soft ctx
               "The first argument of add-include-book-dir must be a keyword ~
                (see :DOC keywordp) other than :SYSTEM, but ~x0 is not."
               keyword))
          ((not (stringp dir))
           (er soft ctx
               "The second argument of add-include-book-dir must be a ~
                string, but ~x0 is not."
               dir))
          (t
           (state-global-let*
            ((inhibit-output-lst (cons 'summary (@ inhibit-output-lst)))
             (modifying-include-book-dir-alist t))
            (let* ((dir (maybe-add-separator
                         (extend-pathname (cbd) dir state)))
                   (raw-p (not (eq (f-get-global 'raw-include-book-dir-alist
                                                 state)
                                   :ignore)))
                   (old (cond (raw-p
                               (f-get-global 'raw-include-book-dir-alist
                                             state))
                              (t
                               (cdr (assoc-eq :include-book-dir-alist
                                              (table-alist 'acl2-defaults-table
                                                           (w state)))))))
                   (pair (assoc-eq keyword old))
                   (new (acons keyword dir old)))
              (cond
               ((not (absolute-pathname-string-p dir t (os (w state))))

; 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 add-include-book-dir must ~
                     represent a directory, in particular ending with ~
                     character '~s0', but ~x1 does not."
                    *directory-separator-string* dir))
               (pair
                (cond ((equal (cdr pair) dir)
                       (stop-redundant-event ctx state))
                      (t (er soft ctx
                             "The keyword ~x0 is already bound to directory ~
                              ~x1. If you intend to override the old setting ~
                              with directory ~x2, first evaluate ~x3."
                             keyword
                             (cdr pair)
                             dir
                             `(delete-include-book-dir ,keyword)))))
               (raw-p
                (pprogn (cond
                         ((or (acl2-defaults-table-local-ctx-p state)
                              (not (eq (f-get-global
                                        'raw-include-book-dir-alist state)
                                       :ignore)))

; We skip the warning below when in a context for which acl2-defaults-table
; will ultimately be discarded, since the effect of add-include-book-dir would
; disappear even without raw-mode.  We also skip the warning if we are in a
; context where we have previously transitioned the value of
; 'raw-include-book-dir-alist from :ignore, as either we have already given a
; warning, or else we deemed that transition not worthy of a warning, as in the
; state-global-let* binding of raw-include-book-dir-alist in
; load-compiled-book.

                          state)
                         (t
                          (warning$ ctx "Raw-mode"
                                    "The effect of add-include-book-dir will ~
                                     disappear if you exit raw-mode.")))
                        (f-put-global 'raw-include-book-dir-alist new state)
                        (value new)))
               (t (er-progn
                   (table-fn 'acl2-defaults-table
                             (list :include-book-dir-alist
                                   (list 'quote new))
                             state
                             (list 'table
                                   'acl2-defaults-table
                                   ':include-book-dir-alist
                                   (list 'quote new)))
                   (value new))))))))))

(defun delete-include-book-dir-fn (keyword state)

; See the Essay on Include-book-dir-alist.

  (declare (xargs :guard (state-p state)
                  :mode :program))
  (let ((ctx 'delete-include-book-dir))
    (cond ((or (not (keywordp keyword))
               (eq keyword :SYSTEM))
           (er soft ctx
               "The argument of delete-include-book-dir must be a keyword ~
                (see :DOC keywordp) other than :SYSTEM, but ~x0 is not."
               keyword))
          (t
           (state-global-let*
            ((inhibit-output-lst (cons 'summary (@ inhibit-output-lst)))
             (modifying-include-book-dir-alist t))
            (let* ((raw-p (not (eq (f-get-global 'raw-include-book-dir-alist
                                                 state)
                                   :ignore)))
                   (old (cond (raw-p
                               (f-get-global 'raw-include-book-dir-alist
                                             state))
                              (t
                               (cdr (assoc-eq :include-book-dir-alist
                                              (table-alist 'acl2-defaults-table
                                                           (w state)))))))
                   (found (assoc-eq keyword old))
                   (new (if found
                            (delete-assoc-eq keyword old)
                          old)))
              (cond
               ((not found)
                (pprogn
                 (warning$ ctx "Table"
                           "There is no binding of keyword ~x0 to delete!"
                           keyword)
                 (stop-redundant-event ctx state)))
               (raw-p
                (pprogn (f-put-global 'raw-include-book-dir-alist new state)
                        (warning$ ctx "Raw-mode"
                                  "The effect of add-include-book-dir will ~
                                   disappear if you exit raw-mode.")
                        (value new)))
               (t (er-progn
                   (table-fn 'acl2-defaults-table
                             (list :include-book-dir-alist
                                   (list 'quote new))
                             state
                             (list 'table
                                   'acl2-defaults-table
                                   ':include-book-dir-alist
                                   (list 'quote new)))
                   (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 insure 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
           (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
           (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))))))))))

(link-doc-to set-non-linear switches-parameters-and-modes set-non-linearp)
(link-doc-to set-let*-abstraction switches-parameters-and-modes
             set-let*-abstractionp)
(link-doc-to set-ld-skip-proofs switches-parameters-and-modes
             set-ld-skip-proofsp)

#-acl2-loop-only
(defmacro reset-prehistory (&rest args)
  (declare (ignore args))
  nil)

#+acl2-loop-only
(defmacro reset-prehistory (&whole event-form &optional permanent-p doc)

; Warning: See the Important Boot-Strapping Invariants before modifying!

; 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".

  ":Doc-Section switches-parameters-and-modes

  reset the prehistory~/
  ~bv[]
  Examples:
  (reset-prehistory)     ; restart command numbering at 0
  (reset-prehistory nil) ; same as above
  (reset-prehistory t)   ; as above except also disable ubt-prehistory~/

  General Forms:
  (reset-prehistory)
  (reset-prehistory permanent-p)
  (reset-prehistory permanent-p doc-string)
  ~ev[]
  where ~c[permanent-p] is ~c[t] or ~c[nil], and ~c[doc-string] is an optional
  ~il[documentation] string not beginning with ``~c[:Doc-Section] ...''.  After
  execution of this command, ACL2 will change the numbering provided by its
  ~il[history] utilities so that this ~c[reset-prehistory] command (or the
  top-level compound ~il[command] containing it, which for example might be an
  ~ilc[include-book]) is assigned the number 0.  The only way to undo this
  command is with command ~ilc[ubt-prehistory].  However, even that is
  disallowed if ~c[permanent-p] is ~c[t].

  Note that the second argument of ~ilc[certify-book], which specifies the
  number of commands in the certification world (i.e., since ground-zero), is
  not sensitive to ~c[reset-prehistory]; rather, it expects the number of
  commands since ground-zero.  To see such commands,
  ~c[:]~ilc[pbt]~c[ :start].

  A ~c[reset-prehistory] event with value ~c[nil] for ~c[permanent-p] (the
  default) is always skipped during ~ilc[certify-book] and ~ilc[include-book]
  (indeed, whenever ~ilc[ld-skip-proofsp] is ~c[t]).  Otherwise one would find
  the history numbering reset to 0 just by virtue of including (or certifying) a
  book ~-[] probably not what was intended.

  ~l[ubt-prehistory] for how to undo a ~c[reset-prehistory] command that does
  not have a ~c[permanent-p] of ~c[t].~/"

; Warning: See the Important Boot-Strapping Invariants before modifying!

  (declare (xargs :guard (member-eq permanent-p '(t nil))))
  (list 'reset-prehistory-fn
        (list 'quote permanent-p)
        'state
        (list 'quote doc)
        (list 'quote event-form)))

#+acl2-loop-only
(defun checkpoint-world (flushp state)
  (declare (ignore flushp state))
  nil)

#-acl2-loop-only
(progn

(defvar *checkpoint-world-len-and-alist-stack*
  nil)

(defmacro checkpoint-world-len-and-alist ()
  '(car *checkpoint-world-len-and-alist-stack*))

(defun checkpoint-world1 (flushp wrld state)

; When flushp is true, we are promising never to undo back past wrld.  For
; example, we could be calling checkpoint-world1 when finishing the boot-strap
; or executing (reset-prehistory t), but not when executing (reset-prehistory
; nil).

  (let (saved-alist)
    (loop for entry in (known-package-alist state)
          do
          (let ((pkg (find-package (package-entry-name entry))))
            (assert pkg)
            (when flushp
              (do-symbols (sym pkg)
                (when (get sym '*undo-stack*)
                  (setf (get sym '*undo-stack*) nil))))
            (do-symbols (sym pkg)
              (let ((alist (get sym *current-acl2-world-key* :unfound)))
                (when (not (eq alist :unfound))
                  (push (cons sym (copy-alist alist))
                        saved-alist))))))
    (let ((new (list* wrld (length wrld) saved-alist)))
      (cond (flushp (setq *checkpoint-world-len-and-alist-stack*
                          (list new)))
            (t (push new *checkpoint-world-len-and-alist-stack*))))))

(defun checkpoint-world (flushp state)
  (revert-world-on-error
   (let* ((wrld0 (w state))
          (wrld (scan-to-command wrld0)))
     (set-w 'retraction wrld state)
     (checkpoint-world1 flushp wrld state)
     (set-w 'extension wrld0 state)
     (value nil)))
  nil)

)

(defun reset-kill-ring (n state)

  ":Doc-Section History

  save memory by resetting and perhaps resizing the kill ring used by ~ilc[oops]~/

  By default, ACL2 holds on to old logical ~il[world]s when you undo
  ~il[command]s (~pl[ubt]), as documented elswhere; ~pl[oops].  You can free up
  memory by deleting those old worlds using ~c[reset-kill-ring].
  ~bv[]
  Examples:
  (reset-kill-ring t state)   ; replace each element of the kill ring by nil
  (reset-kill-ring 2 state)   ; create a new kill ring of '(nil nil)
  (reset-kill-ring 0 state)   ; create a new kill ring that is empty
  (reset-kill-ring nil state) ; just return the length of the kill ring

  General form:
  (reset-kill-ring n state)
  ~ev[]
  where ~c[n] evaluates either to ~c[t], to ~c[nil], or to a nonnegative
  integer (a ~ilc[natp]).  If ~c[n] evaluates to ~c[t], it is treated as the
  length of the current kill ring.  If ~c[n] is ~c[nil], then the length ~c[k]
  of the current kill ring is returned as a value triple ~c[(mv nil k state)].
  If ~c[n] is a ~ilc[natp], then the kill ring is replaced with a list of ~c[n]
  ~c[nil]s.

  In particular, use ~c[(reset-kill-ring 0 state)] to avoid saving any old
  logical ~il[world]s, at the cost of disabling the effect of the ~ilc[oops]
  ~il[command].~/~/"

  (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 (permanent-p state doc 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 ((output-in-infixp state)
          event-form)
         ((null doc)
          (msg "( RESET-PREHISTORY ~x0)" permanent-p))
         (t
          (msg "( RESET-PREHISTORY ~x0 ...)" permanent-p)))
   (cond ((and (not permanent-p)
               (or (f-get-global 'certify-book-info state)
                   (eq (f-get-global 'ld-skip-proofsp state) 'include-book)))
          (pprogn (observation ctx
                               "~x0 events with permanent-p=t are skipped ~
                                when ~s1 books.  See :DOC reset-prehistory."
                               'reset-prehistory
                               (if (f-get-global 'certify-book-info state)
                                   "certifying"
                                 "including"))
                  (value :skipped)))
         (t
          (let* ((wrld (w state))
                 (event-form (or event-form
                                 (list* 'reset-prehistory
                                        permanent-p
                                        (if doc
                                            (list :doc doc)
                                          nil))))
                 (next-absolute-command-number
                  (next-absolute-command-number wrld)))
            (er-let*
             ((val
               (install-event :new-prehistory-set
                              event-form
                              'reset-prehistory
                              0
                              nil
                              nil
                              nil
                              ctx
                              (global-set
                               'command-number-baseline-info
                               (change command-number-baseline-info
                                       (global-val
                                        'command-number-baseline-info
                                        wrld)
                                       :permanent-p permanent-p
                                       :current next-absolute-command-number)
                               wrld)
                              state)))
             (er-progn (reset-kill-ring t state)
                       (prog2$ (checkpoint-world permanent-p 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 (str fn val ctx 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 t or causes a hard error using the same string (str) as is used by
; memoize-table-chk.

  (declare (xargs :guard (and (symbolp fn)
                              (not (eq (getprop fn 'formals t
                                                'current-acl2-world wrld)
                                       t))
                              (symbol-alistp val))))
  (let ((commutative (cdr (assoc-eq :commutative val))))
    (cond ((null commutative) t)
          ((not (eql (len (getprop fn 'formals t 'current-acl2-world wrld))
                     2))
           (er hard ctx
               "~@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))
           (er hard ctx
               "~@0Attempted to memoize ~x1 with a non-symbolp value of ~
                :commutative, ~x2."
               str fn commutative))
          (t (let ((thm (getprop commutative 'theorem nil 'current-acl2-world
                                 wrld)))
               (cond ((null thm)
                      (er hard ctx
                          "~@0The theorem ~x1 specified for :commutative ~
                           memoization of ~x2 does not exist."
                          str commutative fn))
                     (t
                      (or
                       (case-match thm
                         (('equal (!fn x y) (!fn y x))
                          (cond
                           ((and (variablep x)
                                 (variablep y)
                                 (not (eq x y)))
                            t)))
                         (& nil))
                       (er hard ctx
                           "~@0The theorem ~x1 specified for :commutative ~
                            memoization of ~x2 does not have the expected ~
                            form.  See :DOC memoize."
                           str commutative fn)))))))))

(defun memoize-table-chk (key val wrld)

; Although this function is generally only called with #+hons, nevertheless we
; define it independently of #+hons so that it has the same definition in the
; hons and non-hons versions of ACL2.

; 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:  ")
        (memoize-table (table-alist 'memoize-table wrld))
        (key-formals (if (symbolp key)
                         (getprop key 'formals t 'current-acl2-world wrld)
                       t))
        (key-class (symbol-class key wrld))
        (condition (and val (cdr (assoc-eq :condition-fn val)))))
    (let ((result
           (cond
            ((eq key-formals t)
             (er hard ctx
                 "~@0~x1 is not a function symbol."
                 str key))
            ((member-eq 'state (stobjs-in key wrld))
             (er hard ctx
                 "~@0~x1 takes ACL2's STATE as an argument."
                 str key))
            ((and condition
                  (not (all-nils (stobjs-out key wrld))))
             (let ((stobj (find-first-non-nil (stobjs-out key wrld))))
               (er hard ctx
                   "~@0~x1 returns a stobj, ~x2."
                   str key stobj)))
            ((member-eq key *hons-primitive-fns*)
             (er hard ctx
                 "~@0~x1 is a HONS primitive."
                 str key))
            ((not (cltl-def-from-name key wrld))
             (er hard ctx
                 "~@0~x1 is not a defined ACL2 function."
                 str key))
            ((getprop key 'constrainedp nil 'current-acl2-world wrld)
             (er hard ctx
                 "~@0~x1 is constrained.  You may instead wish to memoize a ~
                  caller or to memoize its attachment (see :DOC defattach)."
                 str key))
            ((if (eq key-class :program)
                 (member-eq key *primitive-program-fns-with-raw-code*)
               (member-eq key *primitive-logic-fns-with-raw-code*))
             (er hard ctx
                 "~@0The built-in function symbol ~x1 has associated raw-Lisp ~
                  code, hence is illegal to memoize."
                 str key))
            ((not (symbol-alistp val))
             (er hard ctx
                 "~@0Function symbol ~x1 must be associated with a ~
                  symbol-alistp, unlike ~x2."
                 str key val))
            ((let ((pair (assoc-eq :memo-table-init-size val)))
               (and pair (not (posp (cdr pair)))))
             (er hard ctx
                 "~@0The :memo-table-init-size must be a positive integer, ~
                  unlike ~x1."
                 str (cdr (assoc-eq :memo-table-init-size val))))
            ((not (memoize-table-chk-commutative str key val ctx wrld))
             nil) ; an error was presumably already caused

; 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)))
             (er hard ctx
                 "~@0Function ~x1 is already memoized."
                 str key))
            ((and (null val) (null (cdr (assoc-eq key memoize-table))))
             (er hard ctx
                 "~@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)
                           (er hard ctx
                               "~@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$-cw
                                    'memoize-table-chk
                                    "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)
                                         (getprop condition 'formals t
                                                  'current-acl2-world wrld)
                                       t)))
                   (val-guard (and condition
                                   (if (symbolp condition)
                                       (getprop condition 'guard *t*
                                                'current-acl2-world wrld)
                                     t))))

               (cond
                ((or (eq val nil)
                     (member-eq condition '(t nil)))
                 t)
                ((eq val-formals t)
                 (er hard ctx
                     "~@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))))
                 (er hard ctx
                     "~@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))
                 (er hard ctx
                     "~@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 (getprop key 'guard *t* 'current-acl2-world wrld)
                             val-guard))
                 (er hard ctx
                     "~@0Function ~x1 cannot serve as a memoization condition ~
                      function for ~x2, because the two functions have ~
                      different guards."
                     str condition key))
                (t t)))))))
      (progn$
       (or (global-val 'hons-enabled wrld)
           (warning$-cw (if val 'memoize 'unmemoize)
                        "The ~#0~[un~/~]memoization request for ~x1 is being ~
                         ignored because this ACL2 executable is not ~
                         hons-enabled."
                        (if val 1 0)
                        key))
       (and val
            (let ((stobjs-in (stobjs-in key wrld)))
              (cond
               ((and condition
                     (find-first-non-nil stobjs-in))
                (let ((input-stobjs (collect-non-x nil stobjs-in)))
                  (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
                   input-stobjs
                   (zero-one-or-more (cdr input-stobjs)))))
               (t nil))))
       result))))

(table memoize-table nil nil
       :guard
       (memoize-table-chk key val world))

; 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 alist-to-doublets (alist)
  (declare (xargs :guard (alistp alist)))
  (cond ((endp alist) nil)
        (t (cons (list (caar alist) (cdar alist))
                 (alist-to-doublets (cdr alist))))))

(defun print-gv1 (fn-guard-stobjsin-args state)
  (let* ((wrld (w state))
         (fn (nth 0 fn-guard-stobjsin-args))
         (guard (nth 1 fn-guard-stobjsin-args))
         (args (apply-user-stobj-alist-or-kwote
                (user-stobj-alist state)
                (nth 3 fn-guard-stobjsin-args)
                nil))
         (formals (formals fn wrld))
         (guard-fn (intern-in-package-of-symbol
                    (concatenate 'string (symbol-name fn) "{GUARD}")
                    fn)))

; Note: (nth 2 fn-guard-stobjsin-args) is the stobjs-in of fn, but we don't
; need it.

    `(flet ((,guard-fn
             ,formals
             (declare (ignorable ,@formals))
             ,guard))
       (,guard-fn ,@args))))

(defun print-gv-fn (evisc-tuple state)
  (prog2$
   (wormhole 'ev-fncall-guard-er-wormhole
             '(lambda (whs)
                (set-wormhole-entry-code whs :ENTER))
             nil
             `(pprogn
               (let ((info ; see save-ev-fncall-guard-er
                      (wormhole-data (f-get-global 'wormhole-status state))))
                 (cond (info
                        (fms "~x0~|~%"
                             (list (cons #\0
                                         (print-gv1 info state)))
                             (standard-co state) state ',evisc-tuple))
                       (t
                        (fms "There is no guard violation to debug.~|~%"
                             nil (standard-co state) state nil))))
               (value :q))
             :ld-prompt  nil
             :ld-missing-input-ok 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)))

(defmacro print-gv (&key (evisc-tuple
                          '(evisc-tuple nil ; print-level
                                        nil ; print-length
                                        (world-evisceration-alist state nil)
                                        nil ; hiding-cars
                                        )))
  ":Doc-Section Other

  print a form whose evaluation caused a guard violation~/

  By default, ACL2 checks input constraints on functions, known as
  ~il[guard]s.  When guards are violated, an informative message is printed;
  but sometimes it is useful to investigate why the guard check fails.  The
  utility ~c[print-gv] is provided for that purpose.  (Alternatively, you may
  prefer to avoid guards entirely with ~c[(set-guard-checking :none)];
  ~pl[set-guard-checking].)
  ~bv[]
  Example Forms:
  (print-gv)
  (print-gv :evisc-tuple (evisc-tuple 4 4 nil nil))
  (print-gv :evisc-tuple (evisc-tuple 4 ; print-level
                                      5 ; print-length
                                      (world-evisceration-alist state nil)
                                      nil ; hiding-cars
                                      ))
  ~ev[]~/
  ~bv[]
  General Form:
  (print-gv :evisc-tuple x)
  ~ev[]
  where the ~c[:evisc-tuple] argument is optional and defaults to one that
  hides only the ACL2 logical ~il[world], by printing ~c[<world>] instead of a
  very large structure.  ~l[evisc-tuple] for a discussion of evisc-tuples.

  To see how one might use ~c[print-gv], consider the following definition.
  ~bv[]
  (defun foo (x)
    (declare (xargs :guard (and (my-first-predicate x)
                                (my-second-predicate x))))
    (cdr x))
  ~ev[]
  Now suppose we evaluate a call of ~c[foo] and obtain a guard violation.
  ~bv[]
  ACL2 !>(foo 3)


  ACL2 Error in TOP-LEVEL:  The guard for the function call (FOO X),
  which is (AND (MY-FIRST-PREDICATE X) (MY-SECOND-PREDICATE X)), is violated
  by the arguments in the call (FOO 3).  To debug: See :DOC print-gv,
  see :DOC trace, and see :DOC wet.  See :DOC set-guard-checking for
  information about suppressing this check with (set-guard-checking :none),
  as recommended for new users.

  ACL2 !>
  ~ev[]
  We can obtain (in essence) the guard form that was false, as follows.
  ~bv[]
  ACL2 !>(print-gv)

  (LET ((X '3))
       (DECLARE (IGNORABLE X))
       (AND (MY-FIRST-PREDICATE X)
            (MY-SECOND-PREDICATE X)))

  ACL2 !>
  ~ev[]
  But which conjunct is to blame?  With a bit of editing we can try each
  conjunct in turn.
  ~bv[]
  ACL2 !>(LET ((X '3))
              (DECLARE (IGNORABLE X))
              (MY-FIRST-PREDICATE X))
  T
  ACL2 !>(LET ((X '3))
              (DECLARE (IGNORABLE X))
              (MY-SECOND-PREDICATE X))
  NIL
  ACL2 !>
  ~ev[]
  Aha!  Now we can investigate why the second predicate fails for 3.

  The following hack will give you access in raw Lisp to the form printed by
  ~c[(print-gv)].  After a guard violation, just submit this form to raw Lisp:
  ~bv[]
  (print-gv1 (wormhole-data (cdr (assoc 'ev-fncall-guard-er-wormhole
                                        *wormhole-status-alist*)))
             state)
  ~ev[]

  If you use local ~il[stobj]s (~pl[with-local-stobj]) or stobj fields of
  stobjs, you may need to edit the output of ~c[print-gv] in order to evaluate
  it.  Consider the following example.
  ~bv[]
  (defstobj st fld)

  (defun g (x st)
    (declare (xargs :guard (consp x) :stobjs st)
             (ignore x))
    (fld st))

  (defun test ()
    (with-local-stobj
     st
     (mv-let (result st)
             (mv (g 3 st) st)
             result)))

  (test)
  ~ev[]
  Then ~c[:print-gv] yields the result shown below.
  ~bv[]
  (FLET ((G{GUARD} (X ST)
                   (DECLARE (IGNORABLE X ST))
                   (AND (STP ST) (CONSP X))))
        (G{GUARD} '3 |<some-stobj>|))
  ~ev[]
  In this example you could replace ``~c[|<some-stobj>|]'' by ``~c[st]'' to
  obtain a result of ~c[nil].  But similar cases may require the use of a local
  stobj that is no longer available, in which case you may need to be creative
  in order to take advantage of ~c[:print-gv].  Here is such an example.
  ~bv[]
  (defstobj st2 fld2)

  (defun g2 (st2)
    (declare (xargs :guard (null (fld2 st2)) :stobjs st2))
    (mv 0 st2))

  (defun test2 ()
    (with-local-stobj
     st2
     (mv-let (result st2)
             (let ((st2 (update-fld2 17 st2)))
               (g2 st2))
             result)))

  (test2)
  ~ev[]
  In this case, ~c[:print-gv] yields the following.
  ~bv[]
  (FLET ((G2{GUARD} (ST2)
                    (DECLARE (IGNORABLE ST2))
                    (AND (ST2P ST2) (NULL (FLD2 ST2)))))
        (G2{GUARD} |<some-stobj>|))
  ~ev[]
  But if you replace ``~c[|<some-stobj>|]'' by ``~c[st]'', the guard holds; it
  is only the local stobj, which is no longer available, that produced a guard
  violation (because its field had been updated to a cons).
  ~bv[]
  ACL2 !>(FLET ((G2{GUARD} (ST2)
                           (DECLARE (IGNORABLE ST2))
                           (AND (ST2P ST2) (NULL (FLD2 ST2)))))
               (G2{GUARD} st2))
  T
  ACL2 !>
  ~ev[]

  Finally, we note that while ~c[print-gv] is a utility for debugging guard
  violations, in contrast, ~pl[guard-debug] for a utility to assist in
  debugging failed proofs arising from guard verification.~/"

  `(print-gv-fn ,evisc-tuple 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 maintainance 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 (mv t state))))

(defun set-iprint-fn (x state)
  (let ((ctx 'set-iprint))
    (mv-let (msg state)
            (set-iprint-fn1 x state)
            (cond ((eq msg t)
                   (er soft ctx
                       "Unknown option, ~x0.  The legal iprint actions are ~&1."
                       x *iprint-actions*))
                  (msg (pprogn (observation ctx "~@0" msg)
                               (value :invisible)))
                  (t (value :invisible))))))

(defun set-iprint-hard-bound (n ctx state)
  (cond ((posp n)
         (pprogn (f-put-global 'iprint-hard-bound n state)
                 (observation ctx "The hard-bound for iprinting has been set ~
                                   to ~x0."
                              n)
                 (value :invisible)))
        (t
         (er soft ctx
             "The hard-bound for iprinting must be a positive integer, but ~
              ~x0 is not."
             n))))

(defun set-iprint-soft-bound (n ctx state)
  (cond ((posp n)
         (pprogn (f-put-global 'iprint-soft-bound n state)
                 (observation ctx "The soft-bound for iprinting has been set ~
                                   to ~x0."
                              n)
                 (value :invisible)))
        (t
         (er soft ctx
             "The soft-bound for iprinting must be a positive integer, but ~
              ~x0 is not."
             n))))

(defmacro set-iprint (&optional (action ':RESET ; default ignored
                                        action-p)
                                &key
                                (soft-bound '1 ; default ignored
                                            soft-bound-p)
                                (hard-bound '1 ; default ignored
                                            hard-bound-p))

  ":Doc-Section IO

  control whether abbreviated output can be read back in~/

  When ACL2 pretty-prints large expressions using formatted printing
  (~pl[fmt]), it may save time and space by printing tokens `~c[#]' or
  `~c[...]' in place of certain subexpressions.  By default this only happens
  for a few settings such as error and warning messages; ~pl[set-evisc-tuple]
  for controlling such elision in general.  The full expression is unavailable
  to the user when `~c[#]' or `~c[...]' is printed, but that is easily solved
  by evaluating the form
  ~bv[]
    (set-iprint t)
  ~ev[]
  to enable a mode called ``iprinting''.  Then, instead of printing `~c[#]' or
  `~c[...]', ACL2 prints `~c[#@i#]' for ~c[i] = 1,2,3,... ~-[] all in base 10.
  ACL2 can read back in such `~c[#@i#]' because under the hood, ~c[i] is
  associated with its corresponding elided form.  Thus the term ``iprint'' can
  be viewed as suggesting ``interactive print'' or ``index print''.  We also
  think of ``iprint'' as suggesting ``~c[i] printing'', to suggest the printing
  of token `~c[#@i#]'.  We call ~c[i] the ``iprint index'' of that token.

  The following example should suffice to illustrate how to recover elided
  subexpressions.  (Below this example we provide details that may be of
  interest only to advanced users.)  Here we cause an error by defining a macro
  of one argument and then calling it with two arguments.  By default, error
  messages abbreviate subexpressions deeper than level 5 with `~c[#]' and past
  the 7th element of a list with `~c[...]'.  We see this behavior below.
  ~bv[]
  ACL2 !>(defmacro foo (x) x)

  Summary
  Form:  ( DEFMACRO FOO ...)
  Rules: NIL
  Warnings:  None
  Time:  0.02 seconds (prove: 0.00, print: 0.00, other: 0.02)
   FOO
  ACL2 !>(foo arg1 (a (b (c (d (e (f (g)))))) h i j k l m n))


  ACL2 Error in macro expansion:  Wrong number of args in macro expansion
  of (FOO ARG1 (A (B (C (D #))) H I J K L ...)).  (See :DOC set-iprint
  to be able to see elided values in this message.)

  ACL2 !>(set-iprint t)

  ACL2 Observation in SET-IPRINT:  Iprinting has been enabled.
  ACL2 !>(foo arg1 (a (b (c (d (e (f (g)))))) h i j k l m n))


  ACL2 Error in macro expansion:  Wrong number of args in macro expansion
  of (FOO ARG1 (A (B (C (D #@1#))) H I J K L . #@2#)).

  ACL2 !>(acl2-count '(FOO ARG1 (A (B (C (D #@1#))) H I J K L . #@2#)))
  23
  ACL2 !>
  ~ev[]
  Sometimes you may want to supply the abbreviated form not to compute with it,
  as in the ~ilc[acl2-count] example just above, but so that you can see it.
  The macro ~ilc[without-evisc] eliminates elision during printing.  Below we
  show two ways to use this utility: first, we use it to print the elided form,
  and then, we use it instead on the original input form to print the entire
  error message.
  ~bv[]
  ACL2 !>(without-evisc '(FOO ARG1 (A (B (C (D #@1#))) H I J K L . #@2#)))
  (FOO ARG1
       (A (B (C (D (E (F (G))))))
          H I J K L M N))
  ACL2 !>(without-evisc (foo arg1 (a (b (c (d (e (f (g)))))) h i j k l m n)))


  ACL2 Error in macro expansion:  Wrong number of args in macro expansion
  of (FOO ARG1 (A (B (C (D (E (F (G)))))) H I J K L M N)).

  ACL2 !>
  ~ev[]

  The documentation above probably suffices for most users.  For those who want
  more details, below we detail all the ways to use the ~c[set-iprint]
  utility.~/

  ~bv[]
  Example Forms:
  (set-iprint t)   ; enable iprinting (elision with #@i@)
  (set-iprint nil) ; disable iprinting

  General Form:
  (set-iprint action        ; t, nil, :reset, :reset-enable, or :same
              :soft-bound s ; initially  1000
              :hard-bound h ; initially 10000)
  ~ev[]
  where all arguments are optional, but ACL2 queries for ~c[action] if it is
  omitted.   We defer the explanations of ~c[:soft-bound] and ~c[:hard-bound].
  The values for ~c[action] are as follows:
  ~bq[]

  ~c[T] ~-[] Enable iprinting.

  ~c[NIL] ~-[] Disable iprinting.

  ~c[:RESET] ~-[] Reset iprinting to its initial disabled state, so that when
  enabled, the first index ~c[i] for which `~c[#@i#] is printed will be 1.
  Note that all stored information for existing iprint indices will be erased.

  ~c[:RESET-ENABLE] ~-[] Reset iprinting as with ~c[:reset], and then enable
  iprinting.

  ~c[:SAME] ~-[] Make no change to the iprinting state (other than setting the
  ~c[:soft-bound] and/or ~c[:hard-bound] if specified, as explained
  below).~eq[]

  Immediately after a top-level form is read, hence before it is evaluated, a
  check is made for whether the latest iprint index exceeds a certain bound,
  ~c[(iprint-soft-bound state)] ~-[] 1000, by default.  If so, then the
  ~c[(iprint-last-index state)] is set back to 0.  This soft bound can be
  changed to any positive integer ~c[k] by calling ~c[set-iprint] with
  ~c[:soft-bound k], typically ~c[(set-iprint :same :soft-bound k])].

  The above ``soft bound'' is applied once for each top-level form, but you may
  want finer control by applying a bound after the pretty-printing of each
  individual form (since many forms may be pretty-printed between successive
  evaluations of top-level forms).  That bound is
  ~c[(iprint-hard-bound state)], and can be set with the ~c[:hard-bound]
  argument in analogy to how ~c[:soft-bound] is set, as described above.

  A ``rollover'' is the detection that the soft or hard bound has been
  exceeded, along with a state update so that the next iprint index will be 1.
  When a rollover occurs, any index beyond the latest iprint index is no longer
  available for reading.  At the top level of the ACL2 read-eval-print loop,
  this works as follows: ACL2 reads the next top-level form according to the
  current iprint state, then handles a rollover if the latest iprint index
  exceeded the current soft bound.  The following log illustrates a rollover,
  which follows the description above.
  ~bv[]
  ACL2 !>(set-iprint t :soft-bound 3)

  ACL2 Observation in SET-IPRINT:  The soft-bound for iprinting has been
  set to 3.

  ACL2 Observation in SET-IPRINT:  Iprinting has been enabled.
  ACL2 !>(set-evisc-tuple (evisc-tuple 2 3 nil nil) :sites :ld)
   (:LD)
  ACL2 !>'((a b c d e f g) (a b c d e f g) (a b c d e f g))
  ((A B C . #@1#) (A B C . #@2#) (A B C . #@3#))
  ACL2 !>'((a b c d e f g) (a b c d e f g) (a b c d e f g))
  ((A B C . #@4#) (A B C . #@5#) (A B C . #@6#))
  ACL2 !>(without-evisc '((A B C . #@4#) (A B C . #@5#) (A B C . #@6#)))
  ((A B C D E F G)
   (A B C D E F G)
   (A B C D E F G))
  ACL2 !>'(1 2 3 4 5)
  (1 2 3 . #@1#)
  ACL2 !>'((a b c d e f g) (a b c d e f g) (a b c d e f g))
  ((A B C . #@2#) (A B C . #@3#) (A B C . #@4#))
  ACL2 !>(without-evisc '((A B C . #@4#) (A B C . #@5#) (A B C . #@6#)))
  ((A B C D E F G)
   (A B C D E F G)
   (A B C D E F G))
  ACL2 !>(without-evisc '((A B C . #@4#) (A B C . #@5#) (A B C . #@6#)))

  ***********************************************
  ************ ABORTING from raw Lisp ***********
  Error:  Out-of-bounds index in #@5#.  See :DOC set-iprint.
  ***********************************************

  If you didn't cause an explicit interrupt (Control-C),
  then the root cause may be call of a :program mode
  function that has the wrong guard specified, or even no
  guard specified (i.e., an implicit guard of t).
  See :DOC guards.

  To enable breaks into the debugger (also see :DOC acl2-customization):
  (SET-DEBUGGER-ENABLE T)
  ACL2 !>
  ~ev[]

  We conclude by mentioning two cases where iprinting and evisc-tuples are
  ignored.  (1) This is typically the case when printing results in raw Lisp
  outside the ACL2 loop.  To use iprinting and evisc-tuples in raw Lisp, use
  raw-mode; ~pl[set-raw-mode].  In raw-mode, results that are ACL2 objects will
  be printed in the same way that ACL2 would print those results if not in
  raw-mode.  (2) Iprinting and evisc-tuples are ignored by ~ilc[print-object$],
  which however is sensitive to many settings that do not affect formatted
  (~ilc[fmt] etc.) printing; ~pl[print-control].

  The reader interested in design and implementation issues considered during
  the addition of iprinting to ACL2 is invited to read the paper ``Abbreviated
  Output for Input in ACL2: An Implementation Case Study''; see the proceedings
  of ACL2 Workshop 2009,
  ~url[http://www.cs.utexas.edu/users/moore/acl2/workshop-2009/]."

  (declare (xargs :guard ; the setters deal with illegal values
                  t))
  `(er-progn ,@(and hard-bound-p
                    `((set-iprint-hard-bound ,hard-bound 'set-iprint state)))
             ,@(and soft-bound-p
                    `((set-iprint-soft-bound ,soft-bound 'set-iprint state)))
             ,(cond
               (action-p `(set-iprint-fn ,action state))
               (t
                '(er-let*
                  ((ans
                    (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 ans :q)
                         (silent-error state))
                        (t (set-iprint-fn ans state))))))))

; We develop code for setting evisc-tuples.

(defconst *evisc-tuple-sites*
  '(:TERM :LD :TRACE :ABBREV :GAG-MODE))

(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))
    (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 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))

  ":Doc-Section IO

  control suppression of details when printing~/

  ACL2 output is generally printed in full.  However, ACL2 can be directed to
  abbreviate, or ``eviscerate'', objects before printing them, though the use
  of a so-called ``evisc-tuple''.  ~l[evisc-tuple] for a discussion of
  evisc-tuples.  The utility ~c[set-evisc-tuple] modifies certain global
  evisc-tuples, as explained below, to affect the extent to which ACL2
  eviscerates objects during printing, for example during proof output or when
  printing top-level evaluation results.

  ~bv[]
  General Form:
  (set-evisc-tuple evisc-tuple ; a legal evisc-tuple, or :DEFAULT
                  :iprint val  ; one of *iprint-actions*
                  :sites sites ; either :ALL, or an element or a subset of the
                               ;   list (:TERM :LD :TRACE :ABBREV)
  ~ev[]
  where the value of ~c[:iprint] is passed to ~ilc[set-iprint], ~c[:sites :all]
  abbreviates ~c[:sites '(:TERM :LD :TRACE :ABBREV)], and other documentation
  is provided below.  Note that all arguments are evaluated.

  ~l[without-evisc] for how to avoid evisceration for ACL2 output.

  The following example illustrates an invocation of ~c[set-evisc-tuple] that
  limits the print-level to 3 ~-[] only three descents into list structures are
  permitted before eviscerating a subterm ~-[] and limits the print-length to 4
  ~-[] only the first four elements of any list structure will be printed.
  ~bv[]
  ACL2 !>(set-evisc-tuple (evisc-tuple 3   ; print-level
                                       4   ; print-length
                                       nil ; alist
                                       nil ; hiding-cars
                                       )
                          :iprint :same ; better yet, T
                          :sites :all)
   (:TERM :LD :TRACE :ABBREV)
  ACL2 !>'((a b ((c d)) e f g) u v w x y)
  ((A B (#) E ...) U V W ...)
  ACL2 !>
  ~ev[]
  We recommend however using ~c[:iprint t] so that eviscerated terms may be
  read back in; ~pl[set-iprint].  Indeed, the ~c[:iprint] argument is required
  as a reminder to the user to consider that issue, unless iprinting has been
  enabled at least once.  If ~c[:sites] or a required ~c[:iprint] argument is
  omitted, however, ACL2 will query the user for the missing arguments rather
  than causing an error.

  ACL2 eviscerates by default only in a few cases, primarily in informational
  messages for errors, warnings, and queries (i.e., in the ~c[:EVISC] case
  below).  Users can modify the default behavior by supplying a suitable
  argument to ~c[set-evisc-tuple].  The argument may be ~c[:default], which
  denotes the evisceration provided when ACL2 starts up.  Otherwise that
  argument is an evisc-tuple, which is either ~c[nil] (no evisceration) or as
  described above.  Moreover, there are four evisc-tuple ``evisceration
  contexts'', each with its own evisceration control.  The value returned by
  ~c[set-evisc-tuple] indicates the evisceration contexts whose evisc-tuple has
  been set.  The evisceration contexts are as follows, all of which use a
  default value of ~c[nil] for the hiding-cars.  Accessors are also shown for
  retrieving the corresponding evisc-tuple.
  ~bq[]

  o ~c[:TERM] ~-[] used for printing terms.  The accessor is
  ~c[(term-evisc-tuple flg state)], where ~c[flg] is ignored if
  ~c[set-evisc-tuple] has been called for ~c[:term] with value other than
  ~c[:default], and otherwise (hence initially): a ~c[flg] of ~c[nil] indicates
  an evisc-tuple of ~c[nil], and otherwise the term-evisc-tuple has a
  print-level of 3 and print-length of 4.

  o ~c[:ABBREV] ~-[] used for printing informational messages for errors,
  warnings, and queries.  Initially, the alist abbreviates the ACL2
  ~c[world], print-level is 5, and print-level is 7.  The accessor is
  ~c[(abbrev-evisc-tuple state)].

  o ~c[:GAG-MODE] ~-[] used for printing induction schemes (and perhaps, in the
  future, for other printing) when ~il[gag-mode] is on.  If gag-mode is off,
  the value used for this ~il[evisc-tuple] is ~c[(term-evisc-tuple nil state)].
  But if gag-mode is on (i.e., ~c[(gag-mode)] evaluates to a non-~c[nil]
  value), then with one exception, the value is an evisc-tuple or ~c[nil], to
  be used in gag-mode for printing of induction schemes and, during proofs, the
  ``The non-trivial part of the guard conjecture''.  The exceptional value is
  ~c[t], which indicates that in gag-mode, no printing of induction schemes
  should be and the guard conjecture should be printed using
  ~c[(term-evisc-tuple t state)].  The accessor is
  ~c[(gag-mode-evisc-tuple state)].

  o ~c[:LD] ~-[] used by the ACL2 read-eval-print loop.  The accessor is
  ~c[(]~ilc[ld-evisc-tuple]~c[ state)].

  o ~c[:TRACE] ~-[] used for printing ~il[trace] output.  No accessor is
  available (though in raw Lisp, ~c[(trace-evisc-tuple)] returns the
  trace-evisc-tuple).~eq[]

  Each context ~c[ectx] also has an updater,
  ~c[(set-ectx-evisc-tuple val state)], where ~c[val] is a legal value for
  ~c[set-evisc-tuple] as described above: ~c[:default] or an ~il[evisc-tuple]
  (possibly ~c[nil]).~/

  Note that the ~il[break-rewrite] commands and the ~il[proof-checker]
  generally do their printing using the term-evisc-tuple.~/"

  `(set-evisc-tuple-fn ,evisc-tuple
                       ,iprint ,iprint-p
                       ,sites ,sites-p
                       state))

(defmacro top-level (form &rest declares)
  ":Doc-Section Other

  evaluate a top-level form as a function body~/

  Some forms, such as calls of ~ilc[with-local-stobj], are illegal when
  supplied directly to the ACL2 top-level loop.  The macro ~c[top-level]
  provides a workaround in such cases, by defining a temporary
  ~c[:]~ilc[program]-mode function named ~c[top-level-fn] whose only argument
  is ~c[state] and whose body is the form to be evaluated.  When the call of
  ~c[top-level] returns there is no change to the existing ACL2 logical
  ~il[world].  The following edited log illustrates all of the above points.

  ~bv[]
  ACL2 !>:pbt 0
            0  (EXIT-BOOT-STRAP-MODE)
  ACL2 !>(defstobj st fld)

  Summary
  Form:  ( DEFSTOBJ ST ...)
  Rules: NIL
  Time:  0.01 seconds (prove: 0.00, print: 0.00, other: 0.01)
   ST
  ACL2 !>(top-level
          (with-local-stobj
           st
           (mv-let (result st)
                   (let ((st (update-fld 17 st)))
                     (mv (fld st) st))
                   result)))
  17
  ACL2 !>(top-level
          (with-local-stobj
           st
           (mv-let (result st)
                   (let ((st (update-fld 17 st)))
                     (mv (fld st) st))
                   (mv nil result state))))
   17
  ACL2 !>(top-level
          (with-local-stobj
           st
           (mv-let (result st)
                   (let ((st (update-fld 17 st)))
                     (mv (fld st) st))
                   (mv result state))))
  (17 <state>)
  ACL2 !>:pbt 0
            0  (EXIT-BOOT-STRAP-MODE)
     d      1:x(DEFSTOBJ ST FLD)
  ACL2 !>
  ~ev[]~/

  Each argument of ~c[top-level] after the first should be a ~ilc[declare] form
  or ~il[documentation] string, as the list of these extra arguments will be
  placed before the first argument when forming the definition of
  ~c[top-level-fn].

  ~ilc[Top-level] generates a call of ~ilc[ld], so that the value returned is
  printed in the normal way.  The call of ~ilc[top-level] itself actually
  evaluates to ~c[(mv erp :invisible state)], where ~c[erp] is ~c[t] if and
  only evaluation of the call of ~c[top-level-fn] caused an error, which
  normally results in no additional output.  (For details about ``caused an
  error'', see the definition of ~c[top-level] in the ACL2 source code, and
  ~pl[ld-error-action].)~/"

  `(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)
                 (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)
           (declare (ignore erp val))
           (mv (@ top-level-errorp) :invisible state)))

; Essay on Defattach

; In this essay we discuss both the implementation of defattach and its logical
; characterization.

; We begin by introducing some terminology.  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.  Defattach has a syntax, :attach nil, that
; specifies that an attachment is not to be installed for execution; 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.

; (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)) will always compute to
; t, not nil!

; This example motivates an acylicity 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 evaluating the second
; defattach, then we are left with the following, which violates the contraint
; 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.

;   Theorem (Evaluation History).  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 . msg) with the
; 'attachment property of the function, where msg 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 name-tree val ctx wrld 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 wrld ctx state)
  (er soft ctx
      "Attachment is disallowed in this context, because the function ~x0 has ~
       unknown constraints provided by the dependent clause-processor ~x1.  ~
       See :DOC define-trusted-clause-processor."
      name
      (getprop name 'constrainedp
               '(:error
                 "See defattach-unknown-constraints-error:  expected to find ~
                  a 'constrainedp property where we did not.")
               'current-acl2-world wrld)))

(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)

; 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)")))
           (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))
                             ((getprop f 'macro-body nil 'current-acl2-world
                                       wrld)
                              (msg "  NOTE: ~x0 is a macro, not a function ~
                                    symbol."
                                   f))
                             (t "")))))
                ((let ((fns (global-val 'untouchable-fns wrld)))
                   (or (member-eq f fns) (member-eq g fns)))
                 (er soft ctx
                     "The argument~#0~[ ~&0 has~/s ~&0 have~] been placed on ~
                      untouchable-fns.  See :DOC remove-untouchable."
                     (intersection-eq (list f g)
                                      (global-val 'untouchable-fns wrld))))
                ((and (not skip-checks-t)
                      (not (logicalp 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 (global-val 'boot-strap-flg wrld)))
                 (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))
                (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.

                     (er soft ctx
                         "It is illegal to attach to the function symbol ~x0 ~
                          because ~@1.~@2"
                         f
                         (cdr at-alist)
                         see-doc))
                    (t ; at-alist is a legitimate attachment alist
                     (let* ((erasures (cond ((consp at-alist)
                                             (append at-alist erasures))
                                            (t erasures)))
                            (constraint-lst
                             (getprop f 'constraint-lst t 'current-acl2-world
                                      wrld))
                            (attach-pair (assoc-eq :ATTACH helper-alist)))
                       (cond
                        ((and (not skip-checks-t)
                              (eq constraint-lst *unknown-constraints*))
                         (defattach-unknown-constraints-error
                           f wrld 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)))))
                        ((and (or (null attach-pair)
                                  (cdr attach-pair)) ; attaching for execution
                              (not (and skip-checks-t

; If skip-checks is tand 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 (getprop f 'non-executablep nil
                                                     'current-acl2-world 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 (getprop f 'constrainedp nil
                                                'current-acl2-world 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 was introduced with ~x1.~@2"
                             f
                             (if (getprop f 'defchoose-axiom nil
                                          'current-acl2-world wrld)
                                 'defchoose
                               '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))
                                     ((getprop g 'macro-body nil
                                               'current-acl2-world wrld)
                                      (msg "  NOTE: ~x0 is a macro, not a ~
                                            function symbol."
                                           g))
                                     (t "")))))
                        ((and (not skip-checks-t)
                              (not (logicalp 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)))))))))))
             (& (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 filter-for-attachment (attachment-alist helpers-lst attach-by-default
                                               aa hl)

; 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.

  (cond ((endp attachment-alist)
         (mv (reverse aa) (reverse hl)))
        (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)))
                   (t (filter-for-attachment (cdr attachment-alist)
                                             (cdr helpers-lst)
                                             attach-by-default
                                             aa
                                             hl)))))))

(defconst *defattach-keys-plus-skip-checks*
  (cons :skip-checks *defattach-keys*))

(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)
               (eql (length args) 4)
               (eq (caddr args) :SKIP-CHECKS))
          (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-plus-skip-checks*
                                 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-plus-skip-checks*
             constraint-kwd-alist))
        (t (let* ((wrld (w state))
                  (ld-skip-proofsp (ld-skip-proofsp state))
                  (skip-checks
                   (cadr (assoc-keyword :skip-checks constraint-kwd-alist)))
                  (constraint-kwd-alist
                   (if skip-checks
                       (remove-keyword :skip-checks 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 (global-val 'boot-strap-flg wrld)
                             (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."))
              (t
               (er-let* ((tuple
                          (process-defattach-args1 args ctx wrld state nil nil
                                                   nil nil skip-checks))
                         (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)
                           (filter-for-attachment attachment-alist
                                                  helper-alist-lst
                                                  attach-by-default
                                                  nil nil)
                           (value (list constraint-helpers
                                        erasures
                                        explicit-erasures
                                        attachment-alist
                                        attachment-alist-exec
                                        helper-alist-lst-exec
                                        skip-checks)))))))))))))))

(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-checker nil ugoal goal nil
                                                      instructions wrld state))
                         (t (prove goal
                                   (make-pspv ens
                                              wrld
                                              :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
; signalling 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)))))

(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 ((null alist)
         (mv constraint event-names new-entries))
        (t
         (mv-let
          (name x)
          (constraint-info (caar alist) wrld)

; Note that if x is not *unknown-constraints*, then x is a single constraint if
; name is nil and otherwise x is a list of constraints.

          (cond
           ((eq x *unknown-constraints*)
            (mv x name nil)) ; the nil is irrelevant
           (t
            (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) 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 ((eq goal *unknown-constraints*)
          (defattach-unknown-constraints-error event-names wrld 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 (eq goal *unknown-constraints*))
   (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-checker nil ugoal goal nil instructions
                                    wrld state))
                    (t
                     (prove goal
                            (make-pspv ens
                                       wrld
                                       :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 intersection1-eq (x y)
  (declare (xargs :guard (and (true-listp x)
                              (true-listp y)
                              (or (symbol-listp x)
                                  (symbol-listp y)))))
  (cond ((endp x) nil)
        ((member-eq (car x) y) (car x))
        (t (intersection1-eq (cdr x) y))))

(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 iself 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))
             (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 (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 (getprop (car symbols) 'defaxiom-supporter nil
                                'current-acl2-world 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 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
; 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 associates function symbols with their proposed
;   attachments;
; - attachment-alist-exec is a subsequence of attachment-alist, 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 that we return.

  (cond
   ((eq (context-for-encapsulate-pass-2 wrld
                                        (f-get-global 'in-local-flg state))
        'illegal)
    (er soft ctx
        "Defattach events are illegal inside encapsulate events with ~
         non-empty signatures unless they are local.  In this case such a ~
         signature introduces the function symbol ~x0."
        (caar (cadar (non-trivial-encapsulate-ee-entries
                      (global-val 'embedded-event-lst wrld))))))
   (t
    (er-let*
        ((tuple (process-defattach-args args ctx state)))
      (let* ((constraint-helper-alist (nth 0 tuple))
             (erasures                (nth 1 tuple))
             (explicit-erasures       (nth 2 tuple))
             (attachment-alist        (nth 3 tuple))
             (attachment-alist-exec   (nth 4 tuple))
             (guard-helpers-lst       (nth 5 tuple))
             (skip-checks             (nth 6 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 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)
                      wrld))))
        (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
                 "~@*"
                 "~@*, and "
                 "~@*, "
                 ,defaxiom-supporter-msg-list)))
         (t
          (er-let*
              ((records (cond (skip-checks (value :skipped)) ; not used
                              (t (chk-defattach-loop attachment-alist erasures wrld
                                                     ctx state))))
               (goal/event-names/new-entries
                (cond ((and (not skip-checks-t)
                            attachment-alist)
                       (defattach-constraint attachment-alist 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)
                        (prove-defattach-constraint goal event-names attachment-alist
                                                    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
                          attachment-alist-exec
                          new-entries
                          (cons-tag-trees ttree1 ttree2)
                          records
                          skip-checks)))))))))))

(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 defattach-fn (args state event-form)
  (with-ctx-summarized
   (if (output-in-infixp state)
       event-form
     (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      (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)))
         (let* ((attachment-fns (strip-cars attachment-alist))
                (wrld1 (putprop-x-lst1 erasures 'attachment nil wrld))
                (wrld2 (cond (attachment-fns
                              (putprop-x-lst1 (cdr attachment-fns)
                                              'attachment
                                              (car attachment-fns)
                                              (putprop (car attachment-fns)
                                                       'attachment
                                                       attachment-alist
                                                       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)))
           (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 wrld4 state))))))))

; We now provide support for return-last.

(defun chk-return-last-entry (key val wrld)

; 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))))
              (or (not (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.

                  (er hard! 'chk-return-last-entry
                      "The proposed key ~x0 for ~x1 is illegal because it is ~
                       given special treatment.  See :DOC return-last."
                      key 'return-last-table))
              (or (null val)
                  (let ((val2 (if (symbolp val) val (car val))))
                    (or
                     (getprop val2 'macro-body nil 'current-acl2-world wrld)
                     (er hard! 'chk-return-last-entry
                         "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
              (or (fboundp key)

; Note that fboundp holds for functions, macros, and special operators.

                  (er hard! 'chk-return-last-entry
                      "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))
        (t (er hard! 'chk-return-last-entry
               "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))))

(table return-last-table nil nil
       :guard
       (chk-return-last-entry key val world))

(defdoc return-last-table
  ":Doc-Section switches-parameters-and-modes

  install special raw Lisp behavior~/

  Please first ~pl[return-last] for relevant background.

  This ~il[table] is for advanced users only, and requires an active trust
  tag (~pl[defttag]).  We recommend that you do not modify this table directly,
  but instead use the macro ~c[defmacro-last].  Here we augment that discussion
  with some highly technical observations that can probably be ignored if you
  use ~c[defmacro-last].~/

  This ~il[table] has a ~c[:guard] requiring that each key be a symbol defined
  in raw Lisp, generally as a macro, and requiring that each non-~c[nil] value
  be associated either with a symbol that names a macro defined in ACL2, or
  else with a list of one element containing such a symbol.  The table can only
  be modified when there is an active trust tag; ~pl[defttag].  If a key is
  associated with the value ~c[nil], then that key is treated as though it were
  not in the table.

  Note that keys of this table are not eligible to be bound by ~ilc[flet].  The
  current value of this table may be obtained by evaluating the form
  ~c[(table-alist 'return-last-table (w state))].  The built-in constant
  ~c[*initial-return-last-table*] holds the initial value of this table.~/")

(defmacro defmacro-last (fn &key raw (top-level-ok 't))

  ":Doc-Section Events

  define a macro that returns its last argument, but with side effects~/

  This is an advanced feature that requires a trust tag.  For explanation,
  including an example, ~pl[return-last].~/~/"

  (declare (xargs :guard (and (symbolp fn)
                              (symbolp raw))))
  (let ((raw (or raw (intern-in-package-of-symbol
                      (concatenate 'string (symbol-name fn) "-RAW")
                      fn))))
    `(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.

(defdoc printing-to-strings

  ":Doc-Section IO

  printing to strings instead of files or standard output~/

  Each of ACL2's formatted printing functions, ~c[FM*], has an analoguous macro
  ~c[FM*-TO-STRING] indicated below.  These functions do not include a channel
  or ~ilc[state] as an argument, and ~c[FM*-TO-STRING] returns the string that
  ~c[FM*] would print to the state, in place of ~c[state]; ~pl[fmt].  The legal
  keyword arguments are described below.

  ~bv[]
  General Forms:                                 result
  (fms-to-string string alist &key ...)          ; string
  (fmt-to-string string alist &key ...)          ; (mv col string)
  (fmt1-to-string string alist column &key ...)  ; (mv col string)
  (fms!-to-string string alist &key ...)         ; string
  (fmt!-to-string string alist &key ...)         ; (mv col string)
  (fmt1!-to-string string alist column &key ...) ; (mv col string)
  ~ev[]

  The legal keyword arguments are as follows.  They are all optional with a
  default of ~c[nil].
  ~bq[]
  ~c[Evisc-tuple] is evaluated, and corresponds exactly to the ~c[evisc-tuple]
  argument of the corresponding ~c[FM*] function; ~pl[fmt].

  ~c[Fmt-control-alist] should typically evaluate to an alist that maps
  print-control variables to values; ~pl[print-control].  Any alist mapping
  variables to values is legal, however.  By default the print controls are set
  according to the value of constant ~c[*fmt-control-defaults*];
  ~c[fmt-control-alist] overrides these defaults.  For example,
  ~c[*fmt-control-defaults*] sets the right margin just as it is set in the
  initial ACL2 ~il[state], by binding ~c[fmt-soft-right-margin] and
  ~c[fmt-hard-right-margin] to their respective defaults of
  ~c[*fmt-soft-right-margin-default*] and ~c[*fmt-hard-right-margin-default*].
  The following example shows how you can override those defaults, in this case
  arranging to print flat by setting the right margin to a large number.
  ~bv[]
  (fmt-to-string \"~~x0\"
                 (list (cons #\\0 (make-list 30)))
                 :fmt-control-alist
                 `((fmt-soft-right-margin . 10000)
                   (fmt-hard-right-margin . 10000)))
  ~ev[]

  ~c[Iprint] is typically ~c[nil], but ~c[t] is also a legal value.
  ~l[set-iprint] for the effect of value ~c[t], which however is local to this
  call of a ~c[FM*-TO-STRING] function; the behavior if iprinting afterwards is
  not affected by this call.  In particular, you will not be able to look at
  the values of iprint tokens printed by this call, so the value ~c[t] is
  probably of limited utility at best.~eq[]

  Also ~pl[io] for a discussion of the utility ~c[get-output-stream-string$],
  which allows for accumulating the results of more than one printing call into
  a single string but requires the use of ~ilc[state].~/~/")

(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.

  (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*)))

; 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)

; Alist is a variable whose value is an alist used to modify
; fmt-control-defaults-tail, which is a tail of *fmt-control-defaults*.

  (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))))
                        (cddr trip)))
               (fmt-control-bindings1 alist
                                      (cdr fmt-control-defaults-tail))))))

(defun fmt-control-bindings (alist)
  (cond (alist (fmt-control-bindings1 alist *fmt-control-defaults*))
        (t ; optimization
         *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.

  (prog2$ (compress1 'iprint-ar iprint-ar)
          (f-put-global 'iprint-ar iprint-ar state)))

(defmacro channel-to-string (form channel-var
                                  &optional
                                  extra-var fmt-controls iprint-action)

; 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!

; Note that fmt-controls and iprint-action are evaluated, but channel-var and
; extra-var are not evaluated.

; Any non-nil value of iprint-action is coerced to t before being passed to
; (a function underneath) set-iprint.

; This macro is not recommended for users, as it has been designed specifically
; for the fmt family of functions.  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 iprint-action)
;     (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 iprint-action))
;   (defmacro fmt-to-string-again
;     (str alist &key evisc-tuple fmt-control-alist iprint)
;     (declare (xargs :guard (member-eq iprint '(t nil))))
;     `(fmt-to-string-fn ,str ,alist ,evisc-tuple ,fmt-control-alist ,iprint))

; 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)
                              (symbolp iprint-action)
                              (not (eq 'result extra-var))
                              (not (eq 'state extra-var)))))
  (let* ((body0 ; error triple (mv nil val state), where val may cons extra-var
          `(mv?-let
            (,@(and extra-var (list extra-var)) state)
            ,form
            (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
          `(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)
             (mv-let (msg state)
                     (set-iprint-fn1
                      (if ,iprint-action :reset-enable :reset)
                      state)
                     (declare (ignore msg))
                     ,body0))
            (cond ((open-output-channel-p ,channel-var :character state)
                   (close-output-channel ,channel-var state))
                  (t 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 (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))))))

(defun fms-to-string-fn (str alist evisc-tuple fmt-control-alist iprint-action)
  (channel-to-string
   (fms str alist chan-do-not-use-elsewhere state evisc-tuple)
   chan-do-not-use-elsewhere nil fmt-control-alist iprint-action))

(defmacro fms-to-string (str alist &key evisc-tuple fmt-control-alist iprint)
  (declare (xargs :guard (member-eq iprint '(t nil))))
  `(fms-to-string-fn ,str ,alist ,evisc-tuple ,fmt-control-alist ,iprint))

(defun fms!-to-string-fn (str alist evisc-tuple fmt-control-alist iprint-action)
  (channel-to-string
   (fms! str alist chan-do-not-use-elsewhere state evisc-tuple)
   chan-do-not-use-elsewhere nil fmt-control-alist iprint-action))

(defmacro fms!-to-string (str alist &key evisc-tuple fmt-control-alist iprint)
  (declare (xargs :guard (member-eq iprint '(t nil))))
  `(fms!-to-string-fn ,str ,alist ,evisc-tuple ,fmt-control-alist ,iprint))

(defun fmt-to-string-fn (str alist evisc-tuple fmt-control-alist iprint-action)
  (channel-to-string
   (fmt str alist chan-do-not-use-elsewhere state evisc-tuple)
   chan-do-not-use-elsewhere col fmt-control-alist iprint-action))

(defmacro fmt-to-string (str alist &key evisc-tuple fmt-control-alist iprint)
  (declare (xargs :guard (member-eq iprint '(t nil))))
  `(fmt-to-string-fn ,str ,alist ,evisc-tuple ,fmt-control-alist ,iprint))

(defun fmt!-to-string-fn (str alist evisc-tuple fmt-control-alist
                              iprint-action)
  (channel-to-string
   (fmt! str alist chan-do-not-use-elsewhere state evisc-tuple)
   chan-do-not-use-elsewhere col fmt-control-alist iprint-action))

(defmacro fmt!-to-string (str alist &key evisc-tuple fmt-control-alist iprint)
  (declare (xargs :guard (member-eq iprint '(t nil))))
  `(fmt!-to-string-fn ,str ,alist ,evisc-tuple ,fmt-control-alist ,iprint))

(defun fmt1-to-string-fn (str alist col evisc-tuple fmt-control-alist
                              iprint-action)
  (channel-to-string
   (fmt1 str alist col chan-do-not-use-elsewhere state evisc-tuple)
   chan-do-not-use-elsewhere col fmt-control-alist iprint-action))

(defmacro fmt1-to-string (str alist col &key evisc-tuple fmt-control-alist
                              iprint)
  (declare (xargs :guard (member-eq iprint '(t nil))))
  `(fmt1-to-string-fn ,str ,alist ,col ,evisc-tuple ,fmt-control-alist ,iprint))

(defun fmt1!-to-string-fn (str alist col evisc-tuple fmt-control-alist
                            iprint-action)
  (channel-to-string
   (fmt1! str alist col chan-do-not-use-elsewhere state evisc-tuple)
   chan-do-not-use-elsewhere col fmt-control-alist iprint-action))

(defmacro fmt1!-to-string (str alist col &key evisc-tuple fmt-control-alist
                               iprint)
  (declare (xargs :guard (member-eq iprint '(t nil))))
  `(fmt1!-to-string-fn ,str ,alist ,col ,evisc-tuple ,fmt-control-alist ,iprint))

(link-doc-to fms-to-string acl2-built-ins printing-to-strings)
(link-doc-to fms!-to-string acl2-built-ins printing-to-strings)
(link-doc-to fmt-to-string acl2-built-ins printing-to-strings)
(link-doc-to fmt!-to-string acl2-built-ins printing-to-strings)
(link-doc-to fmt1-to-string acl2-built-ins printing-to-strings)
(link-doc-to fmt1!-to-string acl2-built-ins printing-to-strings)

(defdoc dead-events

  ":Doc-Section Other

  using proof supporters to identify dead code and unused theorems~/

  Below, when we talk about ``an event ~c[A]'', we mean an event whose name is
  ~c[A].

  When event ~c[A] is used in a proof performed to admit event ~c[B] that you
  submit to ACL2, we say that ~c[A] is a ``proof-supporter'' of ~c[B].  ACL2
  stores an association list such that for every event ~c[B] with at least one
  proof-supporter, ~c[B] is associated with a list of all of its
  proof-supporters, sorted by ~ilc[symbol-<].  The following form evaluates to
  that alist, which is called the ``proof-supporters-alist''.
  ~bv[]
  (global-val 'proof-supporters-alist (w state))
  ~ev[]
  By ``used in a proof'' above, we mean: applied as a rule or supplied
  explicitly via ~il[hints] of type ~c[:use], ~c[:by], or
  ~c[:clause-processor].  That is, the ~il[events] ``used in a proof'' for
  admitting an event ~c[E] are those listed in the summary printed at the
  conclusion of admitting ~c[E].~/

  Note that if proofs are skipped when admitting event ~c[E], say because the
  last admission of ~c[E] was done by ~ilc[include-book] (or ~c[certify-book],
  which ends with an ~ilc[include-book]), then there will be no entry in that
  alist for ~c[E].  (An exception is made however for ~ilc[encapsulate]
  ~il[events], where proof-supporters are remembered from the first pass; see
  below.)  So if you want the proof-supporters-alist to include supporters for
  events in a book, use ~ilc[ld] rather than ~ilc[include-book] or
  ~ilc[certify-book] to process the events in that book.  If however you are
  interested in the proof-supporters FROM a book that support a later event,
  then it is fine to include that book.

  The case for ~ilc[encapsulate] is slightly tricky.  Consider an example of
  the following form.
  ~bv[]
  A ; event preceding the encapsulate
  (encapsulate
   ()
   B
   (local C) ; uses A and B in a proof
   D ; uses C in a proof
   )
  ~ev[]
  At the conclusion of this ~ilc[encapsulate] event, the proof-supporters-alist
  associates ~c[D] with ~c[A] and ~c[B], but not ~c[C] (which has disappeared,
  since it is ~il[local]).

  Note that this sort of ``transitive closure'' operation is only performed
  when necessary due to the disappearance of ~il[local] ~il[events].  For
  example, if we replace ~c[(local C)] above by just ~c[C], then ~c[D] is
  associated in the proof-supporters-alist only with ~c[C], not with ~c[A] or
  ~c[B].  If you want the transitive closure of the relation computed by the
  proof-supporters-alist, you have to compute it yourself. (This was a
  deliberate design decision, in order to avoid slowing down event processing.)
  However, there is help available on how to do such a computation:

  A community book, ~c[books/misc/dead-events.lisp], does such a transitive
  closure, and moreover uses that information to find ``dead events'' relative
  to a list of ``desired'' events.  For example, suppose you use ~ilc[LD] to
  process the events, with proofs, in a book intended to prove theorems
  ~c[MAIN-1] and ~c[MAIN-2].  (Remember, ~ilc[certify-book] will not save such
  information.)  Suppose furthermore that the book begins with some
  ~ilc[include-book] forms followed by ~c[(deflabel book-start)].  You could
  evaluate this form:
  ~bv[]
  (dead-events '(main-1 main-2) :start 'book-start)
  ~ev[]
  The result is a list of events that you probably can delete from the book
  without causing any proofs to fail.  See the ~c[dead-events.lisp] book for
  further documentation.

  You might also find the code in the above book to be helpful for writing your
  own utilities based on the proof-supporters-alist.~/")

(link-doc-to proof-supporters-alist miscellaneous dead-events)

; Essay on Memoization with Attachments (relevant for #+hons version only)

; 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 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 it 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.  Morover, 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.

; Let m 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, retract-world1, and recover-world
; so that they do not update such fields or clear memo-tables until all trips
; have been processed.  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 variable 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 to check attachments for siblings of
; functions in L.  In particular, if L is empty then nothing needs to be done.

;;; Going backward, when we see that an extended ancestor attachment has
;;; changed or been added for the memo table of fn, then add fn to a list of
;;; functions that will eventually have their memo tables strongly cleared when
;;; we finish retract-world1.  (How about recover-world?  Perhaps just strongly
;;; clear all memo tables unless I find a better idea.)

; Start code supporting extended-ancestors.

(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 extended-ancestors4 (fns wrld fal)
  (cond ((endp fns) fal)
        (t (extended-ancestors4
            (cdr fns)
            wrld
            (cond ((hons-get (car fns) fal)
                   fal)
                  (t (hons-acons (car fns)
                                 (sibling-attachments (car fns) wrld)
                                 fal)))))))

(defun extended-ancestors3 (components wrld fal)
  (cond ((endp components) fal)
        (t (extended-ancestors3
            (cdr components)
            wrld
            (let ((anc (access attachment-component (car components) :ord-anc))
                  (path (access attachment-component (car components) :path)))
              (extended-ancestors4
               (if path
                   (cons (car path) ; attachment-component-owner
                         anc)
                 anc)
               wrld
               fal))))))

(defun extended-ancestors2 (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)
                    (extended-ancestors2
                     (cdr canon-gs) arfal wrld canon-gs-fal fal))
                   (t (let ((rec (cdr (hons-get g arfal))))
                        (extended-ancestors2
                         (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 (extended-ancestors3
                                       (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 extended-ancestors1 (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)
         (extended-ancestors2 canon-gs arfal wrld 'extended-ancestors2 fal))
        ((hons-get (car fns) fal)
         (extended-ancestors1 (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)))))
             (extended-ancestors1
              (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 extended-ancestors (f wrld)

; The implementation of this function uses hons-acons, so might only be
; efficient when #+hons (which was its intended use when written).

  (extended-ancestors1 (cons (canonical-sibling f wrld)
                             (canonical-ancestors f 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 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.

; Acc is initially t, but is nil when we find that an alist needs to grow.

  (cond ((endp fns) acc)
        (t (let* ((f (car fns))
                  (siblings (siblings f wrld))
                  (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
                  wrld
                  (and acc
                       (ext-anc-attachments-valid-p-1 siblings alist wrld))))))))

; Start definitions related to defun-inline.

(defconst *inline-suffix* "$INLINE")
(defconst *inline-suffix-len-minus-1* (1- (length *inline-suffix*)))
(defconst *notinline-suffix* "$NOTINLINE")
(defconst *notinline-suffix-len-minus-1* (1- (length *notinline-suffix*)))
(defconst *non-stobj-var-root* (coerce (symbol-name 'non-stobj-var) 'list))

(defun defun-inline-form (name formals lst defun-type suffix)

; Defun-type is DEFUN or DEFUND; suffix is *inline-suffix* or
; *notinline-suffix*.

  (declare (xargs :mode :program
                  :guard (and (symbolp name)
                              (symbol-listp formals)
                              lst
                              (<= (number-of-strings (butlast lst 1))
                                  1)
                              (or (eq defun-type 'defun)
                                  (eq defun-type 'defund))
                              (or (equal suffix *inline-suffix*)
                                  (equal suffix *notinline-suffix*)))))
  (let* ((name$inline
          (intern-in-package-of-symbol
           (concatenate 'string (symbol-name name) suffix)
           name))
         (dcls-and-strings (butlast lst 1))
         (strings (get-string dcls-and-strings))
         (dcls (remove-strings dcls-and-strings))
         (body (car (last lst)))
         (macro-formals formals))
    `(progn (defmacro ,name ,macro-formals
              ,@strings
              (list ',name$inline ,@macro-formals))
            (add-macro-fn ,name ,name$inline)
            (,defun-type ,name$inline ,formals ,@dcls ,body))))

(defmacro defun-inline (name formals &rest lst)

  ":Doc-Section acl2::Events

  define a potentially inlined function symbol and associated macro~/

  You may be able to improve performance by replacing an event
  ~c[(defun f ...)] with a corresponding event ~c[(defun-inline f ...)], in
  order to encourage the host Lisp compiler to inline calls of ~c[f].

  ~bv[]
  Example Form:
  (defun-inline lng (x)
    (declare (xargs :guard (true-listp x)))
    (if (endp x) 0 (1+ (lng (cdr x)))))~/

  General Form:
  (defun-inline fn (var1 ... varn) doc-string dcl ... dcl body)
  ~ev[]
  satisfying the same requirements as in the General Form for ~ilc[defun].  The
  effect is to define a macro ~c[fn] and a function ~c[fn$inline] (i.e., a
  symbol in the same package as ~c[fn] but whose ~ilc[symbol-name] has the
  suffix ~c[\"$INLINE\"], such that each call of ~c[fn] expands to a call of
  the function symbol ~c[fn$inline] on the same arguments.  If ~c[doc-string]
  is supplied, then it is associated with ~c[fn], not with ~c[fn$inline].
  Moreover, ~ilc[table] ~il[events] are generated that allow the use of ~c[fn]
  in ~il[theory] expressions to represent ~c[fn$inline] and that cause any
  untranslated (user-level) call of ~c[fn$inline] to be printed as the
  corresponding call of ~c[fn].

  A form ~c[(defun-inline f ...)] actually defines a function named
  ~c[f$inline] and a corresponding macro named ~c[f] whose calls expand to
  calls of ~c[f$inline], while providing the illusion that there is just the
  ``function'' ~c[f].  For example, the Example Form above macroexpands in one
  step to the following form.
  ~bv[]
  (progn (defmacro lng (non-stobj-var0)
           (list 'lng$inline non-stobj-var0))
         (add-macro-fn lng lng$inline)
         (defun lng$inline (x)
           (declare (xargs :guard (true-listp x)))
           (if (endp x) 0 (1+ (lng (cdr x))))))
  ~ev[]
  Note that the above call of ~ilc[add-macro-fn] generates the aforementioned
  two table events (~pl[add-macro-fn]), which provide the illusion that we are
  just defining a function ~c[lng], as you can see in the following log:
  ~c[lng] appears rather than ~c[lng$inline].
  ~bv[]
  ACL2 !>(set-gag-mode nil)
  <state>
  ACL2 !>(thm (equal (lng (append x y))
                     (+ (lng x) (lng y)))
              :hints ((\"Goal\" :in-theory (enable lng))))

  [.. output omitted ..]

  Subgoal *1/2
  (IMPLIES (AND (NOT (ENDP X))
                (EQUAL (LNG (APPEND (CDR X) Y))
                       (+ (LNG (CDR X)) (LNG Y))))
           (EQUAL (LNG (APPEND X Y))
                  (+ (LNG X) (LNG Y)))).

  [.. output omitted ..]
  ~ev[]

  Under the hood, ACL2 arranges that every function symbol with suffix
  ~c[\"$INLINE\"] is presented to the compiler as one whose calls we would
  prefer to inline.  Technically: the Common Lisp form
  ~c[(declaim (inline f$inline))] is generated for a function symbol
  ~c[f$inline] before that symbol's definition is submitted.  However, the
  Common Lisp spec explicitly avoids requiring that the compiler respect this
  ~c[declaim] form.  Fortunately, Common Lisp implementations often do respect
  it.

  Also ~pl[defund-inline], ~pl[defun-notinline], and ~pl[defund-notinline].

  ~em[Remarks].

  (1) None of these macros (including ~c[defun-inline]) is supported for use
  inside a ~ilc[mutual-recursion].

  (2) Every function symbol defined in ACL2 whose ~ilc[symbol-name] has the
  suffix ~c[\"$INLINE\"] is proclaimed to be inline; similarly for
  ~c[\"$NOTINLINE\"] and notinline.

  (3) No special treatment for inlining (or notinlining) is given for function
  symbols locally defined by ~ilc[flet], with two exceptions: when explicitly
  declared ~c[inline] or ~c[notinline] by the ~c[flet] form, and for symbols
  discussed in (1) and (2) above that, at some point in the current ACL2
  session, were defined as function symbols in ACL2 (even if not currently
  defined because of undoing or being ~il[local]).

  (4) The function symbol actually being defined by ~c[(defun-inline foo ...)]
  is ~c[foo$inline].  As mentioned above, one can be oblivious to this fact
  when writing ~il[theory] expressions or perusing prover output.  However, for
  other purposes (for example, ~ilc[verify-guards] and ~ilc[defabsstobj]
  ~c[:exports]) you will need to supply the name of the function symbol rather
  than the name of the macro; e.g., for the above form
  ~c[(defun-inline foo ...)], you may subsequently issue the event
  ~c[(verify-guards foo$inline)] but not ~c[(verify-guards foo)].

  (5) Obscure Remark.  Suppose that you certify a book with compilation (the
  default) in one host Lisp, saving the expansion file.  Suppose that you then
  compile in another host Lisp by using ~ilc[include-book] with argument
  ~c[:load-compiled-file :comp].  Then in subsequent sessions, including that
  book with the second host Lisp will not result in any inline or notinline
  behavior for functions defined in the book.  This may be fixed in a future
  release if someone complains.~/"

; Implementor hint for (5) above: Search for ";;; Declaim forms:" in
; write-expansion-file, and notice the printing just below it of a readtime
; conditional for the host Lisp, so that declaim forms are restricted to that
; Lisp.  This mechanism was probably put into place so that declaiming for GCL
; didn't result in declaiming for Allegro CL, or something along those lines.

  (defun-inline-form name formals lst 'defun *inline-suffix*))

(defmacro defund-inline (name formals &rest lst)

; Warning: Keep this in sync with defun-inline.

  ":Doc-Section acl2::Events

  define a potentially disabled, inlined function symbol and associated macro~/

  ~c[Defund-inline] is a variant of ~ilc[defun-inline], the difference being
  that ~c[defund-inline] disables the newly-defined function symbol.
  ~l[defun-inline].~/~/"

  (defun-inline-form name formals lst 'defund *inline-suffix*))

(defmacro defun-notinline (name formals &rest lst)

; Warning: Keep this in sync with defund-notinline.

  ":Doc-Section acl2::Events

  define a not-to-be-inlined function symbol and associated macro~/

  ~l[defun-inline] for an analogous utility that supports inlining.  The
  present utility is probably far less useful; it tells the compiler ~em[not]
  to inline calls of the function being defined.  Also ~pl[defund-notinline]
  for a variant of this event that disables the newly-defined function symbol.

  Under the hood, ~c[(defun-inline f ...)] and ~c[(defun-notinline f ...)]
  cause evaluation of Common Lisp forms ~c[(declaim (inline f$inline))] and
  ~c[(declaim (notinline f$notinline))], respectively.  According to the Common
  Lisp spec, the compiler need not respect the first of these (for ~c[inline]),
  but it must respect the second of these (for ~c[notinline]).  Fortunately,
  Common Lisp implementations often do respect the first of these as well.~/~/"

  (defun-inline-form name formals lst 'defun *notinline-suffix*))

(defmacro defund-notinline (name formals &rest lst)

; Warning: Keep this in sync with defun-inline.

  ":Doc-Section acl2::Events

  define a disabled, not-to-be-inlined function symbol and associated macro~/

  ~c[Defund-notinline] is a variant of ~ilc[defun-notinline], the difference
  being that ~c[defund-notinline] disables the newly-defined function symbol.
  ~l[defun-notinline].~/~/"

  (defun-inline-form name formals lst 'defund *notinline-suffix*))

(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 doc 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
    (if (output-in-infixp state)
        event-form
        (if doc
            "( REGENERATE-TAU-DATABASE ...)"
            "( REGENERATE-TAU-DATABASE)"))
    (let* ((wrld (w state))
           (event-form (or event-form
                           `(REGENERATE-TAU-DATABASE
                             ,@(if doc
                                   (list :doc doc)
                                   nil))))
           (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*
        ((doc-pair (translate-doc nil doc ctx state))
         (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 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*
          (delete-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.  Specify :INIT first to solve this problem.  ~
           See :DOC time-tracker."
          tag))
     ((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.  Specify :START first to ~
           solve this problem.  See :DOC time-tracker."
          tag))
     (t (setf (time-tracker-elapsed tt)
              (+ (time-tracker-elapsed tt)
                 (- (get-internal-time) latest)))
        (setf (time-tracker-latest tt)
              nil)))))

(defun tt-start (tag)
  (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.  Specify :INIT first to solve this problem.  ~
           See :DOC time-tracker."
          tag))
     ((time-tracker-latest tt)
      (er hard 'time-tracker
          "It is illegal to specify :START for tag ~x0, because tracking for ~
           this tag is already in an active state.  Specify :STOP first to ~
           solve this problem.  See :DOC time-tracker."
          tag))
     (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.

(defun program-declared-p1 (dcls)
  (cond ((endp dcls) nil)
        ((and (consp (car dcls))
              (eq (caar dcls) 'xargs)
              (keyword-value-listp (cdr (car dcls)))
              (eq (cadr (assoc-keyword :mode (cdr (car dcls))))
                  :program))
         t)
        (t (program-declared-p1 (cdr dcls)))))

(defun program-declared-p (def)

; Def is a definition with the initial DEFUN or DEFUND stripped off.  We return
; t if the declarations in def are minimally well-formed and there is an xargs
; declaration of :mode :program.

  (mv-let (erp dcls)
          (collect-dcls (remove-strings (butlast (cddr def) 1)) 'ignored-ctx)
          (cond (erp nil)
                (t (program-declared-p1 dcls)))))

#+acl2-loop-only
(defmacro defund (&rest def)

  ":Doc-Section acl2::Events

  define a function symbol and then disable it~/~/

  Use ~c[defund] instead of ~ilc[defun] when you want to disable a function
  immediately after its definition in ~c[:]~ilc[logic] mode.  This macro has
  been provided for users who prefer working in a mode where functions are only
  enabled when explicitly directed by ~c[:]~ilc[in-theory].  Specifically, the
  form
  ~bv[]
  (defund NAME FORMALS ...)
  ~ev[]
  expands to:
  ~bv[]
  (progn
    (defun NAME FORMALS ...)
    (with-output
     :off summary
     (in-theory (disable NAME)))
    (value-triple '(:defund NAME))).
  ~ev[]
  Only the ~c[:]~ilc[definition] rule (and, for recursively defined functions,
  the ~c[:]~ilc[induction] rule) for the function are disabled.  In particular,
  ~c[defund] does not disable either the ~c[:]~ilc[type-prescription] or the
  ~c[:]~ilc[executable-counterpart] rule.  Also, the summary for the
  ~ilc[in-theory] event is suppressed.

  If the function is defined in ~c[:]~ilc[program] mode, either because the
  ~il[default-defun-mode] is ~c[:]~ilc[program] or because ~c[:mode :program]
  has been specified in an ~ilc[xargs] form of a ~ilc[declare] form, then no
  ~ilc[in-theory] event is executed.  (More precisely, ~ilc[in-theory] events
  are ignored when the ~il[default-defun-mode] is ~c[:]~ilc[program], and if
  ~c[:mode :program] is specified then ~c[defund] does not generate an
  ~ilc[in-theory] event.)

  Note that ~c[defund] commands are never redundant (~pl[redundant-events])
  when the ~il[default-defun-mode] is ~c[:]~ilc[logic], because the
  ~ilc[in-theory] event will always be executed.

  ~l[defun] for documentation of ~c[defun]."

  (declare (xargs :guard (and (true-listp def)
                              (symbolp (car def))
                              (symbol-listp (cadr def)))))

  `(progn (defun ,@def)
          ,@(and (not (program-declared-p def))
                 `((with-output
                    :off summary
                    (in-theory (disable ,(car def))))))
          (value-triple ',(xd-name 'defund (car def))
                        :on-skip-proofs t)))

#-acl2-loop-only
(defmacro defund (&rest def)
  (cons 'defun def))

; The next three events define a :logic mode version of ev-fncall that has
; unknown constraints.  We originally put this in boot-strap-pass-2.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 are evaluated.

(defun magic-ev-fncall-cl-proc (x)

; This function is a sort of placeholder, used in a
; define-trusted-clause-processor event for noting that magic-ev-fncall has
; unknown constraints.

  (declare (xargs :guard t))
  (list x))

#+acl2-loop-only
(encapsulate
 ()
 (define-trusted-clause-processor
   magic-ev-fncall-cl-proc
   (magic-ev-fncall)
   :partial-theory
   (encapsulate
    (((magic-ev-fncall * * state * *) => (mv * *)))
    (logic)
    (local (defun magic-ev-fncall (fn args state hard-error-returns-nilp aok)
             (declare (xargs :mode :logic)
                      (ignore fn args state hard-error-returns-nilp aok))
             (mv nil nil))))))

#-acl2-loop-only
(defun-overrides magic-ev-fncall (fn args state hard-error-returns-nilp aok)
  (let ((wrld (w state)))
    (cond ((and (symbolp fn)
                (true-listp args)
                (let ((formals
                       (getprop fn 'formals t 'current-acl2-world wrld)))
                  (and (not (eq formals t)) ; (function-symbolp fn wrld)
                       (eql (length args) (length formals))))
                (logicalp fn wrld))
           (ev-fncall fn args state
                      nil ; latches
                      hard-error-returns-nilp aok))
          (t (mv t
                 (cw "~%~%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 (getprop fn 'formals t 'current-acl2-world wrld) t)
                       (msg "~x0 is not a known function symbol in the ~
                             current ACL2 logical world"
                            fn))
                      ((not (eql (length args)
                                 (length (getprop fn 'formals t
                                                  'current-acl2-world wrld))))
                       (msg "The length of that args is ~x0, but ~x1 takes ~
                             ~x2 arguments"
                            (length args)
                            fn
                            (length (getprop fn 'formals t
                                             'current-acl2-world wrld))))
                      (t
                       (assert (not (logicalp fn wrld)))
                       (msg "~x0 is not a logic-mode function symbol"
                            fn)))))))))

