acl2-source 7.2dfsg-3 / usr / share / acl2-7.2dfsg / other-events.lisp

; ACL2 Version 7.2 -- A Computational Logic for Applicative Common Lisp
; Copyright (C) 2016, Regents of the University of Texas

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

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

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

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

(in-package "ACL2")

;  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 w state)
  (let ((w (putprop name 'const (kwote val) w)))
    (value w)))

#-acl2-loop-only
(progn

; See the Essay on Hash Table Support for Compilation.

(defvar *hcomp-fn-ht* nil)
(defvar *hcomp-const-ht* nil)
(defvar *hcomp-macro-ht* nil)
(defvar *hcomp-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
  (cond
   ((f-get-global 'boot-strap-flg state)

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

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

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

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

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

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

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

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

; ;;; char-bug-sub.lisp

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

; ;;; char-bug.lisp

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

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

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

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

(defun large-consp (x)
  (eql (the (signed-byte 30)
            (cons-count-bounded x))
       (the (signed-byte 30)
            (fn-count-evg-max-val))))

(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 (getpropc name 'const nil wrld1)))
        (cond
         ((and const-prop
               (not (ld-redefinition-action state))

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

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

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

          (stop-redundant-event ctx state))
         (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 nil 'const nil ctx wrld1 state))
                (wrld3 (defconst-fn1 name val wrld2 state)))
               (install-event name
                              event-form
                              'defconst
                              name
                              nil
                              (list 'defconst name form val)
                              nil nil wrld3 state)))))))))))))

(defun 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 guard body w state)
  (let ((w (putprop
            name 'macro-args args
            (putprop
             name 'macro-body body

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

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

(defun 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 (getpropc name 'absolute-event-number nil w)

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

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

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

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

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

  (with-ctx-summarized
   (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 ((edcls (if (stringp (car edcls)) (cdr edcls) edcls)))
               (er-let*
                   ((tguard (translate
                             (conjoin-untranslated-terms
                              (get-guards1 edcls '(guards types) 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 (f-get-global 'boot-strap-flg state))
                                (not (f-get-global 'redundant-with-raw-code-okp
                                                   state))
                                (member-eq name
                                           (f-get-global 'macros-with-raw-code
                                                         state)))

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

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

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

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

(defconst *initial-event-defmacros*
  '((defmacro in-package (str)
      (list 'in-package-fn
            (list 'quote str)
            'state))
    (defmacro defpkg (&whole event-form name form &optional doc book-path)
      (list 'defpkg-fn
            (list 'quote name)
            (list 'quote form)
            'state
            (list 'quote doc)
            (list 'quote book-path)
            (list 'quote hidden-p)
            (list 'quote event-form)))
    (defmacro defchoose (&whole event-form &rest def)
      (list 'defchoose-fn
            (list 'quote def)
            'state
            (list 'quote event-form)))
    (defmacro defun (&whole event-form &rest def)
      (list 'defun-fn
            (list 'quote def)
            'state
            (list 'quote event-form)
            #+:non-standard-analysis ; std-p
            nil))
    (defmacro defuns (&whole event-form &rest def-lst)
      (list 'defuns-fn
            (list 'quote def-lst)
            'state
            (list 'quote event-form)
            #+:non-standard-analysis ; std-p
            nil))
    (defmacro verify-termination-boot-strap (&whole event-form &rest lst)
      (list 'verify-termination-boot-strap-fn
            (list 'quote lst)
            'state
            (list 'quote event-form)))
    (defmacro verify-guards (&whole event-form name
                                    &key hints otf-flg guard-debug)
      (list 'verify-guards-fn
            (list 'quote name)
            'state
            (list 'quote hints)
            (list 'quote otf-flg)
            (list 'quote guard-debug)
            (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)
      (list 'defthm-fn
            (list 'quote name)
            (list 'quote term)
            'state
            (list 'quote rule-classes)
            (list 'quote instructions)
            (list 'quote hints)
            (list 'quote otf-flg)
            (list 'quote event-form)
            #+:non-standard-analysis ; std-p
            nil))
    (defmacro defaxiom (&whole event-form
                               name term
                               &key (rule-classes '(:REWRITE)))
      (list 'defaxiom-fn
            (list 'quote name)
            (list 'quote term)
            'state
            (list 'quote rule-classes)
            (list 'quote event-form)))
    (defmacro deflabel (&whole event-form name)
      (list 'deflabel-fn
            (list 'quote name)
            'state
            (list 'quote event-form)))
    (defmacro deftheory (&whole event-form name expr)
      (list 'deftheory-fn
            (list 'quote name)
            (list 'quote expr)
            'state
            (list 'quote event-form)))
    (defmacro in-theory (&whole event-form expr)
      (list 'in-theory-fn
            (list 'quote expr)
            'state
            (list 'quote event-form)))
    (defmacro in-arithmetic-theory (&whole event-form expr)
      (list 'in-arithmetic-theory-fn
            (list 'quote expr)
            'state
            (list 'quote event-form)))
    (defmacro regenerate-tau-database (&whole event-form)
      (list 'regenerate-tau-database-fn
            'state
            (list 'quote event-form)))
    (defmacro push-untouchable (&whole event-form name fn-p)
      (list 'push-untouchable-fn
            (list 'quote name)
            (list 'quote fn-p)
            'state
            (list 'quote event-form)))
    (defmacro reset-prehistory (&whole event-form &optional permanent-p)
      (list 'reset-prehistory-fn
            (list 'quote permanent-p)
            'state
            (list 'quote event-form)))
    (defmacro set-body (&whole event-form fn name-or-rune)
      (list 'set-body-fn
            (list 'quote fn)
            (list 'quote name-or-rune)
            'state
            (list 'quote event-form)))
    (defmacro table (&whole event-form name &rest args)
      (list 'table-fn
            (list 'quote name)
            (list 'quote args)
            'state
            (list 'quote event-form)))
    (defmacro progn (&rest r)
      (list 'progn-fn
            (list 'quote r)
            'state))
    (defmacro encapsulate (&whole event-form signatures &rest cmd-lst)
      (list 'encapsulate-fn
            (list 'quote signatures)
            (list 'quote cmd-lst)
            'state
            (list 'quote event-form)))
    (defmacro include-book (&whole event-form user-book-name
                                   &key
                                   (load-compiled-file ':default)
                                   (uncertified-okp 't)
                                   (defaxioms-okp 't)
                                   (skip-proofs-okp 't)
                                   (ttags 'nil)
                                   dir)
      (list 'include-book-fn
            (list 'quote user-book-name)
            'state
            (list 'quote load-compiled-file)
            (list 'quote :none)
            (list 'quote uncertified-okp)
            (list 'quote defaxioms-okp)
            (list 'quote skip-proofs-okp)
            (list 'quote ttags)
            (list 'quote dir)
            (list 'quote event-form)))
    (defmacro local (x)
      (list 'if
            '(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))))

(defconst *boot-strap-invariant-risk-symbols*

; The following should contain all function symbols that might violate an ACL2
; invariant.  See check-invariant-risk-state-p.

; We don't include compress1 or compress2 because we believe they don't write
; out of bounds.

  '(aset1 ; could write past the end of the real array
    aset2 ; could write past the end of the real array
    extend-32-bit-integer-stack
    aset-32-bit-integer-stack))

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

;   (getpropc 'memoize-table 'table-guard *t*)

; 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)
                    (cert-replay 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 deftheory
                         in-theory in-arithmetic-theory regenerate-tau-database
                         push-untouchable remove-untouchable set-body table
                         reset-prehistory verify-guards verify-termination-boot-strap
                         local defchoose ld-skip-proofsp
                         in-package-fn defpkg-fn defun-fn defuns-fn
                         mutual-recursion-fn defmacro-fn defconst-fn
                         defstobj-fn
                         defthm-fn defaxiom-fn progn-fn encapsulate-fn
                         include-book-fn deflabel-fn
                         deftheory-fn in-theory-fn in-arithmetic-theory-fn
                         regenerate-tau-database-fn
                         push-untouchable-fn remove-untouchable-fn
                         reset-prehistory-fn set-body-fn
                         table-fn verify-guards-fn verify-termination-boot-strap-fn
                         defchoose-fn apply o-p o<
                         defattach defattach-fn
                         default-defun-mode-from-state skip-when-logic

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

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

                         ,@*boot-strap-invariant-risk-symbols*

                         ))
                    (ttags-seen nil)
                    (never-untouchable-fns 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.

          ))

(defun initialize-invariant-risk (wrld)

; We put a non-nil 'invariant-risk property on every function that might
; violate some ACL2 invariant, if called on arguments that fail to satisfy that
; function's guard.  Also see put-invariant-risk.

; At one point we thought we should do this for all functions that have raw
; code and have state as a formal:

;;; (initialize-invariant-risk-1
;;;  *primitive-program-fns-with-raw-code*
;;;  (initialize-invariant-risk-1
;;;   *primitive-logic-fns-with-raw-code*
;;;   wrld
;;;   wrld)
;;;  wrld)

; where:

;;; (defun initialize-invariant-risk-1 (fns wrld wrld0)
;;; 
;;; ; We could eliminate wrld0 and do our lookups in wrld, but the extra
;;; ; properties in wrld not in wrld0 are all 'invariant-risk, so looking up
;;; ; 'formals properties in wrld0 may be more efficient.
;;; 
;;;   (cond ((endp fns) wrld)
;;;         (t (initialize-invariant-risk-1
;;;             (cdr fns)
;;;             (if (member-eq 'state
;;; 
;;; ; For robustness we do not call formals here, because it causes an error in
;;; ; the case that it is not given a known function symbol, as can happen (for
;;; ; example) with a member of the list *primitive-program-fns-with-raw-code*.
;;; ; In that case, the following getprop will return nil, in which case the
;;; ; above member-eq test is false, which works out as expected.
;;; 
;;;                            (getprop (car fns) 'formals nil wrld0))
;;;                 (putprop (car fns) 'invariant-risk (car fns) wrld)
;;;               wrld)
;;;             wrld0))))

; But we see almost no way to violate an invariant by misguided updates of the
; (fictional) live state.  For example, state-p1 specifies that the
; global-table is an ordered-symbol-alistp, but there is no way to get one's
; hands directly on the global-table; and state-p1 also specifies that
; plist-worldp holds of the logical world, and we ensure that by making set-w
; and related functions untouchable.  The only exceptions are those in
; *boot-strap-invariant-risk-symbols*, as is checked by the function
; check-invariant-risk-state-p.  If new exceptions arise, then we should add
; them to the value of *boot-strap-invariant-risk-symbols*.

  (putprop-x-lst2 *boot-strap-invariant-risk-symbols* 'invariant-risk
                  *boot-strap-invariant-risk-symbols* wrld))

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

(defun primordial-world (operating-system)

; Warning: Names converted during the boot-strap from :program mode to :logic
; mode will, we believe, have many properties erased by renew-name.  That is
; why, for example, we call initialize-invariant-risk at the end of the
; boot-strap, in end-prehistoric-world.  Consider whether a property should be
; set there rather than here.

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

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

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

                       (putprop
                        'state 'stobj '(*the-live-state*)
                        (primordial-world-globals
                         operating-system)))))))))))))))))))
      t
      nil))))

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

(defun conflicting-imports (l)

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

  (same-name-twice l))

(defun chk-new-stringp-name (ev-type name ctx w state)
  (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)))))))

(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 remove-lisp-suffix (x dotp)

; X is a full-book-name, hence a string ending in ".lisp".  We remove that
; "lisp" suffix, leaving the final "." if and only if dotp is true.

  (subseq x 0 (- (length x)
                 (if dotp 5 4))))

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

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

(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 an existing defpkg for ~
      name ~x0~@1.  ~#a~[For example, symbol ~s2::~s3 is in the list of ~
      imported symbols for the ~s4 definition but not for the other.~/The two ~
      have the same lists of imported symbols, but not in the same order.~]  ~
      The existing defpkg is ~#5~[at the top level.~/in the certificate file ~
      for the book ~x7, which is included at the top level.~/in the ~
      certificate file for the book ~x7, which is included via the following ~
      path, from top-most book down to the above file.~|  ~F8~]~@9~@b"
     (cons #\0 name)
     (cons #\1 (if (package-entry-hidden-p package-entry)
                   " that no longer exists in the current ACL2 logical world ~
                  (see :DOC hidden-death-package)"
                 ""))
     (cons #\a (if (or new-not-old old-not-new) 0 1))
     (cons #\2 (symbol-package-name (if new-not-old
                                        (car new-not-old)
                                      (car old-not-new))))
     (cons #\3 (symbol-name (if new-not-old
                                (car new-not-old)
                              (car old-not-new))))
     (cons #\4 (if new-not-old "proposed" "existing"))
     (cons #\5 (zero-one-or-more book-path))
     (cons #\7 (car book-path))
     (cons #\8 (reverse book-path))
     (cons #\9 (if defpkg-book-path
                   "~|This existing defpkg event appears to have been created ~
                  because of a defpkg that was hidden by a local include-book; ~
                  see :DOC hidden-death-package."
                 ""))
     (cons #\b (let ((include-book-path
                      (global-val 'include-book-path w)))
                 (if (or include-book-path
                         defpkg-book-path)
                     (msg "~|The proposed defpkg event may be found by ~
                           following the sequence of include-books below, ~
                           from top-most book down to the book whose ~
                           portcullis contains the proposed defpkg event.~|  ~
                           ~F0"
                          (reverse (append defpkg-book-path 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 (f-get-global 'boot-strap-flg state))
              (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 (f-get-global 'boot-strap-flg state))))
        (er-let*
         ((pair (simple-translate-and-eval form nil nil
                                           "The second argument to defpkg"
                                           ctx w state nil)))
         (let ((tform (car pair))
               (imports (cdr pair)))
           (cond
            ((not (symbol-listp imports))
             (er soft ctx
                 "The second argument of defpkg must eval to a list of ~
                  symbols.  See :DOC defpkg."))
            (t (let* ((imports (sort-symbol-listp imports))
                      (conflict (conflicting-imports imports))
                      (base-symbol (packn (cons name '("-PACKAGE")))))

; Base-symbol is the 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 nil
                                             'theorem nil ctx w state)
                          (prog2$
                           (chk-package-reincarnation-import-restrictions
                            name imports)
                           (value (list* tform
                                         imports
                                         package-entry ; hidden-p is true
                                         )))))))))))))))))))

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

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

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

; Like defconst, defpkg evals its second argument.

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

  (with-ctx-summarized
   (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* ((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))))))
                  (install-event name
                                 event-form
                                 'defpkg
                                 name
                                 nil
                                 (list 'defpkg name form)
                                 :protect ctx w2 state))))))))

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

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

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

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

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

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

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

; (1) When our theory functions are getting input directly from the
;     user we wish they did a 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.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

(defun set-difference-theories-fn (lst1 lst2 lst1-known-to-be-runic 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))))))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

(defun union-current-theory-fn (lst2 wrld)

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

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

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

(defmacro union-theories (lst1 lst2)

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

  (cond ((equal lst1 '(current-theory :here)) ; optimization
         (list 'union-current-theory-fn
               lst2
               'world))
        ((equal lst2 '(current-theory :here)) ; optimization
         (list 'union-current-theory-fn
               lst1
               'world))
        ((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-current-theory-fn (lst2 wrld)

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

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

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

(defmacro set-difference-theories (lst1 lst2)

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

  (cond ((equal lst1 '(current-theory :here)) ; optimization
         (list 'set-difference-current-theory-fn
               lst2
               'world))
        (t (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.

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

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

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

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

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

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

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

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

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

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

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

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

(defmacro current-theory (logical-name)

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

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

; Essay on Theory Manipulation Performance

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

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

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

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

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

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

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

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

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

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

; End of performance data.

(defconst *initial-return-last-table*
  '((time$1-raw . time$1)
    (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 'cert-replay 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*
                   (initialize-invariant-risk 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
      nil))))

(defun theory-namep (name wrld)

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

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

(defun theory-fn (name wrld)

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

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

(defmacro theory (name)

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

  (list 'theory-fn name 'world))

(defun deftheory-fn (name expr state event-form)

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

; 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))))
      (er-progn
       (chk-all-but-new-name name ctx nil wrld state)
       (er-let* ((wrld1 (chk-just-new-name name nil 'theory nil ctx wrld
                                           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 (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 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)
             (msg "( IN-THEORY ~x0)" expr))
            ((symbolp (car expr))
             (msg "( IN-THEORY (~x0 ...))"
                  (car expr)))
            (t "( IN-THEORY (...))")))
    (let ((wrld (w state))
          (event-form (or event-form
                          (list 'in-theory expr))))
      (er-let*
       ((theory0 (translate-in-theory-hint expr t ctx wrld state)))
       (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 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)
             (msg "( IN-ARITHMETIC-THEORY ~x0)" expr))
            ((symbolp (car expr))
             (msg "( IN-ARITHMETIC-THEORY (~x0 ...))"
                  (car expr)))
            (t "( IN-ARITHMETIC-THEORY (...))")))
    (let ((wrld (w state))
          (event-form (or event-form
                          (list 'in-arithmetic-theory expr))))
      (cond
       ((not (quotep expr))
        (er soft ctx
            "Arithmetic theory expressions must be quoted constants.  ~
             See :DOC in-arithmetic-theory."))
       (t
        (er-let*
          ((theory (translate-in-theory-hint expr t ctx wrld state))
           (ens (load-theory-into-enabled-structure
                 expr theory nil
                 (global-val 'global-arithmetic-enabled-structure wrld)
                 nil nil wrld ctx state)))
          (let ((wrld1 (global-set 'global-arithmetic-enabled-structure ens
                                   wrld)))

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

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

(defmacro disable (&rest rst)

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

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

(defmacro enable (&rest rst)

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

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

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

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

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

(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 formals-pretty-flags-mismatch-msg (formals pretty-flags
                                                  fn
                                                  formals-top
                                                  pretty-flags-top)

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

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

(defun chk-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))
                 (msg (and formals-tail
                           (formals-pretty-flags-mismatch-msg
                            formals pretty-flags1
                            fn
                            formals pretty-flags1))))
            (cond (msg (mv (msg "The object ~x0 is not a legal signature ~
                                 because ~@1.  See :DOC signature."
                                x msg)
                           nil nil nil nil nil))
                  (t (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
                                                  nil
                                                  (list* 'function
                                                         stobjs-in
                                                         stobjs-out)
                                                  nil ctx wrld state)))
                       (value (list* (list fn
                                           formals
                                           stobjs-in
                                           stobjs-out)
                                     kwd-value-list
                                     wrld1))))))))))))

(defun chk-signatures (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-include-book-dir add-include-book-dir!
     add-match-free-override
     comp
     defabsstobj
     defattach
     defaxiom
     defchoose
     defconst
     deflabel
     defmacro
;    defpkg ; We prohibit defpkgs except in very special places.  See below.
     defstobj
     deftheory
     defthm
     defun
     defuns
     delete-include-book-dir delete-include-book-dir!
     encapsulate
     in-arithmetic-theory
     in-theory
     include-book
     logic
     mutual-recursion
     progn
     progn!
     program
     push-untouchable
     regenerate-tau-database
     remove-untouchable
     reset-prehistory
     set-body
     set-override-hints-macro
     set-prover-step-limit
     set-ruler-extenders
     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.

; 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)
; 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-ok
                             set-irrelevant-formals-ok
                             set-let*-abstractionp
                             set-match-free-default
                             set-measure-function
                             set-non-linearp
                             set-prover-step-limit
                             set-rewrite-stack-limit
                             set-ruler-extenders
                             set-state-ok
                             set-tau-auto-mode
                             set-verify-guards-eagerness
                             set-well-founded-relation)))
           (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 in-local-flg
                (member-eq (car form) '(add-include-book-dir!
                                        delete-include-book-dir!)))
           (er soft ctx local-str
               form
               (msg " (see :DOC ~x0)" (car form))
               (chk-embedded-event-form-orig-form-msg orig-form state)
               ""))
          ((and (eq (car form) 'include-book)
                in-encapsulatep
                (or (eq in-local-flg nil)
                    (eq in-local-flg 'local-encapsulate)))

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

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

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

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

           (value form))
          ((and (eq (car form) 'skip-proofs)
                (consp (cdr form))
                (null (cddr form)))
           (pprogn
            (cond ((global-val 'embedded-event-lst wrld)
                   (warning$ ctx "Skip-proofs"
                             "ACL2 has encountered a SKIP-PROOFS form, ~x0, ~
                              in the context of a book or an encapsulate ~
                              event.  Therefore, no logical claims may be ~
                              soundly made in this context.  See :DOC ~
                              SKIP-PROOFS."
                             form))
                  (t state))
            (er-let* ((new-form (chk-embedded-event-form
                                 (cadr form) orig-form wrld ctx state names
                                 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)))))
          ((getpropc (car form) 'macro-body nil 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! ()
  '(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))))
  (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)))))
  #+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)))
  #+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
                 (getpropc (car form) 'stobjs-out t 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, make-include-books-absolute, and
; equal-mod-elide-locals.

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

(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 maybe-add-event-landmark (state)

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

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

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

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

  (cond ((let ((wrld (w state)))
           (not (and (eq (caar wrld)
                         'event-landmark)
                     (eq (cadar wrld)
                         'global-value))))
         (state-global-let*
          ((inhibit-output-lst
            (add-to-set-eq
             'summary
             (f-get-global 'inhibit-output-lst
                           state))))
          (TABLE-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))))

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

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

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

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

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

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

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

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

  (cond
   ((null ev-lst)
    (pprogn (f-put-global 'last-make-event-expansion nil state)
            (mv nil last-val (reverse expansion-alist) kpa state)))
   (t
    (let ((old-wrld (w state)))
      (pprogn
       (cond
        (quietp state)
        (t
         (io? event nil state
              (channel ev-lst)
              (fms "~%~@0~sr ~@1~*2~#3~[~Q45~/~]~|"
                   (list
                    (cons #\0 (f-get-global 'current-package state))
                    (cons #\1 (defun-mode-prompt-string state))
                    (cons #\2 (list "" ">" ">" ">"
                                    (make-list-ac
                                     (1+ (f-get-global 'ld-level state))
                                     nil nil)))
                    (cons #\3 (if (eq (ld-pre-eval-print state) :never)
                                  1
                                0))
                    (cons #\4 (car ev-lst))
                    (cons #\5 (term-evisc-tuple nil state))
                    (cons #\r
                          #+:non-standard-analysis "(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
                          caller ctx channel state))
         (t
          (mv-let
           (erp trans-ans state)
           (pprogn (f-put-global 'last-make-event-expansion nil state)
                   (if (raw-mode-p state)
                       (acl2-raw-eval form state)
                     (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
                   (mv-let
                    (erp ignored-val state)
                    (cond
                     ((and (eq caller 'certify-book)
                           (eq (global-val 'cert-replay (w state)) t))
                      (pprogn
                       (set-w 'extension
                              (global-set 'cert-replay
                                          (cons index old-wrld)
                                          (w state))
                              state)
                       (maybe-add-event-landmark state)))
                     (t (value nil)))
                    (declare (ignore ignored-val))
                    (cond
                     (erp ; very surprising
                      (mv 'make-event-problem index nil nil state))
                     (t
                      (eval-event-lst
                       (1+ index)
                       (cond
                        (expansion0
                         (acons index
                                (make-record-expansion
                                 (car ev-lst)
                                 (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))
                       caller ctx channel state))))))))))))))))))))

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

(defun equal-insig (insig1 insig2)

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

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

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

(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))
  `(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 one of :do-not-install or :do-not-install!.  If an alist, then we may
; install a suitable acl2-defaults-table before executing the events in ev-lst,
; and the given acl2-defaults-table is installed as the acl2-defaults-table (if
; it is not already there) after executing those events.  But the latter of
; these is skipped if acl2-defaults-table is :do-not-install, and both are
; skipped if acl2-defaults-table is :do-not-install!.

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

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

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

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

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

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

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

; If caller is 'encapsulate-pass-2, then since the final world is in STATE, we
; use the value component of the non-erroneous return triple to return the
; world extended by the signatures (and the incremented depth).  That world,
; called proto-wrld3 in the encapsulate essay and below, is useful only for
; computing (via difference) the names introduced by the embedded events.  We
; still need the expansion-alist described in the preceding paragraph, 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 acl2-defaults-table :do-not-install!)
                        (value nil))
                       ((eq caller 'include-book)

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

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

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

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

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

; you'll see a much simpler result, with return-last calls removed, than if we
; did not apply remove-guard-holders-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 (getpropc (car names) 'constrainedp nil wrld))

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

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

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

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

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

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

(defun encapsulate-ctx (signatures form-lst)

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

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

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

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

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

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

  (cond ((null lst)

; Say nothing if there are no additional names.

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

(defun print-encapsulate-msg3/constraints (constrained-fns constraints
                                                           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 wrld primitives state-vars)

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

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

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

  (let ((val
         (case-match x

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

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

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

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

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

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

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

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

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

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

; We assume that form can be translated.

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

(mutual-recursion

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

; Warning: Keep this in sync with elide-locals-rec.

; This function checks that (elide-locals-rec ev1 t) agrees with
; (elide-locals-rec ev2 t), but without doing any consing.

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

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

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

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

  (cond
   (signatures
    (let ((name (case-match signatures
                  ((((name . &) arrow . &) . &)
                   (and (symbolp arrow)
                        (equal (symbol-name arrow) "=>")
                        name))
                  (((name . &) . &)
                   name))))
      (and name
           (symbolp name)
           (not (new-namep name wrld))
           (let* ((wrld-tail (lookup-world-index
                              'event
                              (getpropc name 'absolute-event-number 0 wrld)
                              wrld))
                  (event-tuple (cddr (car wrld-tail)))
                  (old-event-form (access-event-tuple-form
                                   event-tuple))
                  (equal? (corresponding-encaps old-event-form
                                                event-form)))
             (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* ((name0 (find-first-non-local-name-lst ev-lst
                                                   wrld
                                                   (primitive-event-macros)
                                                   (default-state-vars nil)
                                                   nil))
             (name (and (not (eq name0 :make-event)) name0)))
        (and name0
             (or (not name)

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

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

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

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

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

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

; Return true if every package-entry in a1 is present in a2, and 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))
        ((getpropc (car names) 'absolute-event-number nil wrld)

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

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

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

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

(defun update-proof-supporters-alist-1 (namex names local-alist
                                              proof-supporters-alist
                                              wrld)
  (assert$
   names ; sanity check; else we wouldn't have updated at install-event
   (let ((non-local-names
          (update-proof-supporters-alist-2 names local-alist wrld)))
     (cond ((getpropc (if (symbolp namex) namex (car namex))
                      'absolute-event-number nil wrld)
; See comment for similar getprop call in  update-proof-supporters-alist-2.
            (mv local-alist
                (if non-local-names
                    (acons namex non-local-names proof-supporters-alist)
                  proof-supporters-alist)))
           (t (mv (acons namex non-local-names local-alist)
                  proof-supporters-alist))))))

(defun update-proof-supporters-alist (new-proof-supporters-alist
                                      proof-supporters-alist
                                      wrld)

; Both alists are indexed by namex values that occur in reverse order of
; introduction; for example, the caar (if non-empty) is the most recent namex.

  (cond ((endp new-proof-supporters-alist)
         (mv nil proof-supporters-alist))
        (t (mv-let
            (local-alist proof-supporters-alist)
            (update-proof-supporters-alist (cdr new-proof-supporters-alist)
                                           proof-supporters-alist
                                           wrld)
            (update-proof-supporters-alist-1
             (caar new-proof-supporters-alist)
             (cdar new-proof-supporters-alist)
             local-alist
             proof-supporters-alist
             wrld)))))

(defun install-proof-supporters-alist (new-proof-supporters-alist
                                       installed-wrld
                                       wrld)
  (let ((saved-proof-supporters-alist
         (global-val 'proof-supporters-alist installed-wrld)))
    (mv-let (local-alist proof-supporters-alist)
            (update-proof-supporters-alist
             new-proof-supporters-alist
             saved-proof-supporters-alist
             installed-wrld)
            (declare (ignore local-alist))
            (global-set 'proof-supporters-alist proof-supporters-alist wrld))))

(defun empty-encapsulate (ctx state)
  (pprogn (observation ctx
                       "The submitted encapsulate event has created no new ~
                        ACL2 events, and thus is leaving the ACL2 logical ~
                        world unchanged.  See :DOC encapsulate.")
          (value :empty-encapsulate)))

(defun 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))
                          (post-pass-1-cert-replay
                           (global-val 'cert-replay 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))
                              (new-event-form
                               (and expansion-alist
                                    (list* 'encapsulate signatures
                                           new-ev-lst))))
                         (er-let* ((temp

; The following encapsulate-pass-2 is protected by the revert-world-on
; error above.
                                    (encapsulate-pass-2
                                     insigs
                                     kwd-value-list-lst
                                     new-ev-lst
                                     saved-acl2-defaults-table nil ctx state)))
                           (pprogn
                            (f-put-global 'last-make-event-expansion
                                          new-event-form
                                          state)
                            (cond
                             ((eq (car temp) :empty-encapsulate)
                              (empty-encapsulate ctx state))
                             (t
                              (let ((wrld3 (w state))
                                    (constrained-fns (nth 0 temp))
                                    (constraints-introduced (nth 1 temp))
                                    (exports (nth 2 temp))
                                    (subversive-fns (nth 3 temp))
                                    (infectious-fns (nth 4 temp)))
                                (pprogn
                                 (print-encapsulate-msg3
                                  ctx insigs new-ev-lst exports
                                  constrained-fns constraints-introduced
                                  subversive-fns infectious-fns wrld3 state)
                                 (er-let*
                                     ((wrld3a (intro-udf-guards insigs
                                                                kwd-value-list-lst 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
                                    (or (strip-cars insigs) 0)
                                    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)))
                                           (wrld10
                                            (if (and post-pass-1-cert-replay
                                                     (not (global-val
                                                           'cert-replay
                                                           wrld3)))

; The 'cert-replay world global supports the possible avoidance of rolling back
; the world after the first pass of certify-book, before doing the local
; incompatibility check using include-book.  At one time we think we only
; intended to set cert-replay when locally including books, and we didn't set
; it here.  That led to a bug in handling hidden defpkg events: see the Essay
; on Hidden Packages for relevant background, and see community books directory
; misc/hidden-defpkg-checks/ for an example of a soundness bug in Version_7.1,
; which is fixed by the global-set of 'cert-replay just below.

; Perhaps we could take care of this in encapsulate-fix-known-package-alist,
; which is called above; but the present approach, relying on the values of
; 'cert-replay at various stages, seems most direct.

                                                (global-set 'cert-replay t
                                                            wrld9)
                                              wrld9)))
                                      wrld10)
                                    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-alist0
                       (encapsulate-pass-2
                        insigs kwd-value-list-lst ev-lst saved-acl2-defaults-table
                        t ctx state)))
                   (let* ((empty-encapsulate-p
                           (eq (car expansion-alist0) :empty-encapsulate))
                          (expansion-alist
                           (if empty-encapsulate-p
                               (cdr expansion-alist0)
                             expansion-alist0))
                          (wrld3 (w state))
                          (new-event-form
                           (and expansion-alist
                                (list* 'encapsulate signatures
                                       (subst-by-position expansion-alist
                                                          ev-lst
                                                          0)))))
                     (pprogn
                      (f-put-global 'last-make-event-expansion
                                    new-event-form
                                    state)
                      (cond
                       (empty-encapsulate-p
                        (empty-encapsulate ctx state))
                       (t
                        (er-let*
                            ((wrld3a (intro-udf-guards insigs kwd-value-list-lst
                                                       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
                                         (or (strip-cars insigs) 0)
                                         nil nil
                                         nil ; irrelevant, since we are skipping proofs
                                         ctx

; We have considered calling encapsulate-fix-known-package-alist on wrld3a, just
; as we do in the first case (when not doing this on behalf of include-book).
; But we do not see a need to do so, both because all include-books are local
; and hence skipped (hence the known-package-alist has not changed from before
; the encapsulate), and because we do not rely on tracking packages during
; include-book, :puff (where ld-skip-proofsp is include-book-with-locals), or
; initialization.

                                         wrld3a
                                         state))))))))))))))))))

(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
         'progn-fn1 ctx (proofs-co state) state))
       (declare (ignore ignore-kpa))
       (pprogn
        (if erp
            (update-for-redo-flat val ev-lst state)
          state)
        (cond ((eq erp 'non-event)
               (er soft ctx
                   "PROGN may only be used on legal event forms (see :DOC ~
                    embedded-event-form).  Consider using ER-PROGN instead."))
              (erp (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)))

; 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 *foo*
;    #+mswindows 'win
;    #-mswindows 'not-win)

; because then we could certify a book in one ACL2 that contains a theorem
; (equal *foo* 'win), and include this book in another world where that theorem
; fails, thus deriving a contradiction.  In fact, we make the operating-system
; part of the state (as a world global), and figure everything else out about
; book names using that information.

(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 cbd-fn (state)
  (or (f-get-global 'connected-book-directory state)
      (er hard 'cbd
          "The connected book directory has apparently not yet been set.  ~
           This could be a sign that the top-level ACL2 loop, generally ~
           entered using (LP), has not yet been entered.")))

(defmacro cbd nil
  `(cbd-fn state))

(defun get-portcullis-cmds (wrld cmds cbds names ctx state)

; When certify-book is called, we scan down wrld to collect all the user
; commands (more accurately: their make-event expansions) into cmds.  This
; answer is part of the portcullis of the certificate, once it has been cleaned
; up by fix-portcullis-cmds and new-defpkg-list.  We also collect into cbds the
; connected-book-directory values for cmds.

  (cond
   ((null wrld) (mv nil cmds cbds state))
   ((and (eq (caar wrld) 'command-landmark)
         (eq (cadar wrld) 'global-value))
    (let ((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 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)
                                    #+gcl
                                    (member (car dir)
                                            '(:ROOT ; for backward compatibility
                                              #+cltl2
                                              :ABSOLUTE)
                                            :test #'eq)
                                    #-gcl
                                    (eq (car dir) :ABSOLUTE)
				    )
                         (let* ((mswindows-drive
                                 (mswindows-drive (namestring truename) state))
                                (tmp (if mswindows-drive
                                         (concatenate 'string mswindows-drive "/")
                                       "/")))
                           (dolist (x dir)
                             (when (stringp x)
                               (setq tmp (concatenate 'string tmp x "/"))))
                           (when (stringp name)
                             (setq tmp (concatenate 'string tmp name)))
                           (when (stringp type)
                             (setq tmp (concatenate 'string tmp "." type)))
                           (let ((namestring-tmp (namestring (truename tmp)))
                                 (namestring-truename (namestring truename)))
                             (cond ((equal namestring-truename namestring-tmp)
                                    tmp)
                                   ((and mswindows-drive

; In Windows, it appears that the value returned by truename can start with
; (for example) "C:/" or "c:/" depending on whether "c" is capitalized in the
; input to truename.  (See the comment in mswindows-drive1.)  Since tmp is
; constructed from mswindows-drive and components of truename, we are really
; just doing a minor sanity check here, so we content ourselves with a
; case-insensitive string-equality check.  That seems reasonable for Windows,
; whose pathnames are generally (as far as we know) considered to be
; case-insensitive.

                                         (string-equal namestring-truename
                                                       namestring-tmp))
                                    tmp)
                                   (t (case *canonical-unix-pathname-action*
                                        (:warning
                                         (let ((state *the-live-state*))
                                           (warning$ 'canonical-unix-pathname
                                                     "Pathname"
                                                     "Unable to compute ~
                                                      canonical-unix-pathname ~
                                                      for ~x0.  (Debug info: ~
                                                      truename is ~x1 while ~
                                                      (truename tmp) is ~x2.)"
                                                     x
                                                     namestring-truename
                                                     namestring-tmp)))
                                        (:error
                                         (er hard 'canonical-unix-pathname
                                             "Unable to compute ~
                                              canonical-unix-pathname for ~
                                              ~x0.  (Debug info: truename is ~
                                              ~x1 while (truename tmp) is ~
                                              ~x2.)"
                                             x
                                             namestring-truename
                                             namestring-tmp)))
                                      (and (not dir-p) ; indeterminate if dir-p
                                           x)))))))))))

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

(defun canonical-dirname! (pathname ctx state)
  (declare (xargs :guard t))
  (or (canonical-pathname pathname t state)
      (let ((x (canonical-pathname pathname nil state)))
        (cond (x (er hard? ctx
                     "The file ~x0 is not known to be a directory."
                     x))
              (t (er hard? ctx
                     "The directory ~x0 does not exist."
                     pathname))))))

(defun directory-of-absolute-pathname (pathname)
  (let* ((lst (coerce pathname 'list))
         (rlst (reverse lst))
         (temp (member *directory-separator* rlst)))
    (coerce (reverse temp) 'string)))

(defun extend-pathname (dir0 file-name 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)))
         (dir (if (eq dir0 :system)
                  (f-get-global 'system-books-dir state)
                dir0))
         (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 (if (eq dir0 :system)
                                 abs-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)
  `(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))))

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

(defun string-prefixp-1 (str1 i str2)
  (declare (type string str1 str2)
           (type (unsigned-byte 29) i)
           (xargs :guard (and (<= i (length str1))
                              (<= i (length str2)))))
  (cond ((zpf i) t)
        (t (let ((i (1-f i)))
             (declare (type (unsigned-byte 29) i))
             (cond ((eql (the character (char str1 i))
                         (the character (char str2 i)))
                    (string-prefixp-1 str1 i str2))
                   (t nil))))))

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

; At one time this was a macro that checked `(eql 0 (search ,root ,string
; :start2 0)).  But it seems potentially inefficient to search for any match,
; only to insist at the end that the match is at 0.

  (declare (type string root string)
           (xargs :guard (<= (length root) (fixnum-bound))))
  (let ((len (length root)))
    (and (<= len (length string))
         (assert$ (<= len (fixnum-bound))
                  (string-prefixp-1 root len string)))))

(defun relativize-book-path (filename system-books-dir)

; System-books-dir is presumably the value of state global 'system-books-dir.
; If the given filename is an absolute pathname extending the absolute
; directory name system-books-dir, then return (:system . suffix), where suffix
; is a relative pathname that points to the same file with respect to
; system-books-dir.

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

(defun relativize-book-path-lst (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-lst (cdr lst) root)))))

(defun sysfile-p (x)
  (and (consp x)
       (eq (car x) :system)
       (stringp (cdr x))))

(defun sysfile-filename (x)
  (declare (xargs :guard (sysfile-p x)))
  (cdr x))

(defun filename-to-sysfile (filename state)
  (relativize-book-path filename (f-get-global 'system-books-dir state)))

(defun sysfile-to-filename (x state)
  (cond ((sysfile-p x)
         (extend-pathname :system
                          (sysfile-filename x)
                          state))
        (t x)))

(mutual-recursion

(defun make-include-books-absolute-1 (form cbd dir names localp ctx state)

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

; Form is a command from the current ACL2 world that is known to be an embedded
; event form with respect to names.  However, it is not necessarily an event
; that would actually be stored: in particular, add-include-book-dir (also
; ..-dir!) can take a relative pathname in the command, but will always be
; stored as an event using an absolute pathname; and make-event uses this
; function to convert some relative to absolute pathnames in the make-event
; expansion of form.

; This function can replace relative pathnames by absolute pathnames, according
; to each of the following scenarios.

; (a) We are converting commands in a certification world so that they are
;     suitable for storing in the portcullis commands section of a certificate
;     file.

; (b) We are creating a make-event expansion.

; In the case of (a), we want to make some pathnames absolute in include-book,
; add-include-book-dir!, and add-include-book-dir forms -- possibly using
; sysfile notation (see sysfile-p) -- so that such pathnames are appropriate
; even if the book and its certificate file are moved.  See the comment in
; fix-portcullis-cmds for discussion of case (a).  In the case of (b) we do
; this as well, just in case the make-event form is ultimately in the
; certification world.  It is tempting not to bother if we are processing the
; event from a book, during include-book or certify-book, since then we know
; it's not in the portcullis.  But rather than think about how making those
; special cases might affect redundancy, we always handle make-event.

; Starting after Version_3.6.1, we allow an include-book pathname for a
; portcullis command to remain a relative pathname if it is relative to the cbd
; of the book.  That change avoided a failure to certify community book
; books/fix-cert/test-fix-cert1.lisp (now defunct) that initially occurred when
; we started including portcullis commands in the check-sum (with the
; introduction of function check-sum-cert), caused by the renaming of an
; absolute pathname in an include-book portcullis command.  Note that since a
; make-event in a certification world is evaluated without knowing the ultimate
; cbd for certification, we always convert to an absolute pathname in case (b),
; the make-event case.

; Cbd is the connected-book-directory just after evaluating form, and hence
; (since form is an embedded event form) also just before evaluating form.  Dir
; is the directory of the book being certified (case (a)), but is nil for the
; make-event case (case (b)).

  (cond
   ((atom form) (mv nil form)) ; This should never happen.
   ((member-eq (car form) '(local skip-proofs))
    (cond
     ((and (eq (car form) 'local)
           (not localp))

; Local events will be skipped when including a book, and in particular when
; evaluating portcullis commands from a book's certificate, so we can ignore
; local events then.

      (mv nil form))
     (t (mv-let (changedp x)
          (make-include-books-absolute-1
           (cadr form) cbd dir names localp ctx state)
          (cond (changedp (mv t (list (car form) x)))
                (t (mv nil form)))))))
   ((eq (car form) 'progn)

; Since progn! has forms that need not be events, we don't try to deal with it.
; We consider this not to present any soundness problems, since progn!
; requires a ttag.

    (mv-let (changedp rest)
      (make-include-books-absolute-lst
       (cdr form) cbd dir names localp ctx state)
      (cond (changedp (mv t (cons (car form) rest)))
            (t (mv nil form)))))
   ((eq (car form) 'value)
    (mv nil form))
   ((eq (car form) 'include-book)

; Consider the case that we are processing the portcullis commands for a book,
; bk, that is in the process of being certified.  We want to ensure that form,
; an include-book form, refers to the same book as when originally processed as
; it does when later being processed as a portcullis command of bk.  When bk is
; later included, the connected-book-directory will be bound to dir, which is
; the directory of the book being certified.  Therefore, if the
; connected-book-directory at the time form was processed, namely cbd, is the
; same as dir, then we do not need bk to be an absolute pathname: the same
; connected-book-directory as when originally processed (namely, cbd) will be
; used as the connected-book-directory when the book is being included as a
; portcullis command of bk (namely, connected-book-directory dir).
; Well... actually, if bk is a system book, and if the system books are moved,
; then cbd and dir will change but their equality (and inequality) will be
; preserved.

; If cbd is nil then we are recovering portcullis commands from an existing
; certificate, so relative pathnames have already been converted to absolute
; pathnames when necessary, and no conversion is needed here.

; If cbd is non-nil and dir is nil, then we are converting pathnames for some
; purposes other than the portcullis of a book being certified, so there is no
; need to convert to an absolute pathname.

; If we have an absolute pathname, either by conversion or because the
; include-book originally referenced an absoluate pathname under the system
; books directory, then we convert to using :dir :system.

; To summarize much of the above: if cbd is nil or if cbd and dir are equal, we
; can skip any pathname conversion and fall through to the next top-level COND
; branch, where form is returned unchanged -- except in both cases, an absolute
; pathname under the system books directory is replaced using :dir :system.

    (assert$
     (keyword-value-listp (cddr form)) ; as form is a legal event
     (cond
      ((assoc-keyword :dir form)

; We do not need to convert a relative pathname to an absolute pathname if the
; :dir argument already specifies how to do this.  Recall that the table guard
; of the acl2-defaults-table specifies that :dir arguments are absolute
; pathnames.

       (mv nil form))
      ((not (equal cbd dir)) ; always true in case (b)
       (assert$
        (stringp cbd)
        (mv-let (full-book-name directory-name familiar-name)
          (parse-book-name cbd (cadr form) nil ctx state)
          (declare (ignore directory-name familiar-name))
          (let ((x (filename-to-sysfile full-book-name state)))
            (cond ((consp x) ; (sysfile-p x)
                   (mv t
                       (list* 'include-book
                              (sysfile-filename x)
                              :dir :system
                              (cddr form))))
                  ((and dir

; Note that if dir is nil, then we are doing this on behalf of make-event so
; that the expansion-alist of a .cert file is relocatable.  In that case, there
; is no need to make the book name absolute, since the usual reason -- a change
; of cbd -- doesn't apply in the middle of a book certification.  Note that if
; the make-event occurs in a certification world, then fix-portcullis-cmds will
; fix, as appropriate, any expansion that is an include-book.

                        (not (equal x (cadr form))))
                   (mv t
                       (list* 'include-book
                              x
                              (cddr form))))
                  (t (mv nil form)))))))
      (t (assert$
          (stringp (cadr form))
          (let ((sysfile (filename-to-sysfile (cadr form) state)))
            (cond ((consp sysfile) ; (sysfile-p sysfile)
                   (mv t
                       (list* 'include-book
                              (sysfile-filename sysfile)
                              :dir :system
                              (cddr form))))
                  (t (mv nil form)))))))))
   ((member-eq (car form)
               '(add-include-book-dir add-include-book-dir!))

; This case is very similar to the include-book case handled in the preceding
; COND branch, above.  See that case for explanatory comments.  In order to see
; an unfortunate include-book failure WITHOUT this case, try the following.  We
; assume two directories, D and D/SUB/, and trivial books D/foo.lisp and
; D/SUB/bar.lisp.

; In directory D, start up ACL2 and then:

; (add-include-book-dir :main "./")
; (certify-book "foo" 1)
; (u)
; :q
; (save-exec "my-acl2" "testing")

; Then in directory D/SUB/, start up ../my-acl2 and then:

; (include-book "foo" :dir :main)
; (certify-book "bar" 2)

; Finally, in directory D/SUB/, start up ../my-acl2 and then:

; (include-book "bar")

; You'll see this error:

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

    (cond
     ((sysfile-p (caddr form)) ; already "absolute"
      (mv nil form))
     ((not (equal cbd dir)) ; always true in case (b)
      (assert$
       (stringp cbd)
       (mv t
           (list (car form)
                 (cadr form)
                 (filename-to-sysfile (extend-pathname cbd (caddr form) state)
                                      state)))))
     (t (let ((sysfile (if (consp (caddr form)) ; presumably sysfile-p holds
                           (caddr form)
                         (filename-to-sysfile (caddr form) state))))
          (cond ((consp sysfile) ; (sysfile-p sysfile)
                 (mv t (list (car form)
                             (cadr form)
                             sysfile)))
                (t (mv nil form)))))))
   ((member-eq (car form) names)

; Note that we do not have a special case for encapsulate.  Every include-book
; inside an encapsulate is local (see chk-embedded-event-form), hence would not
; be changed by this function anyhow.  If we allow non-local include-books in
; an encapsulate, then we will need to add a case for encapsulate that is
; similar to the case for progn.

    (mv nil form))
   ((eq (car form) 'make-event) ; already fixed
    (mv nil form))
   ((and (member-eq (car form) '(with-output
                                  with-prover-step-limit
                                  with-prover-time-limit))
         (consp (cdr form)))
    (mv-let (changedp x)
      (make-include-books-absolute-1
       (car (last form))
       cbd dir names localp ctx state)
      (cond (changedp (mv t (append (butlast form 1) (list x))))
            (t (mv nil form)))))
   ((getpropc (car form) 'macro-body)
    (mv-let (erp x)
      (macroexpand1-cmp form ctx (w state)
                        (default-state-vars t))
      (cond (erp (mv (er hard erp "~@0" x) nil))
            (t (make-include-books-absolute-1 x cbd dir names localp ctx
                                              state)))))
   (t (mv nil
          (er hard ctx
              "Implementation error in make-include-books-absolute-1:  ~
               unrecognized event type, ~x0.  Make-include-books-absolute ~
               needs to be kept in sync with chk-embedded-event-form.  Please ~
               send this error message to the implementors."
              (car form))))))

(defun make-include-books-absolute-lst (forms cbd dir names localp ctx state)

; For each form F in forms, if F is not changed by
; make-include-books-absolute-1 then it is returned unchanged in the result.

  (if (endp forms)
      (mv nil nil)
    (mv-let (changedp-1 first)
      (make-include-books-absolute-1
       (car forms) cbd dir names localp ctx state)
      (mv-let (changedp-2 rest)
        (make-include-books-absolute-lst
         (cdr forms) cbd dir names localp ctx state)
        (cond (changedp-1 (mv t (cons first rest)))
              (changedp-2 (mv t (cons (car forms) rest)))
              (t (mv nil forms)))))))
)

(defun make-include-books-absolute (form cbd dir names localp ctx state)
  (mv-let (changedp new-form)
    (make-include-books-absolute-1 form cbd dir names localp ctx state)
    (if changedp
        new-form
      form)))

(defun first-known-package-alist (wrld-segment)
  (cond
   ((null wrld-segment)
    nil)
   ((and (eq (caar wrld-segment) 'known-package-alist)
         (eq (cadar wrld-segment) 'global-value))
    (let* ((kpa  (cddar wrld-segment)))
      (if (eq kpa *acl2-property-unbound*)

; We do not expect to find *acl2-property-unbound* here.  If we do find it,
; then we cause an error.

          (er hard 'first-known-package-alist
              "Implementation error!  Unexpected find of unbound ~
               known-package-alist value!  Please contact the ACL2 ~
               implementors and send this message.")
        kpa)))
   (t
    (first-known-package-alist (cdr wrld-segment)))))

(defun defpkg-items-rec (new-kpa old-kpa system-books-dir 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 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)))
            (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
                ctx w state
                (cons (list name
                            imports
                            (assert$
                             event
                             (assert$
                              (equal n name)
                              (cond ((and (not erp)
                                          (or (equal (cdr pair) ; optimization
                                                     imports)
                                              (equal (sort-symbol-listp
                                                      (cdr pair))
                                                     imports))
                                          (equal tterm (car pair)))
                                     body)
                                    ((termp tterm w)
                                     tterm)
                                    (t
                                     (kwote imports)))))
                            doc
                            book-path)
                      acc))))))))))

(defun new-defpkg-p (new-kpa old-kpa)
  (cond ((endp new-kpa) nil)
        (t (or (not (find-package-entry (package-entry-name (car new-kpa))
                                        old-kpa))
               (new-defpkg-p (cdr new-kpa) old-kpa)))))

(defun defpkg-items (new-kpa old-kpa ctx w state)

; This is just a wrapper for defpkg-items-rec, with error output turned off
; (because of calls of translate).  See the comment for defpkg-items-rec.

  (cond
   ((new-defpkg-p new-kpa old-kpa)
    (state-global-let*
     ((inhibit-output-lst (cons 'error
                                (f-get-global 'inhibit-output-lst state))))
     (mv-let
       (erp val state)
       (defpkg-items-rec new-kpa old-kpa
         (f-get-global 'system-books-dir state)
         ctx w state nil)
       (assert$
        (null erp)
        (value val)))))
   (t (value nil))))

(defun new-defpkg-list2 (imports all-defpkg-items acc seen)

; Extends acc with items (cons pkg-name rest) from all-defpkg-items not already
; in acc or seen for which pkg-name is the symbol-package-name of a symbol in
; imports.

  (cond
   ((endp imports)
    acc)
   (t
    (let ((p (symbol-package-name (car imports))))
      (cond
       ((or (assoc-equal p acc)
            (assoc-equal p seen))
        (new-defpkg-list2 (cdr imports) all-defpkg-items acc seen))
       (t (let ((item (assoc-equal p all-defpkg-items)))
            (cond (item (new-defpkg-list2
                         (cdr imports)
                         all-defpkg-items
                         (cons item acc)
                         seen))
                  (t (new-defpkg-list2
                      (cdr imports) all-defpkg-items acc seen))))))))))

(defun make-hidden-defpkg (name imports/doc/book-path)

; Warning: Keep this in sync with equal-modulo-hidden-defpkgs.

  (let ((imports (car imports/doc/book-path))
        (doc (cadr imports/doc/book-path))
        (book-path (caddr imports/doc/book-path)))
    `(defpkg ,name ,imports ,doc ,book-path t)))

(defun new-defpkg-list1
  (defpkg-items all-defpkg-items base-kpa earlier-kpa added-defpkgs)

; See the comment in new-defpkg-list.  Here, we maintain an accumulator,
; added-defpkgs, that contains the defpkg events that need to be added based on
; what we have already processed in defpkg-items, in reverse order.

  (cond
   ((endp defpkg-items)
    added-defpkgs)
   (t
    (let* ((added-defpkgs
            (new-defpkg-list1 (cdr defpkg-items) all-defpkg-items base-kpa
                              earlier-kpa added-defpkgs))
           (item (car defpkg-items))
           (name (car item)))
      (cond
       ((find-package-entry name base-kpa)
        added-defpkgs)
       (t ; we want to add event, so may need to add some already "discarded"
        (cons (make-hidden-defpkg name (cddr item))
              (new-defpkg-list1
               (new-defpkg-list2 (cadr item) ; imports
                                 all-defpkg-items nil added-defpkgs)
               all-defpkg-items

; We are considering all defpkg events added in support of import lists.  We
; need to take the appropriate closure in order to get all supporting defpkg
; events that are not represented in earlier-kpa, so this call uses earlier-kpa
; in place of base-kpa.

               earlier-kpa
               earlier-kpa added-defpkgs))))))))

(defun new-defpkg-list (defpkg-items base-kpa earlier-kpa)

; For background on the discussion below, see the Essay on Hidden Packages.

; Defpkg-items is a list of "defpkg items" each of the form (list name imports
; body doc book-path) representing a list of package definitions.  We return a
; list of defpkg events, corresponding to some of these defpkg items, that can
; be executed in a world whose known-package-alist is earlier-kpa.  The primary
; reason a defpkg is in the returned list is that its package is not in
; base-kpa (not even hidden).  The second reason is that we need to define a
; package P1 not already in earlier-kpa if we add another package P2 whose
; import list contains a symbol in package P1; we close under this process.

; This function is called at the end of the include-book phase of certify-book.
; In that case, base-kpa is the known-package-alist at that point, earlier-kpa
; is the known-package-alist of the certification world, and defpkg-items
; contains an item for each name of a package in the known-package-alist at the
; end of the earlier, admissibility pass of certify-book that was not defined
; in the certification world.  To illustrate the "second reason" above, let us
; suppose that the book being certified contains forms (include-book "book1")
; and (local (include-book "book2")), where book1 defines (defpkg "PKG1" ...)
; and book2 defines (defpkg "PKG2" '(PKG1::SYM)).  Then we want to add the
; definition of "PKG2" to the portcullis, but in order to do so, we need to add
; the definition of "PKG1" as well, even though it will eventually be included
; by way of book1.  And, we need to be sure to add the defpkg of "PKG1" before
; that of "PKG2".

; This function is also called on behalf of puff-fn1, where defpkg-items
; corresponds to the packages in known-package-alist in the world at completion
; of the command about to be puffed, and base-kpa and earlier-kpa correspond to
; the known-package-alist just before that command.  In that case there is no
; need for the "second reason" above, but for simplicity we call this same
; function.

  (cond
   ((null defpkg-items) ; optimization
    nil)
   (t (reverse (remove-duplicates-equal
                (new-defpkg-list1 defpkg-items defpkg-items base-kpa
                                  earlier-kpa nil))))))

(mutual-recursion

; We check that a given term or list of terms is acceptable even if (cdr
; (assoc-eq ':ignore-ok (table-alist 'acl2-defaults-table w))) is nil.

(defun term-ignore-okp (x)
  (cond ((or (atom x)
             (fquotep x))
         t)
        ((symbolp (ffn-symb x))
         (term-list-ignore-okp (fargs x)))
        (t ; lambda
         (and (null (set-difference-eq (lambda-formals (ffn-symb x))
                                       (all-vars (lambda-body (ffn-symb x)))))
              (term-list-ignore-okp (fargs x))))))

(defun term-list-ignore-okp (x)
  (cond ((endp x) t)
        ((term-ignore-okp (car x))
         (term-list-ignore-okp (cdr x)))
        (t nil)))

)

(defun hidden-defpkg-events1 (kpa system-books-dir 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 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)))
      (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 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)
                          w ctx state nil)))

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

(defun fix-portcullis-cmds (dir cmds cbds names wrld ctx state)

; This function is called during certification of a book whose directory's
; absolute pathname is dir.  It modifies cmds by making relative pathnames
; absolute when necessary, and also by adding defpkg events for hidden packages
; from the certification world, as explained in the Essay on Hidden Packages.
; We explain these two aspects in turn.

; Certify-book needs to insist that each pathname for an include-book in the
; portcullis refer to the intended file, in particular so that the actual file
; read is not dependent upon cbd.  Consider for example:

; :set-cbd "/usr/home/moore/"
; (include-book "prelude")
; :set-cbd "/usr/local/src/library/"
; (certify-book "user")

; A naive implementation would provide a portcullis for "user" that contains
; (include-book "prelude").  But there is no clue as to the directory on which
; "prelude" resides.  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 with
; inappropriate relative pathnames, that nevertheless is equivalent to the
; original cmds from the standpoint of subsequent embedded events.  (Or, we
; return an error, but in fact we believe that that will not happen.)

; As mentioned at the outset above, this function also adds defpkg events.  We
; trust that the portcullis is a legal sequence of commands (actually, events),
; so the only point is to 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.

  (let ((new-cmds (fix-portcullis-cmds1 dir cmds cbds nil names ctx state)))
    (er-let* ((new-defpkgs (hidden-defpkg-events
                            (global-val 'known-package-alist wrld)
                            wrld ctx state)))
      (value (revappend new-cmds new-defpkgs)))))

(defun collect-uncertified-books (alist)

; Alist is an include-book-alist and thus contains elements of the
; form described in include-book-alist-subsetp.  A typical element is
; (full-book-name user-book-name familiar-name cert-annotations
; . 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)

; Warning: Include-book-er assumes that this function returns (value nil) if
; there is no error.

  (cond
   ((null warning-summary)
    (er soft ctx "~@2" file1 file2 msg))
   ((symbolp warning-summary) ; keyword
    (cond
     ((member-eq (cert-op state)
                 '(nil :write-acl2xu)) ; not certification's fault
      (er soft ctx
          "~@0  This is illegal because we are currently attempting ~
           include-book with ~x1 set to NIL.  You can avoid this error by ~
           using a value of T for ~x1; see :DOC include-book."
          (msg "~@2" file1 file2 msg)
          warning-summary))
     (t ; certification's fault
      (er soft ctx
          "~@0  This is illegal because we are currently attempting ~
           certify-book; see :DOC certify-book."
          (msg "~@2" file1 file2 msg)))))
   (t (pprogn (warning$ ctx warning-summary "~@2" file1 file2 msg)
              (value nil)))))

(defun include-book-er (file1 file2 msg keyword suspect-book-action-alist ctx
                              state)

; Warning: The computation of cert-obj in include-book-fn1 assumes that this
; function returns (value nil) when not returning an error.

; Depending on various conditions we either do nothing and return (value nil),
; print a warning, or cause an error.  File1 and file2 are the full book name
; and its .cert file, respectively.  (Well, sometimes file2 is nil -- we never
; use it ourselves but msg might and supplies it when needed.)  Msg is an
; arbitrary ~@ fmt message, which is used as the error message and used in the
; warning message.  Suspect-book-action-alist is the alist manufactured by
; include-book, specifying the values of its keyword arguments.  Among these
; are arguments that control our behavior on these errors.  Keyword specifies
; the kind of error this is, using the convention that it is either t, meaning
; cause an error, or the keyword used by include-book to specify the behavior.
; For example, if this error reports the lack of a certificate, then keyword is
; :uncertified-okp.

  (let ((warning-summary
         (include-book-er-warning-summary keyword suspect-book-action-alist
                                          state)))

; If warning-summary is nil, we cause an error.  Otherwise, it is summary
; of the desired warning.

    (include-book-er1 file1 file2 msg warning-summary ctx state)))

(defun post-alist-from-channel (x y ch state)

; 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 that depend on it (and, if you are using ~
                             an image created by save-exec, then consider ~
                             rebuilding that image)"
                            (concatenate 'string familiar-name ".cert")
                            familiar-name))
                      (cert-maybe-unchanged-p
                       " so book recertification is probably required")
                      (t
                       (msg "~|AND NOTE that file ~x0 changed after ~x1 was ~
                             included, so you should probably undo back ~
                             through the command that included ~x1 (or, if ~
                             you are using an image created by save-exec, ~
                             consider rebuilding that image)"
                            (concatenate 'string familiar-name ".cert")
                            familiar-name))))
              state)))

(defun tilde-*-book-check-sums-phrase1 (reqd-alist actual-alist state)

; The two alists are include-book-alists.  Thus, each element of each is of the
; form (full-book-name directory-name familiar-name cert-annotations
; . ev-lst-chk-sum).  For each entry (cert-annotations . ev-lst-chk-sum) in
; reqd-alist we either find a corresponding entry for the same full-book-name
; in actual-alist (note that we ignore the directory-name and familiar-name,
; which may differ between the two but are irrelevant) or else we return a
; message.

  (cond
   ((null reqd-alist) (mv nil state))
   (t (let* ((reqd-entry (cdddr (car reqd-alist)))
             (familiar-name (caddr (car reqd-alist)))
             (full-book-name (car (car reqd-alist)))
             (actual-element (assoc-equal full-book-name actual-alist))
             (actual-entry (cdddr actual-element)))
        (assert$

; We know there is an entry for full-book-name because otherwise we would have
; caused an error when trying to include the book (or process its portcullis
; commands).  The question is only whether we found a cert file for it, etc.

         actual-element          
         (cond
          ((equal reqd-entry actual-entry)
           (tilde-*-book-check-sums-phrase1 (cdr reqd-alist)
                                            actual-alist
                                            state))
          (t
           (mv-let
             (msgs state)
             (tilde-*-book-check-sums-phrase1 (cdr reqd-alist)
                                              actual-alist
                                              state)
             (mv-let
               (phrase state)
               (tilde-@-cert-post-alist-phrase full-book-name
                                               familiar-name
                                               reqd-entry
                                               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
                         (car reqd-entry)  ;;; cert-annotations
                         (cdr reqd-entry)  ;;; ev-lst-chk-sum
                         (cond
                          ((null (cdr actual-entry))
                           (msg "an uncertified version of ~x0 with ~
                                 certificate annotations~|  ~x1,"
                                familiar-name
                                (car actual-entry) ; cert-annotations
                                ))
                          (t (msg "a version of ~x0 with certificate ~
                                   annotations~|  ~x1~|and check sum ~x2,"
                                  familiar-name
                                  (car actual-entry) ; cert-annotations
                                  (cdr 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 an `include-book
; alist subset' of actual-alist but it is not.

  (mv-let (phrase1 state)
          (tilde-*-book-check-sums-phrase1 reqd-alist
                                           actual-alist
                                           state)
          (mv (list "" "~%~@*" "~%~@*;~|" "~%~@*;~|"
                    phrase1)
              state)))

(defun get-cmds-from-portcullis1 (eval-hidden-defpkgs ch ctx state ans)

; Keep this in sync with equal-modulo-hidden-defpkgs, make-hidden-defpkg, and
; the #-acl2-loop-only and #+acl2-loop-only definitions of defpkg.

; Also keep this in sync with chk-raise-portcullis2.

; We read successive forms from ch, stopping when we get to
; :END-PORTCULLIS-CMDS and returning the list of forms read, which we
; accumulate onto ans as we go.  Ans should be nil initially.

  (mv-let (eofp form state)
          (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.

  (concatenate 'string
               (remove-lisp-suffix x nil)
               "port"))

(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 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 sysfile-or-string-listp (x)
  (declare (xargs :guard (true-listp x)))
  (cond ((endp x) t)
        ((or (stringp (car x))
             (sysfile-p (car x)))
         (sysfile-or-string-listp (cdr x)))
        (t nil)))

(defun ttag-alistp (x sysfile-okp)

; 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))
                (if sysfile-okp
                    (sysfile-or-string-listp (remove1 nil (cdar x)))
                  (string-listp (remove1 nil (cdar x))))
                (ttag-alistp (cdr x) sysfile-okp)))))

(defun cert-annotationsp (x sysfile-okp)
  (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 sysfile-okp))
                (& nil)))))
    (& nil)))

(defrec cert-obj

; This record represents information stored in a certificate file.  The
; "-sysfile" variants are used for checksums, employing sysfiles (see
; sysfile-p) in place of absolute pathnames referencing system books, to
; support the relocation of system books directories that include .cert files,
; while the "-abs" variants instead contain the original absolute pathnames,
; and are used for purposes other than checksums.

  ((cmds pre-alist-sysfile . pre-alist-abs)
   (post-alist-sysfile . post-alist-abs)
   expansion-alist
   . 

; The :pcert-info field is used for provisional certification.  Its value is
; either an expansion-alist that has not had locals elided (as per elide-locals
; and related functions), or one of tokens :proved or :unproved.  Note that an
; expansion-alist, even a nil value, implicitly indicates that proofs have been
; skipped when producing the corresponding certificate file (a .pcert0 file);
; the explicit value :unproved is stored when constructing a cert-obj from a
; .pcert1 file.

   pcert-info)
  t)

(defun check-sum-cert-obj (cmds pre-alist-sysfile post-alist-sysfile
                                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-sysfile)
                       (cons post-alist-sysfile expansion-alist))))

(defun include-book-alist-entry-p (entry sysfile-okp)
  (and (consp entry)
       (or (stringp (car entry)) ; full-book-name
           (and sysfile-okp
                (sysfile-p (car entry))))
       (consp (cdr entry))
       (stringp (cadr entry)) ; user-book-name
       (consp (cddr entry))
       (stringp (caddr entry)) ; familiar-name
       (consp (cdddr entry))
       (cert-annotationsp (cadddr entry) sysfile-okp) ; cert-annotations
       (or (integerp (cddddr entry))      ; ev-lst-chk-sum
           (eq (cddddr entry) nil))))

(defun sysfile-to-filename-ttag-alist-val (lst state)
  (declare (xargs :guard (true-listp lst)))
  (cond ((endp lst) nil)
        ((null (car lst))
         (cons nil (sysfile-to-filename-ttag-alist-val (cdr lst) state)))
        (t (cons (sysfile-to-filename (car lst) state)
                 (sysfile-to-filename-ttag-alist-val (cdr lst) state)))))

(defun sysfile-to-filename-ttag-alistp (ttag-alist state)
  (declare (xargs :guard (ttag-alistp ttag-alist t)))
  (cond ((endp ttag-alist) nil)
        (t (acons (caar ttag-alist)
                  (sysfile-to-filename-ttag-alist-val (cdar ttag-alist) state)
                  (sysfile-to-filename-ttag-alistp (cdr ttag-alist) state)))))

(defun sysfile-to-filename-cert-annotations (ca state)
  (declare (xargs :guard (cert-annotationsp ca t)))
  (case-match ca
    (((':SKIPPED-PROOFSP . sp)
      (':AXIOMSP . ap)
      . ttags-singleton)
     `((:SKIPPED-PROOFSP . ,sp)
       (:AXIOMSP . ,ap)
       ,@(and ttags-singleton
              (case-match ttags-singleton
                (((':TTAGS . ttags))
                 `((:TTAGS . ,(sysfile-to-filename-ttag-alistp ttags state))))
                (& (er hard 'sysfile-to-filename-cert-annotations
                       "Implementation error: unexpected shape, ~x0."
                       ca))))))
    (& (er hard 'sysfile-to-filename-cert-annotations
           "Implementation error: unexpected shape, ~x0."
           ca))))

(defun sysfile-to-filename-include-book-entry (entry state)
  (declare (xargs :guard (include-book-alist-entry-p entry t)))
  (list* (sysfile-to-filename (car entry) state)
         (cadr entry)
         (caddr entry)
         (sysfile-to-filename-cert-annotations (cadddr entry) state)
         (cddddr entry)))

(defun sysfile-to-filename-include-book-alist1 (x local-markers-allowedp state
                                                  acc)

; See sysfile-to-filename-include-book-alist.

; It was tempting to use the "changedp" trick to avoid consing up a new copy of
; x if it hasn't changed.  But it seems likely that x will change for any
; non-trivial book (which we expect would likely include at least one community
; book), and this tail-recursive code is simpler and, who knows, maybe more
; efficient.

  (cond
   ((atom x)
    (if (null x) (reverse acc) :error))
   (t (let* ((fst (car x))
             (new-fst
              (case-match fst
                (('local entry)
                 (cond ((and local-markers-allowedp
                             (include-book-alist-entry-p entry t))
                        (list 'local (sysfile-to-filename-include-book-entry
                                      entry state)))
                       (t :error)))
                (& (cond ((include-book-alist-entry-p fst t)
                          (sysfile-to-filename-include-book-entry fst state))
                         (t :error))))))
        (cond ((eq new-fst :error) :error)
              (t (sysfile-to-filename-include-book-alist1
                  (cdr x)
                  local-markers-allowedp
                  state
                  (cons new-fst acc))))))))

(defun sysfile-to-filename-include-book-alist (x local-markers-allowedp state)

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

; If the check succeeds, then we return the result of replacing each
; full-book-name in x that is a sysfile-p with its corresponding absolute
; filename.  Otherwise we return :error.

  (sysfile-to-filename-include-book-alist1 x local-markers-allowedp state nil))

(defun filename-to-sysfile-ttag-alist-val (lst state)
  (declare (xargs :guard (and (true-listp lst)
                              (string-listp (remove1 nil lst)))))
  (cond ((endp lst) nil)
        ((null (car lst))
         (cons nil (filename-to-sysfile-ttag-alist-val (cdr lst) state)))
        (t (cons (filename-to-sysfile (car lst) state)
                 (filename-to-sysfile-ttag-alist-val (cdr lst) state)))))

(defun filename-to-sysfile-ttag-alistp (ttag-alist state)
  (declare (xargs :guard (ttag-alistp ttag-alist nil)))
  (cond ((endp ttag-alist) nil)
        (t (acons (caar ttag-alist)
                  (filename-to-sysfile-ttag-alist-val (cdar ttag-alist) state)
                  (filename-to-sysfile-ttag-alistp (cdr ttag-alist) state)))))

(defun filename-to-sysfile-cert-annotations (ca state)
  (declare (xargs :guard (cert-annotationsp ca nil)))
  (case-match ca
    (((':SKIPPED-PROOFSP . sp)
      (':AXIOMSP . ap)
      . ttags-singleton)
     `((:SKIPPED-PROOFSP . ,sp)
       (:AXIOMSP . ,ap)
       ,@(and ttags-singleton
              (case-match ttags-singleton
                (((':TTAGS . ttags))
                 `((:TTAGS . ,(filename-to-sysfile-ttag-alistp ttags state))))
                (& (er hard 'filename-to-sysfile-cert-annotations
                       "Implementation error: unexpected shape, ~x0."
                       ca))))))
    (& (er hard 'filename-to-sysfile-cert-annotations
           "Implementation error: unexpected shape, ~x0."
           ca))))

(defun filename-to-sysfile-include-book-entry (entry state)
  (declare (xargs :guard (include-book-alist-entry-p entry nil)))
  (list* (filename-to-sysfile (car entry) state)
         (cadr entry)
         (caddr entry)
         (filename-to-sysfile-cert-annotations (cadddr entry) state)
         (cddddr entry)))

(defun filename-to-sysfile-include-book-alist1 (x local-markers-allowedp state
                                                  acc)

; See filename-to-sysfile-include-book-alist.

  (cond
   ((atom x)
    (if (null x) (reverse acc) :error))
   (t (let* ((fst (car x))
             (new-fst
              (case-match fst
                (('local entry)
                 (cond ((and local-markers-allowedp
                             (include-book-alist-entry-p entry nil))
                        (list 'local (filename-to-sysfile-include-book-entry
                                      entry state)))
                       (t :error)))
                (& (cond ((include-book-alist-entry-p fst nil)
                          (filename-to-sysfile-include-book-entry fst state))
                         (t :error))))))
        (cond ((eq new-fst :error) :error)
              (t (filename-to-sysfile-include-book-alist1
                  (cdr x)
                  local-markers-allowedp
                  state
                  (cons new-fst acc))))))))

(defun filename-to-sysfile-include-book-alist (x local-markers-allowedp state)

; See sysfile-to-filename-include-book-alist.  This simply works in the
; opposite direction.

  (filename-to-sysfile-include-book-alist1 x local-markers-allowedp state nil))

(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.  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.  The cert-obj record
; contains not only the "-sysfile" versions of the pre- and post-alist, which
; are stored in the certificate file, but their conversions to "-abs" versions,
; in which the sysfiles have been converted to absolute pathnames.

  (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))
      (er-let*
          ((pre-alist0
            (mv-let (eofp pre-alist0 state)
                    (read-object ch state)
                    (cond
                     (eofp (ill-formed-certificate-er
                            ctx
                            'chk-raise-portcullis{pre-alist-0}
                            file1 file2))
                     (t (value pre-alist0)))))
           (expansion-alist
            (cond ((eq pre-alist0 :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-sysfile
            (cond ((eq pre-alist0 :expansion-alist)
                   (mv-let (eofp pre-alist1 state)
                           (read-object ch state)
                           (cond (eofp (ill-formed-certificate-er
                                        ctx
                                        'chk-raise-portcullis{pre-alist-1}
                                        file1 file2))
                                 (t (value pre-alist1)))))
                  (t (value pre-alist0))))
           (pre-alist-abs
            (let ((pre-alist-abs0
                   (sysfile-to-filename-include-book-alist
                    pre-alist-sysfile
                    nil ; local-markers-allowedp
                    state)))
              (cond ((eq pre-alist-abs0 :error)
                     (ill-formed-certificate-er
                      ctx
                      'chk-raise-portcullis{pre-alist-2}
                      file1 file2 pre-alist-sysfile))
                    (t (value pre-alist-abs0)))))
           (post-alist3-sysfile
            (mv-let (eofp post-alist1 state)
                    (read-object ch state)
                    (cond (eofp (ill-formed-certificate-er
                                 ctx
                                 'chk-raise-portcullis{post-alist-1}
                                 file1 file2))
                          (t (value post-alist1)))))
           (post-alist3-abs
            (let ((post-alist3-abs0
                   (sysfile-to-filename-include-book-alist
                    post-alist3-sysfile
                    t ; local-markers-allowedp
                    state)))
              (cond ((eq post-alist3-abs0 :error)
                     (ill-formed-certificate-er
                      ctx
                      'chk-raise-portcullis{post-alist-2}
                      file1 file2 post-alist3-sysfile))
                    (t (value post-alist3-abs0)))))
           (chk-sum1
            (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 (value chk-sum1)))))
           (pcert-info
            (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 (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))))))))))
           (chk-sum2
            (value (and (not light-chkp) ; optimization
                        (check-sum-cert-obj
                         portcullis-cmds     ; :cmds
                         pre-alist-sysfile   ; :pre-alist-sysfile
                         post-alist3-sysfile ; :post-alist-sysfile
                         expansion-alist     ; :expansion-alist
                         ))))
           (actual-alist
            (value (global-val 'include-book-alist (w state)))))
        (cond
         ((and (not light-chkp)
               (or (not (integerp chk-sum2))
                   (not (int= chk-sum1 chk-sum2))))
          (ill-formed-certificate-er
           ctx
           'chk-raise-portcullis{chk-sum}
           file1 file2
           (list :chk-sum1 chk-sum1 :chk-sum2 chk-sum2

; Developer debug:
;                :portcullis-cmds portcullis-cmds
;                :pre-alist-sysfile pre-alist-sysfile
;                :pre-alist-abs pre-alist-abs
;                :post-alist3-sysfile post-alist3-sysfile
;                :post-alist3-abs post-alist3-abs
;                :expansion-alist expansion-alist

                 )))
         ((and (not light-chkp)
               (not (include-book-alist-subsetp
                     pre-alist-abs
                     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-abs
                                                        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-sysfile pre-alist-sysfile
                         :pre-alist-abs pre-alist-abs
                         :post-alist-sysfile post-alist3-sysfile
                         :post-alist-abs post-alist3-abs
                         :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))
              (let ((saved-wrld (w 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)
                                  (cond
                                   (error-flg
                                    (pprogn

; Chk-certificate-file1 may have evaluated portcullis commands from the
; certificate before determining that there is an error (e.g., due to a
; checksum problem that might have been caused by a package change).  It might
; be confusing to a user to see those portcullis commands survive after a
; report that the book is uncertified, so we restore the world.

                                     (set-w! saved-wrld state)
                                     (include-book-er file1 file2
                                                      "An error was ~
                                                       encountered when ~
                                                       checking the ~
                                                       certificate file for ~
                                                       ~x0."
                                                      :uncertified-okp
                                                      suspect-book-action-alist
                                                      ctx state)))
                                   (t (value val))))))))))))))))

; All of the above is used during an include-book to verify that a
; certificate is well-formed and to raise the portcullis of the book.
; It happens that the code is also used by certify-book to recover the
; portcullis of a book from an old certificate.  We now continue with
; certify-book's checking, which next moves on to the question of
; whether the environment in which certify-book was called is actually
; suitable for a certification.

(defun equal-modulo-hidden-defpkgs (cmds1 cmds2)

; Keep this in sync with get-cmds-from-portcullis1, make-hidden-defpkg, and the
; #-acl2-loop-only and #+acl2-loop-only definitions of defpkg.

; Test equality of cmds1 and cmds2, except that cmds2 may have hidden defpkg
; events missing from cmds1.

  (cond ((endp cmds2) (endp cmds1))
        ((and cmds1
              (equal (car cmds1) (car cmds2)))
         (equal-modulo-hidden-defpkgs (cdr cmds1) (cdr cmds2)))
        (t (let ((cmd (car cmds2)))
             (case-match cmd
               (('defpkg & & & & 't) ; keep in sync with make-hidden-defpkg
                (equal-modulo-hidden-defpkgs cmds1 (cdr cmds2)))
               (& nil))))))

(defun cert-obj-for-convert (full-book-name dir pre-alist-abs 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-abs
                       (access cert-obj cert-obj :pre-alist-abs)))
           (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-abs
               (access cert-obj cert-obj :pre-alist-abs)))
          (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 (user-book-name 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
; and cbds are 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 lists of the same length, 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-abs (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
          "Your certify-book command specifies a certification world of ~
           length ~x0 but it is actually of length ~x1.  Perhaps you intended ~
           to issue a command of the form: (certify-book ~x2 ~x1 ...).  See ~
           :DOC certify-book."
          k (length cmds) user-book-name))
     ((assoc-equal file pre-alist-abs)

; 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))
                         ((null cbds)

; This case arises when either there are no commands (cmds), or else we are
; using commands from an existing .cert file; see the call of
; chk-acceptable-certify-book1 with cmds = nil in chk-acceptable-certify-book.

                          (value cmds))
                         (t

; Now that we know we have a list of embedded event forms, we are ready to
; replace relative pathnames by absolute pathnames.  See fix-portcullis-cmds.
; At one time we considered not fixing the portcullis commands when the cert-op
; is :write-acl2x or :write-acl2xu.  But we keep it simple here and fix
; unconditionally.

                          (fix-portcullis-cmds dir cmds cbds names
                                               wrld ctx state)))))
          (cond
           ((eq cert-op :convert-pcert)
            (cert-obj-for-convert file dir pre-alist-abs fixed-cmds
                                  suspect-book-action-alist
                                  ctx state))
           (t
            (value
             (make cert-obj
                   :cmds fixed-cmds
                   :pre-alist-abs
                   (cond (cert-obj (access cert-obj cert-obj
                                           :pre-alist-abs))
                         (t pre-alist-abs))
                   :pre-alist-sysfile
                   (cond
                    (cert-obj (access cert-obj cert-obj
                                      :pre-alist-sysfile))
                    (t (filename-to-sysfile-include-book-alist pre-alist-abs
                                                               nil
                                                               state)))
                   :post-alist-abs nil            ; not needed
                   :post-alist-sysfile nil        ; not needed
                   :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 book-name
                                          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 book-name 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-sysfile
                                    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-sysfile
                               post-alist3-sysfile ; :post-alist-sysfile
                               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-sysfile!")))
       (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-sysfile 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 (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-sysfile), where cmds is the list of portcullis commands that
; created the world in which the certification was done, and pre-alist-sysfile
; is the include-book-alist just before certification was done, with
; full-book-names under the system books converted to sysfiles.  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-sysfile (cdr portcullis)
;       :post-alist-sysfile post-alist3-sysfile
;       :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-abs, 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-sysfile
; post-alist3-sysfile
; chk-sum

; where chk-sum is the check sum of ((cmds . pre-alist-sysfile)
; . post-alist3-sysfile), where post-alist3-sysfile is the result of converting
; to sysfiles those full-book-names in post-alist3-abs that are under the
; system books.

; The reason the portcullis commands are written this way, rather than
; as a single object, is that we can't read them all at once since
; they may contain DEFPKGs.  We have to read and eval the cmdi
; individually.

  (let* ((certification-file (convert-book-name-to-cert-name file cert-op))
         (post-alist3-abs (mark-local-included-books post-alist1 post-alist2))
         (post-alist3-sysfile (filename-to-sysfile-include-book-alist
                               post-alist3-abs
                               t ; local-markers-allowedp
                               state)))
    (make-certificate-file1 file portcullis
                            (concatenate 'string certification-file ".temp")
                            post-alist3-sysfile 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))
   ((raw-include-book-dir-p state)
    (or (cdr (assoc-eq dir (f-get-global 'raw-include-book-dir!-alist state)))
        (cdr (assoc-eq dir (f-get-global 'raw-include-book-dir-alist state)))))
   (t
    (let ((wrld (w state)))
      (or (cdr (assoc-eq dir
                         (cdr (assoc-eq :include-book-dir-alist
                                        (table-alist 'acl2-defaults-table
                                                     wrld)))))
          (cdr (assoc-eq dir
                         (table-alist 'include-book-dir!-table wrld))))))))

(defmacro include-book-dir-with-chk (soft-or-hard ctx dir)
  `(let ((ctx ,ctx)
         (dir ,dir))
     (let ((dir-value (include-book-dir dir state)))
       (cond ((null dir-value) ; hence, dir is not :system
              (er ,soft-or-hard ctx
                  "The legal values for the :DIR argument are keywords that ~
                   include :SYSTEM as well as those added by a call of ~v0.  ~
                   However, that argument is ~x1, which is not ~@2."
                  '(add-include-book-dir add-include-book-dir!)
                  dir
                  (cond
                   ((keywordp dir)
                    (msg
                     "among the list of those legal values, ~x0"
                     (cons :system
                           (strip-cars
                            (append
                             (cdr (assoc-eq :include-book-dir-alist
                                            (table-alist 'acl2-defaults-table
                                                         (w state))))
                             (table-alist 'include-book-dir!-table
                                          (w state)))))))
                   (t "a keyword"))))
             (t ,(if (eq soft-or-hard 'soft)
                     '(value dir-value)
                   'dir-value))))))

(defun 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 an extension of the certification world by
; either by processing all the events in the book during the proof pass of
; certify-book on full-book-name (none of the events being local, in that
; case), or else by processing an initial subsequence of those events followed
; by including that book (but replacing each of the already-processed events by
; a no-op; see cert-include-expansion-alist).  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)
                                          (or (null (cddar 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).

  (concatenate 'string
               (remove-lisp-suffix x nil)
               "acl2x"))

(defun acl2x-alistp (x index len)
  (cond ((atom x)
         (and (null x)
              (< index len)))
        ((consp (car x))
         (and (integerp (caar x))
              (< index (caar x))
              (acl2x-alistp (cdr x) (caar x) len)))
        (t nil)))

(defun read-acl2x-file (acl2x-file full-book-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
            (prog2$

; We use observation-cw just below, instead of observation, because we do not
; want to inhibit these observations during include-book.  One can still
; inhibit OBSERVATION output globally with set-inhibit-output-lst in order to
; turn off all such messages.

             (observation-cw ctx
                             "Reading .port file, ~s0."
                             port-file)
             (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
; 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.

         (uncertified-okp-effective (if (member-eq (cert-op state)
                                                   '(nil :write-acl2xu))
                                        uncertified-okp
                                      nil))
         (suspect-book-action-alist
          (list (cons :uncertified-okp uncertified-okp-effective)
                (cons :defaxioms-okp defaxioms-okp)
                (cons :skip-proofs-okp skip-proofs-okp)))
         (include-book-alist0 (global-val 'include-book-alist wrld0)))
    (er-progn
     (chk-book-name user-book-name full-book-name ctx state)
     (revert-world-on-error
      (cond
       ((and (not (f-get-global 'boot-strap-flg state))
             full-book-name
             (assoc-equal full-book-name include-book-alist0))
        (stop-redundant-event ctx state))
       (t
        (let* ((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))
                     (cert-obj
                      (cond (behalf-of-certify-flg (value nil))
                            ((f-get-global 'ignore-cert-files state)
                             (cond
                              ((eq uncertified-okp-effective nil)

; Include-book-er returns an error or (value nil).

                               (include-book-er
                                full-book-name nil
                                (if (equal full-book-name
                                           (f-get-global 'ignore-cert-files
                                                         state))
                                    "Include-book is specifying ~
                                     :UNCERTIFIED-OKP :IGNORE-CERTS, which ~
                                     requires that its certificate file (if ~
                                     any) must be ignored."
                                  (msg "A superior include-book event for ~x0 ~
                                        has specified :UNCERTIFIED-OKP ~
                                        :IGNORE-CERTS, which requires that ~
                                        the certificate files (if any) for ~
                                        its sub-books must be ignored."
                                       (f-get-global 'ignore-cert-files
                                                     state)))
                                :uncertified-okp
                                suspect-book-action-alist
                                ctx state))
                              (t (value nil))))
                            (t (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
                                        (not (f-get-global 'port-file-enabled state)))
                                    (value nil))
                                   (t (eval-port-file full-book-name ctx state)))
                             (value (w state))))
                     (post-alist-abs (value (and cert-obj
                                                 (access cert-obj cert-obj
                                                         :post-alist-abs))))
                     (cert-full-book-name (value (car (car post-alist-abs)))))
             (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 (f-get-global 'boot-strap-flg state))
                    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-abs 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-abs)) 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-abs))
                                              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 one ~
                                can often move a certified book from one ~
                                directory to another after ~
                                cer~-ti~-fi~-ca~-tion, we insist that it keep ~
                                the same familiar name.  This allows the ~
                                cer~-ti~-fi~-cate file to contain the ~
                                familiar name, making it easier to identify ~
                                which cer~-ti~-fi~-cates go with which files ~
                                and inspiring a little more confidence that ~
                                the cer~-ti~-fi~-cate really does describe ~
                                the alleged file.  In the present case, it ~
                                looks as though the familiar book name was ~
                                changed after cer~-ti~-fi~-ca~-tion.  For ~
                                what it is worth, the 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-abs)))
                                     (cons #\4 familiar-name)
                                     (cons #\5 (cddddr (car post-alist-abs)))
                                     (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-abs))
                                              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-abs)))
                                     (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-abs)))
                              (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 ; 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.

                              (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 ; see Essay on Guard Checking
                                  t)
                                 (in-local-flg
                                  (and (f-get-global 'in-local-flg state)
                                       'local-include-book))
                                 (including-uncertified-p (not certified-p)))
                                (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.

; Moreover, if we are doing the include-book pass of a certify-book command,
; then we also do not allow process-embedded-events-to set the ACL2 defaults
; table at the beginning.

                                   (if behalf-of-certify-flg
                                       :do-not-install!
                                     :do-not-install)
                                   skip-proofsp
                                   (cadr (car ev-lst))
                                   (list 'include-book full-book-name)
                                   (subst-by-position expansion-alist
                                                      (cdr ev-lst)
                                                      1)
                                   1
                                   (and (eq skip-proofsp 'include-book)

; We want to skip the make-event check when including 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-abs))
                                            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-abs))
                                           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-abs 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-abs)
                                 (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-abs)))

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

                                              (remove-lisp-suffix
                                               (or cert-full-book-name
                                                   full-book-name)
                                               t)
                                              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
                                                 (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-abs)
                                                      (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-abs))))
                                                   (if full-book-name
                                                       (global-set
                                                        'skip-proofs-seen
                                                        (list :include-book
                                                              full-book-name)
                                                        wrld6)
                                                     wrld6))))))
                                         wrld7)
                                       state))))))))))))))))))))))))))

(defun chk-include-book-inputs (load-compiled-file
                                uncertified-okp
                                defaxioms-okp
                                skip-proofs-okp
                                ctx state)
  
  (let ((er-str "The ~x0 argument of include-book must be ~v1.  The value ~x2 ~
                 is thus illegal.  See :DOC include-book."))
    (cond
     ((not (member-eq load-compiled-file *load-compiled-file-values*))
      (er soft ctx er-str
          :load-compiled-file
          *load-compiled-file-values*
          load-compiled-file))
     ((not (member-eq uncertified-okp '(t nil :ignore-certs)))
      (er soft ctx er-str
          :uncertified-okp
          '(t nil :ignore-certs)
          uncertified-okp))
     ((not (member-eq defaxioms-okp '(t nil)))
      (er soft ctx er-str
          :defaxioms-okp
          '(t nil)
          defaxioms-okp))
     ((not (member-eq skip-proofs-okp '(t nil)))
      (er soft ctx er-str
          :skip-proofs-okp
          '(t nil)
          skip-proofs-okp))
     (t (value nil)))))

(defun include-book-fn (user-book-name state
                                       load-compiled-file
                                       expansion-alist
                                       uncertified-okp
                                       defaxioms-okp
                                       skip-proofs-okp
                                       ttags
                                       dir
                                       event-form)

; Note that the acl2-defaults-table is initialized when raising the portcullis.
; As of this writing, this happens by way of a call of chk-certificate-file in
; include-book-fn1, as chk-certificate-file calls chk-certificate-file1, which
; calls chk-raise-portcullis, etc.

; 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))
    (state-global-let*
     ((compiler-enabled (f-get-global 'compiler-enabled state))
      (port-file-enabled (f-get-global 'port-file-enabled 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)
        (er-progn
         (chk-input-object-file full-book-name ctx state)
         (chk-include-book-inputs load-compiled-file
                                  uncertified-okp
                                  defaxioms-okp
                                  skip-proofs-okp
                                  ctx state)
         (state-global-let*
          ((ignore-cert-files (or (f-get-global 'ignore-cert-files state)
                                  (and (eq uncertified-okp :ignore-certs)
                                       full-book-name))))
          (let* ((behalf-of-certify-flg (not (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)))))
            (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
; 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
; 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 t in certify-book-fn
; and in include-book-fn (using state-global-let*), as well as in prove and
; puff-fn1.  We bind it to nil pc-single-step-primitive.  We do not bind
; guard-checking-on in defconst-fn.  Here we explain these decisions.

; We prefer to bind guard-checking-on to a predetermined fixed value when
; certifying or including books.  Why?  Book certification is a logical act.
; :Set-guard-checking is intended to be extra-logical, giving the user control
; over evaluation in the interactive loop, and hence we do not want it to
; affect how books are processed, either during certification or during
; inclusion.

; So the question now is whether to bind guard-checking-on to t or to nil for
; book certification and for book inclusion.  (We reject :none and :all because
; they can be too inefficient.)  We want it to be the case that if a book is
; certified, then subsequently it can be included.  In particular, it would be
; unfortunate if certification is done in an environment with guard checking
; off, and then later we get a guard violation when including the book with
; guard checking on.  So we should bind guard-checking-on the same in
; certify-book as in include-book.

; We argue now for binding guard-checking-on to t in certify-book-fn (and
; hence, as argued above, in include-book-fn as well).  Consider this scenario
; brought to our attention by Eric Smith: one certifies a book with
; guard-checking-on bound to nil, but then later gets a guard violation when
; loading that book during a demo using LD (with the default value of t for
; guard-checking-on).  Horrors!  So we bind guard-checking-on to t in
; certify-book-fn, to match the default in the loop.

; We note that raw Lisp evaluation should never take place for the body of a
; defconst form (outside the boot-strap), because the raw Lisp definition of
; defconst avoids such evaluation when the name is already bound, which should
; be the case from prior evaluation of the defconst form in the ACL2 loop.
; Value-triple also is not evaluated in raw Lisp, where it is defined to return
; nil.

; We bind guard-checking-on to nil in prove, because proofs can use evaluation
; and such evaluation should be done in the logic, without regard to guards.

; It can be important to check guards during theory operations like
; union-theory.  For example, with guard checking off in Version_2.9, one gets
; a hard Lisp error upon evaluation of the following form.

; (in-theory (union-theories '((:rewrite no-such-rule))
;                            (current-theory 'ground-zero)))

; (Aside.  One does not get such an error in Version_2.8, because *1* functions
; checked guards of system functions regardless of the value of
; guard-checking-on; but we have abandoned that aggressive approach, relying
; instead on safe-mode.)  Our solution is to bind guard-checking-on to t in
; eval-theory-expr, which calls simple-translate-and-eval and hence causes the
; guards to be checked.

; Note that guard-checking-on is bound to nil in pc-single-step-primitive.  We
; no longer recall why, but we may as well preserve that binding.

(defun expansion-filename (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.

; The following issue came up when attempting to compile an expansion file with
; GCL that had been created with CCL.  (We don't officially support using more
; than one host Lisp on the same files, but it's convenient sometimes to do
; that anyhow.)  The community book in question was
; books/projects/legacy-defrstobj/typed-record-tests.lisp, and ACL2 was used,
; not ACL2(h).  The event that caused the trouble was this one:

;   (make-event
;    `(def-typed-record char
;       :elem-p        (characterp x)
;       :elem-list-p   (character-listp x)
;       :elem-fix      (character-fix x)
;       :elem-default  ,(code-char 0)
;       ;; avoid problems with common-lisp package
;       :in-package-of foo))

; In the expansion file, (code-char 0) was written by CCL as #\Null:
; write-expansion-file calls print-object$ (and print-objects, which calls
; print-object$), and print-object$ calls prin1, which prints "readably".  Now
; our ACL2 readtable can't handle #\Null, but we call compile-certified-file on
; the expansion file, and that calls acl2-compile-file, and that binds
; *readtable* to *reckless-acl2-readtable*.  But the latter binds #\ to the old
; character reader, which can handle #\Null in CCL, but not in GCL.

  #+acl2-loop-only
  (declare (ignore new-fns-exec 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)))

(defun hons-union-ordered-string-lists (x y)
  (cond ((null x) y)
        ((null y) x)
        ((hons-equal x y)
         x)
        ((hons-equal (car x) (car y))
         (hons (car x)
               (hons-union-ordered-string-lists (cdr x) (cdr y))))
        ((string< (car x) (car y))
         (hons (car x)
               (hons-union-ordered-string-lists (cdr x) y)))
        (t ; (string< (car y) (car x))
         (hons (car y)
               (hons-union-ordered-string-lists x (cdr y))))))

(defun expansion-alist-pkg-names-memoize (x)

; See expansion-alist-pkg-names.

  (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-rec (names kpa)
  (cond ((endp kpa)
         nil)
        ((member-equal (package-entry-name (car kpa)) names)
         (delete-names-from-kpa-rec names (cdr kpa)))
        (t
         (cons (car kpa)
               (delete-names-from-kpa-rec names (cdr kpa))))))

(defun delete-names-from-kpa (names kpa)
  (cond ((null names) kpa) ; optimization for common case
        (t (delete-names-from-kpa-rec names kpa))))

(defun print-certify-book-step-2 (ev-lst expansion-alist pcert0-file acl2x-file
                                         state)
  (io? event nil state
       (ev-lst expansion-alist pcert0-file acl2x-file)
       (fms "* Step 2:  There ~#0~[were no forms in the file. Why are you ~
             making such a silly book?~/was one form in the file.~/were ~n1 ~
             forms in the file.~]  We now attempt to establish that each ~
             form, whether local or non-local, is indeed an admissible ~
             embedded event form in the context of the previously admitted ~
             ones.~@2~%"
            (list (cons #\0 (zero-one-or-more ev-lst))
                  (cons #\1 (length ev-lst))
                  (cons #\2
                        (cond (expansion-alist
                               (msg "  Note that we are substituting ~n0 ~
                                     ~#1~[form~/forms~], as specified in ~
                                     file~#2~[~x2~/s ~&2~], for ~#1~[a ~
                                     corresponding top-level ~
                                     form~/corresponding top-level forms~] in ~
                                     the book."
                                    (length expansion-alist)
                                    expansion-alist
                                    (if pcert0-file
                                        (if acl2x-file
                                            (list pcert0-file acl2x-file)
                                          (list pcert0-file))
                                      (list acl2x-file))))
                              (t ""))))
            (proofs-co state) state nil)))

(defun print-certify-book-step-3 (index state)
  (io? event nil state
       (index)
       (cond
        ((null index)
         (fms "* Step 3:  That completes the admissibility check.  Each form ~
               read was an embedded event form and was admissible.  No LOCAL ~
               forms make it necessary to check for local incompatibilities, ~
               so we skip that check.~%"
              nil (proofs-co state) state nil))
        (t
         (assert$
          (posp index)
          (fms "* Step 3:  That completes the admissibility check.  Each form ~
                read was an embedded event form and was admissible.  We now ~
                retract back to the ~#0~[initial world~/world created by ~
                admitting the first event~/world created by the first ~n1 ~
                events~]~#2~[~/ after the initial IN-PACKAGE form~] and try to ~
                include~#2~[~/ the remainder of~] the book.  This may expose ~
                local incompatibilities.~%"
               (list (cons #\0 (zero-one-or-more (1- index)))
                     (cons #\1 (1- index))
                     (cons #\2 (if (int= 1 index) 0 1)))
               (proofs-co state) state nil))))))

(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 cert-op state)
  (io? event nil state
       (full-book-name cert-op)
       (fms "* Step 4:  Write the certificate for ~x0 in ~x1.~%"
            (list
             (cons #\0 full-book-name)
             (cons #\1
                   (convert-book-name-to-cert-name full-book-name cert-op)))
            (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-state (state)
  #+acl2-loop-only
  (read-acl2-oracle state)
  #-acl2-loop-only
  (hcomp-build-from-state-raw
   (reverse (global-val
             'top-level-cltl-command-stack
             (w state)))
   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.

  (concatenate 'string
               (remove-lisp-suffix full-book-name nil)
               (f-get-global 'compiled-file-extension state)))

(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 (sysfile-to-filename-include-book-alist
                             post-alist
                             t ; local-markers-allowedp
                             state)))))))))))))

(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 symbol-package-name-set (syms acc)
  (declare (xargs :guard (and (symbol-listp syms)
                              (true-listp acc))))
  (cond ((endp syms) acc)
        (t (symbol-package-name-set
            (cdr syms)
            (add-to-set-equal (symbol-package-name (car syms))
                              acc)))))

(defun names-of-symbols-in-package (syms package acc)
  (declare (xargs :guard (symbol-listp syms)))
  (cond ((endp syms) acc)
        (t (names-of-symbols-in-package
            (cdr syms)
            package
            (if (equal (symbol-package-name (car syms))
                       package)
                (cons (symbol-name (car syms)) acc)
              acc)))))

(defun symbol-list-to-package-alist1 (syms packages acc)
  (declare (xargs :guard (and (symbol-listp syms)
                              (true-listp packages)
                              (alistp acc))))
  (cond ((endp packages) acc)
        (t (symbol-list-to-package-alist1
            syms
            (cdr packages)
            (acons (car packages)
                   (names-of-symbols-in-package syms (car packages) nil)
                   acc)))))

(defun symbol-list-to-package-alist (syms)

; To verify guards:

; (defthm true-listp-symbol-package-name-set
;   (equal (true-listp (symbol-package-name-set syms acc))
;          (true-listp acc)))

  (declare (xargs :guard (symbol-listp syms)))
  (symbol-list-to-package-alist1 syms
                                 (symbol-package-name-set syms nil)
                                 nil))

(defun bookdata-alist1 (full-book-name collect-p trips port-pkgs
                                       port-books books
                                       port-consts consts
                                       port-fns fns
                                       port-labels labels
                                       port-macros macros
                                       port-stobjs stobjs
                                       port-theories theories
                                       port-thms thms)

; See maybe-write-bookdata.

  (cond
   ((endp trips)
    (list :pkgs          port-pkgs
          :port-books    port-books
          :books         books
          :port-consts   (symbol-list-to-package-alist port-consts)
          :consts        (symbol-list-to-package-alist consts)
          :port-fns      (symbol-list-to-package-alist port-fns)
          :fns           (symbol-list-to-package-alist fns)
          :port-labels   (symbol-list-to-package-alist port-labels)
          :labels        (symbol-list-to-package-alist labels)
          :port-macros   (symbol-list-to-package-alist port-macros)
          :macros        (symbol-list-to-package-alist macros)
          :port-stobjs   (symbol-list-to-package-alist port-stobjs)
          :stobjs        (symbol-list-to-package-alist stobjs)
          :port-theories (symbol-list-to-package-alist port-theories)
          :theories      (symbol-list-to-package-alist theories)
          :port-thms     (symbol-list-to-package-alist port-thms)
          :thms          (symbol-list-to-package-alist thms)))
   (t
    (let ((trip (car trips)))
      (cond
       ((and (eq (car trip) 'INCLUDE-BOOK-PATH)
             (eq (cadr trip) 'GLOBAL-VALUE))
        (bookdata-alist1
         full-book-name
         (cond ((null (cddr trip))
                'port)
               (t (equal (car (cddr trip))
                         full-book-name)))
         (cdr trips)
         port-pkgs
         (cond ((and (eq collect-p 'port)
                     (cddr trip)
                     (not (equal (car (cddr trip))
                                 full-book-name)))
                (cons (car (cddr trip))
                      port-books))
               (t port-books))
         (cond ((and (eq collect-p t)
                     (cddr trip))
                (assert$ ; collect-p = t, so we are already in full-book-name
                 (not (equal (car (cddr trip))
                             full-book-name))
                 (cons (car (cddr trip))
                       books)))
               (t books))
         port-consts consts
         port-fns fns
         port-labels labels
         port-macros macros
         port-stobjs stobjs
         port-theories theories
         port-thms thms))
       ((not collect-p)
        (bookdata-alist1
         full-book-name nil (cdr trips) port-pkgs
         port-books books
         port-consts consts
         port-fns fns
         port-labels labels
         port-macros macros
         port-stobjs stobjs
         port-theories theories
         port-thms thms))
       ((and (eq (car trip) 'EVENT-LANDMARK)
             (eq (cadr trip) 'GLOBAL-VALUE)
             (eq (access-event-tuple-type (cddr trip)) 'DEFPKG))
        (bookdata-alist1
         full-book-name collect-p (cdr trips)
         (assert$ (eq collect-p 'port) ; defpkg cannot be in the current book
                  (cons (access-event-tuple-namex (cddr trip))
                        port-pkgs))
         port-books books
         port-consts consts
         port-fns fns
         port-labels labels
         port-macros macros
         port-stobjs stobjs
         port-theories theories
         port-thms thms))
       (t
        (let ((name (name-introduced trip nil)))
          (cond
           (name
            (case (cadr trip)
              (FORMALS
               (bookdata-alist1
                full-book-name collect-p (cdr trips) port-pkgs
                port-books books
                port-consts consts
                (if (eq collect-p 'port)
                    (cons name port-fns)
                  port-fns)
                (if (eq collect-p 'port)
                    fns
                  (cons name fns))
                port-labels labels
                port-macros macros
                port-stobjs stobjs
                port-theories theories
                port-thms thms))
              (THEOREM
               (bookdata-alist1
                full-book-name collect-p (cdr trips) port-pkgs
                port-books books
                port-consts consts
                port-fns fns
                port-labels labels
                port-macros macros
                port-stobjs stobjs
                port-theories theories
                (if (eq collect-p 'port)
                    (cons name port-thms)
                  port-thms)
                (if (eq collect-p 'port)
                    thms
                  (cons name thms))))
              (CONST
               (bookdata-alist1
                full-book-name collect-p (cdr trips) port-pkgs
                port-books books
                (if (eq collect-p 'port)
                    (cons name port-consts)
                  port-consts)
                (if (eq collect-p 'port)
                    consts
                  (cons name consts))
                port-fns fns
                port-labels labels
                port-macros macros
                port-stobjs stobjs
                port-theories theories
                port-thms thms))
              (STOBJ
               (bookdata-alist1
                full-book-name collect-p (cdr trips) port-pkgs
                port-books books
                port-consts consts
                port-fns fns
                port-labels labels
                port-macros macros
                (if (eq collect-p 'port)
                    (cons name port-stobjs)
                  port-stobjs)
                (if (eq collect-p 'port)
                    stobjs
                  (cons name stobjs))
                port-theories theories
                port-thms thms))
              (LABEL
               (bookdata-alist1
                full-book-name collect-p (cdr trips) port-pkgs
                port-books books
                port-consts consts
                port-fns fns
                (if (eq collect-p 'port)
                    (cons name port-labels)
                  port-labels)
                (if (eq collect-p 'port)
                    labels
                  (cons name labels))
                port-macros macros
                port-stobjs stobjs
                port-theories theories
                port-thms thms))
              (THEORY
               (bookdata-alist1
                full-book-name collect-p (cdr trips) port-pkgs
                port-books books
                port-consts consts
                port-fns fns
                port-labels labels
                port-macros macros
                port-stobjs stobjs
                (if (eq collect-p 'port)
                    (cons name port-theories)
                  theories)
                (if (eq collect-p 'port)
                    theories
                  (cons name theories))
                port-thms thms))
              (MACRO-BODY
               (bookdata-alist1
                full-book-name collect-p (cdr trips) port-pkgs
                port-books books
                port-consts consts
                port-fns fns
                port-labels labels
                (if (eq collect-p 'port)
                    (cons name port-macros)
                  port-macros)
                (if (eq collect-p 'port)
                    macros
                  (cons name macros))
                port-stobjs stobjs
                port-theories theories
                port-thms thms))
              (GLOBAL-VALUE

; Then name-introduced is a full book name, but we extend books
; above already using include-book-path.

               (assert$
                (eq (car trip) 'CERTIFICATION-TUPLE)
                (bookdata-alist1
                 full-book-name collect-p (cdr trips) port-pkgs
                 port-books books
                 port-consts consts
                 port-fns fns
                 port-labels labels
                 port-macros macros
                 port-stobjs stobjs
                 port-theories theories
                 port-thms thms)))
              (otherwise
               (er hard 'bookdata-alist1
                   "Unexpected case for the cadr of ~x0"
                   trip))))
           (t (bookdata-alist1
               full-book-name collect-p (cdr trips) port-pkgs
               port-books books
               port-consts consts
               port-fns fns
               port-labels labels
               port-macros macros
               port-stobjs stobjs
               port-theories theories
               port-thms thms))))))))))

(defun bookdata-alist (full-book-name wrld)
  (assert$
   (null (global-val 'INCLUDE-BOOK-PATH wrld))
   (let* ((boot-strap-wrld
           (lookup-world-index 'command
                               (relative-to-absolute-command-number 0 wrld)
                               wrld))
          (boot-strap-len (length boot-strap-wrld))
          (wrld-len (length wrld))
          (new-trips (first-n-ac-rev (- wrld-len boot-strap-len) wrld nil)))
     (bookdata-alist1 full-book-name 'port new-trips nil
                      nil nil nil nil nil nil nil nil
                      nil nil nil nil nil nil nil nil))))

(defun maybe-write-bookdata (full-book-name wrld ctx state)

; Let full-book-name be a full book name, say foo.lisp.  Then when state global
; 'write-bookdata is non-nil, successful certification of full-book-name will
; cause a file foo__bookdata.out to be written.  That file will be of the form
; (full-book-name . kwd-values), where kwd-values is a keyword-value-listp that
; associates keywords with lists as follows.  In each case, only events in the
; world after including the book are considered, hence not events that are
; merely local or events events within other books, but including events from
; the the portcullis (certification world) for foo.lisp.  The keyword :books is
; associated with the list of full book names of included books.  Each other
; keyword is associated with an alist that associates each key, a package name,
; with a list of symbol-names for symbols in that package that are introduced
; for that keyword, as follows.

; :CONSTS   - constant symbol introduced by defconst
; :FNS      - function symbol: introduced by defun, defuns, or defchoose;
;             or constrained
; :LABELS   - symbol introduced by deflabel
; :MACROS   - macro name introduced by defmacro
; :STOBJS   - stobj name introduced by defstobj or defabsstobj
; :THEORIES - theory name introduced by deftheory
; :THMS     - theorem name introduced by defthm or defaxiom

  (cond
   ((null (f-get-global 'write-bookdata state))
    state)
   (t (let ((outfile (concatenate
                      'string
                      (subseq full-book-name 0 (- (length full-book-name) 5))
                      "__bookdata.out")))
        (mv-let
         (channel state)
         (open-output-channel outfile :object state)
         (cond ((null channel)
                (prog2$ (er hard ctx
                            "Error in maybe-write-bookdata: Unable to open ~
                             file ~x0 for output."
                            outfile)
                        state))
               (t (pprogn
                   (print-object$-ser (cons full-book-name
                                            (bookdata-alist full-book-name
                                                            wrld))
                                      nil ; serialize-character
                                      channel
                                      state)
                   (close-output-channel channel state)))))))))

(defun fromto (i j)
  (declare (xargs :guard (and (rationalp i) (rationalp j))))
  (if (< j i)
      nil
    (cons i (fromto (1+ i) j))))

(defun remove-smaller-keys-from-sorted-alist (index alist)

; Alist is an alist whose keys are rational numbers.  Return the tail of alist,
; if any, starting with a key that is at least as large as index.  Thus, if
; alist is sorted, then we return its tail of entries at least as large as
; index.

  (cond ((endp alist) nil)
        ((< (caar alist) index)
         (remove-smaller-keys-from-sorted-alist index (cdr alist)))
        (t alist)))

(defun cert-include-expansion-alist (index expansion-alist)

; We are ready to call include-book-fn after the initial processing of all
; events in a book by certify-book.  But we have already retracted the world to
; the world, w, just before position index, where index=1 corresponds the first
; event after the book's in-package event, hence to the certification world.
; We want to fool include-book-fn into skipping all events that were already
; processed in creating w.  So we replace expansion-alist by one that
; associates every index in the half-open interval [1,index) with a no-op.

  (append (pairlis$ (fromto 1 (1- index))
                    (make-list (1- index)
                               :initial-element '(value-triple nil)))
          (remove-smaller-keys-from-sorted-alist index expansion-alist)))

(defun 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)
                          (cond
                           (pcert

; We have seen a "convert" failure (for creating the .pcert1 file) for
; community book
; books/workshops/2011/verbeek-schmaltz/sources/correctness.lisp.  The problem
; seems to be that build system automatically creates .port files that are
; loaded, but more .port files are around when building correctness.pcert1 file
; than when building correctness.pcert1.pcert0.  Our solution is to make the
; default for :write-port be nil, instead of t, when doing any step of
; provisional certification -- even when ACL2_WRITE_PORT is set, so as to
; defeat the build system's attempt to build .port files when doing
; pcertification steps.

                            (value nil))
                           (t
                            (er-let* ((str
                                       (getenv! "ACL2_WRITE_PORT" state)))
                              (value (cond (str (intern$ (string-upcase str)
                                                         "ACL2"))
                                           (t t))))))) ; default
                         (t (er soft ctx
                                "Illegal :write-port argument, ~x0.  See :DOC ~
                                 certify-book."))))
                       (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 cert. world: already reported
                               ctx state)))
               (state-global-let*
                ((compiler-enabled (f-get-global 'compiler-enabled state))
                 (port-file-enabled (f-get-global 'port-file-enabled state))
                 (certify-book-info (make certify-book-info
                                          :full-book-name full-book-name
                                          :cert-op cert-op
                                          :include-book-phase nil))
                 (match-free-error nil)
                 (defaxioms-okp-cert defaxioms-okp)
                 (skip-proofs-okp-cert skip-proofs-okp)
                 (guard-checking-on ; see Essay on Guard Checking
                  t))
                (er-let* ((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
                                (let (#-acl2-loop-only
                                      (*acl2-error-msg*
                                       *acl2-error-msg-certify-book-step1*))
                                  (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-abs)))))
                                                      (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-abs 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-abs)
                                    (access cert-obj cert-obj :post-alist-abs)
                                    full-book-name ctx state)))
                                (t
                                 (let ((index/old-wrld
                                        (global-val 'cert-replay (w state))))

; Step 3: include the book if necessary.

                                   (pprogn
                                    (assert$
                                     (listp index/old-wrld)
                                     (print-certify-book-step-3
                                      (car index/old-wrld)
                                      state))
                                    (cond
                                     (index/old-wrld
                                      (set-w 'retraction
                                             (cdr index/old-wrld)
                                             state))
                                     (t 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 (not *gcl-large-maxpages*)
                                             (fboundp 'si::sgc-on)
                                             (funcall 'si::sgc-on))
                                        (funcall 'si::sgc-on nil)
                                        (si::gbc t)
                                        (funcall 'si::sgc-on t))
                                       (t (si::gbc t)))
                                      state)
                                    (with-hcomp-bindings
                                     compile-flg

; It may seem strange to call with-hcomp-bindings here -- after all, we call
; include-book-fn below, and we may think that include-book-fn will ultimately
; call load-compiled-book, which calls with-hcomp-bindings.  However, when
; include-book-fn is called on behalf of certify-book, it avoids calling
; include-book-raw and hence avoids calling load-compiled-book; it processes
; events without first doing a load in raw Lisp.  It is up to us to bind the
; *hcomp-xxx* variables here, so that add-trip can use them as it is processing
; events on behalf of the call below of include-book-fn, where
; *inside-include-book-fn* is 'hcomp-build.

                                     (mv-let
                                      (expansion-alist pcert-info)
                                      (cond
                                       ((eq cert-op :create-pcert)
                                        (elide-locals-and-split-expansion-alist
                                         expansion-alist acl2x-expansion-alist
                                         nil nil))
                                       (t (mv expansion-alist
                                              (if (eq cert-op
                                                      :create+convert-pcert)
                                                  :proved
                                                nil))))
                                      (er-let* ((defpkg-items
                                                  (defpkg-items
                                                    pass1-known-package-alist
                                                    wrld1-known-package-alist
                                                    ctx wrld1
                                                    state))
                                                (declaim-list
                                                 (state-global-let*
                                                  ((ld-redefinition-action
                                                    nil)
                                                   (certify-book-info
                                                    (change certify-book-info
                                                            (f-get-global
                                                             'certify-book-info
                                                             state)
                                                            :include-book-phase
                                                            t)))

; Note that we do not bind connected-book-directory before calling
; include-book-fn, because it will bind it for us.  We leave the directory set
; as it was when we parsed user-book-name to get full-book-name, so that
; include-book-fn will parse user-book-name the same way again.

                                                  (er-progn
                                                   (hcomp-build-from-state
                                                    state)
                                                   (cond
                                                    (index/old-wrld
                                                     (include-book-fn
                                                      user-book-name
                                                      state
                                                      nil
                                                      (cert-include-expansion-alist
                                                       (car index/old-wrld)
                                                       expansion-alist)
                                                      uncertified-okp
                                                      defaxioms-okp
                                                      skip-proofs-okp
                                                      ttags-seen
                                                      nil
                                                      nil))
                                                    (t
                                                     (get-declaim-list
                                                      state))))))
                                                (ignore
                                                 (cond
                                                  (index/old-wrld
                                                   (maybe-install-acl2-defaults-table
                                                    saved-acl2-defaults-table
                                                    state))
                                                  (t (value 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)))
                                               (include-book-alist-wrld2
                                                (global-val 'include-book-alist
                                                            wrld2))
                                               (post-alist2-abs
                                                (cond
                                                 (index/old-wrld

; In this case, include-book-fn was evaluated above.  The following call of cdr
; removes the certification tuple stored by the include-book-fn itself.  That
; pair is guaranteed to be the car because it is the most recently added one
; (with add-to-set-equal) and we know it was not already a member of the list
; because chk-acceptable-certify-book1 checked that.  Could a file include
; itself?  It could try.  But if (include-book file) is one of the events in
; file, then the attempt to (include-book file) will cause infinite recursion
; -- because we don't put file on the list of files we've included (and hence
; recognize as redundant) until after we've completed the processing.

                                                  (cdr
                                                   include-book-alist-wrld2))
                                                 (t include-book-alist-wrld2))))
                                          (pprogn
                                           (maybe-write-bookdata
                                            full-book-name wrld2 ctx state)
                                           (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-abs post-alist1-abs
                                             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
                                               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-sysfile))
                                                         (cons extra-entry
                                                               post-alist1-abs)
                                                         (cons extra-entry
                                                               post-alist2-abs)
                                                         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
                                                         (let ((os-expansion-filename
                                                                (and compile-flg
                                                                     (expansion-filename
                                                                      full-book-name t state))))
                                                           (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))
  (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))))
  `(er-progn (ubt! ,(1+ k))
             ,(if compile-flg-supplied-p
                  `(certify-book ,user-book-name ,k ,compile-flg ,@args)
                `(certify-book ,user-book-name ,k))))

; Next we implement defchoose and defun-sk.

(defun redundant-defchoosep (name event-form wrld)
  (let* ((old-ev (get-event name wrld)))
    (and
     old-ev
     (case-match old-ev
       (('defchoose !name old-bound-vars old-free-vars old-body . old-rest)
        (case-match event-form
          (('defchoose !name new-bound-vars new-free-vars new-body . new-rest)
           (and (equal old-bound-vars new-bound-vars)
                (equal old-free-vars new-free-vars)
                (equal old-body new-body)
                (eq (cadr (assoc-keyword :strengthen old-rest))
                    (cadr (assoc-keyword :strengthen new-rest)))))))))))

(defun chk-arglist-for-defchoose (args bound-vars-flg ctx state)
  (cond ((arglistp args) (value nil))
        ((not (true-listp args))
         (er soft ctx
             "The ~#0~[bound~/free~] variables of a DEFCHOOSE event must be a ~
              true list but ~x1 is not."
             (if bound-vars-flg 0 1)
             args))
        (t (mv-let (culprit explan)
                   (find-first-bad-arg args)
                   (er soft ctx
                       "The ~#0~[bound~/free~] variables of a DEFCHOOSE event ~
                        must be a true list of distinct, legal variable names.  ~
                        ~x1 is not such a list.  The element ~x2 violates the ~
                        rules because it ~@3."
                       (if bound-vars-flg 0 1)
                       args culprit explan)))))

(defun 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 '(:strengthen))
           (ka (nthcdr 4 def)) ; def is the argument list of a defchoose call
           (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 argument~#0~[~/s~] ~&0.  ~
              However, ~x1 does not have this form.  See :DOC defchoose."
             valid-keywords
             event-form))
        ((not (booleanp strengthen))
         (er soft ctx
             "The :strengthen argument of a defchoose event must be t or nil. ~
              The event ~x0 is thus illegal."
             event-form))
        ((redundant-defchoosep (car def) event-form wrld)
         (stop-redundant-event ctx state))
        (t
         (enforce-redundancy
          event-form ctx wrld
          (cond
           ((null raw-bound-vars)
            (er soft ctx
                "The bound variables of a defchoose form must be non-empty.  ~
                 The form ~x0 is therefore illegal."
                event-form))
           (t
            (let ((fn (car def))
                  (bound-vars (if (atom raw-bound-vars)
                                  (list raw-bound-vars)
                                raw-bound-vars))
                  (formals (caddr def))
                  (body (cadddr def)))
              (er-progn
               (chk-arglist-for-defchoose bound-vars t ctx state)
               (chk-arglist-for-defchoose formals nil ctx state)
               (er-let*
                ((tbody (translate body t t t ctx wrld state))
                 (wrld (chk-just-new-name fn nil 'function nil ctx wrld
                                          state)))
                (cond
                 ((intersectp-eq bound-vars formals)
                  (er soft ctx
                      "The bound and free variables of a defchoose form must ~
                       not intersect, but their intersection for the form ~x0 ~
                       is ~x1."
                      event-form
                      (intersection-eq bound-vars formals)))
                 (t
                  (let* ((body-vars (all-vars tbody))
                         (bound-and-free-vars (append bound-vars formals))
                         (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
                                     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 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.

  (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)
                (member-eq (car body) '(forall exists))
                (true-listp bound-vars)
                (null (collect-non-legal-variableps bound-vars))))
      (msg "The body (last argument) of a DEFUN-SK form must be a true list of ~
            the form (Q vars term), where Q is ~x0 or ~x1 and vars is a ~
            variable or a true list of variables.  The body ~x2 is therefore ~
            illegal."
           'forall 'exists body))
     ((member-eq 'state bound-vars)
      (msg "The body (last argument) of a DEFUN-SK form must be a true list of ~
            the form (Q vars term), where vars represents the bound ~
            variables.  The bound variables must not include STATE.  The body ~
            ~x0 is therefore illegal."
           body))
     ((null (cadr body))
      (msg "The variables of the body of a DEFUN-SK, following the quantifier ~
            EXISTS or FORALL, must be a non-empty list.  However, in DEFUN-SK ~
            of ~x0, they are empty."
           name))
     ((intersectp-eq bound-vars args)
      (msg "The formal parameters of a DEFUN-SK form must be disjoint from ~
            the variables bound by its body.  However, the ~#0~[variable ~x0 ~
            belongs~/variables ~&0 belong~] to both the formal parameters, ~
            ~x1, and the bound variables, ~x2."
           (intersection-eq bound-vars args)
           args bound-vars))
     ((and (not quant-ok)
           (or (tree-occur-eq 'forall (caddr body))
               (tree-occur-eq 'exists (caddr body))))
      (msg "The symbol ~x0 occurs in the term you have supplied to DEFUN-SK, ~
            namely, ~x1.  By default, this is not allowed.  Perhaps you ~
            believe that DEFUN-SK can appropriately handle quantifiers other ~
            than one outermost quantifier; however, this is not the case.  If ~
            however you really intend this DEFUN-SK form to be executed, ~
            simply give a non-nil :quant-ok argument.  See :DOC defun-sk."
           (if (tree-occur-eq 'forall (caddr body))
               'forall
             'exists)
           body))
     (t nil))))

(defmacro defun-sk (name args body
                         &key
                         quant-ok skolem-name thm-name rewrite strengthen
                         #+:non-standard-analysis
                         (classicalp 't classicalp-p)
                         (witness-dcls
                          '((declare (xargs :non-executable t)))))
  (let* ((exists-p (and (true-listp body)
                        (eq (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
              (add-suffix name "-WITNESS")))
         (thm-name
          (or thm-name
              (add-suffix name
                          (if exists-p "-SUFF" "-NECC"))))
         (msg (non-acceptable-defun-sk-p name args body 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
           ,@(remove1-equal '(declare (xargs :non-executable t)) 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)))))))))

; Here is the defstobj event.  Note that many supporting functions have been
; moved from this file to basis-a.lisp, in support of ACL2 "toothbrush"
; applications.

; We start with the problem of finding the arguments to the defstobj event.
; The form looks likes

; (defstobj name ... field-descri ...
;           :renaming alist
;           :inline flag)

; where the :renaming and :inline keyword arguments are optional.  This syntax
; is not supported by macros because you can't have an &REST arg and a &KEYS
; arg without all the arguments being in the keyword style.  So we use &REST
; and implement the new style of argument recovery.

; Once we have partitioned the args for defstobj, we'll have recovered the
; field-descriptors and a renaming alist.  Our next step is to check that the
; renaming alist is of the correct form.

(defun doublet-style-symbol-to-symbol-alistp (x)
  (cond ((atom x) (equal x nil))
        (t (and (consp (car x))
                (symbolp (caar x))
                (consp (cdar x))
                (symbolp (cadar x))
                (null (cddar x))
                (doublet-style-symbol-to-symbol-alistp (cdr x))))))

; Then, we can use the function defstobj-fnname to map the default
; symbols in the defstobj to the function names the user wants us to
; use.  (It is defined elsewhere because it is needed by translate.)

(defun chk-legal-defstobj-name (name state)
  (cond ((eq name 'state)
         (er soft (cons 'defstobj name)
             "STATE is an illegal name for a user-declared ~
              single-threaded object."))
        ((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-state (car names) state)
        (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)))))

(defun chk-stobj-field-descriptor (name field-descriptor non-memoizable
                                        ctx wrld state)

; See the comment just before chk-acceptable-defstobj1 for an explanation of
; our handling of Common Lisp compliance.

; The argument, non-memoizable, is the value of the :non-memoizable keyword of
; the defstobj event intrducing name.  Let us consider whether there is a need
; to add a check about :non-memoizable for the case of a stobj with stobj
; fields.

; On the one hand, it is fine for the parent stobj to be memoizable regardless
; of whether any child stobjs are non-memoizable.  Suppose that some child
; stobj is non-memoizable but the (new) parent stobj is memoizable.  The
; concern is the case that some memoized function reads the parent twice on the
; same inputs when between those reads, some child stobj has changed without
; any flushing of memoization tables (because the child stobj is
; non-memoizable).  But the only way to change a child stobj is by way of
; stobj-let, which flushes the memo table for each function that takes the
; parent stobj as an argument (since the parent is memoizable).

; On the other hand, suppose that some child stobj is memoizable but the (new)
; parent stobj is non-memoizable.  In this case, stobj-let does not flush the
; parent stobj's memo tables, and we return to the soundness bug illustrated in
; a comment in stobj-let-fn-raw.

  (cond
   ((symbolp field-descriptor) (value nil))
   (t
    (er-progn
     (cond ((and (consp field-descriptor)
                 (symbolp (car field-descriptor))
                 (keyword-value-listp (cdr field-descriptor))
                 (member-equal (length field-descriptor) '(1 3 5 7))
                 (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))
            (child-stobj-memoizable-error-string
             "It is illegal to declare stobj ~x0 as :NON-MEMOIZABLE, because ~
              it has a child stobj, ~x1, that was not thus declared.  See ~
              :DOC defstobj."))
       (cond
        ((and resizable (not (eq resizable t)))
         (er soft ctx
             "The :resizable value in the ~x0 field of ~x1 is illegal:  ~x2.  ~
              The legal values are t and nil."
             field name resizable))
        ((and (consp type)
              (eq (car type) 'array))
         (cond
          ((not (and (true-listp type)
                     (equal (length type) 3)
                     (true-listp (caddr type))
                     (equal (length (caddr type)) 1)))
           (er soft ctx
               "When a field descriptor specifies an ARRAY :type, the type ~
                must be of the form (ARRAY etype (n)).  Note that we only ~
                support single-dimensional arrays.  The purported ARRAY :type ~
                ~x0 for the ~x1 field of ~x2 is not of this form."
               type field name))
          (t (let* ((type0 (fix-stobj-array-type type wrld))
                    (etype (cadr type0))
                    (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.  Also see the comment above
; explaining how stobj-let depends on this check.

                 (cond ((eq etype 'state)
                        (er soft ctx
                            etype-error-string
                            field name etype))
                       ((and non-memoizable
                             (not (getpropc etype 'non-memoizable nil wrld)))
                        (er soft ctx
                            child-stobj-memoizable-error-string
                            name etype))
                       ((null initp) (value nil))
                       (t (er soft ctx
                              "The :initially keyword must be omitted for a ~
                               :type specified as an array of stobjs.  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.  Also see the comment above
; explaining how stobj-let depends on this check.

               (cond ((eq type 'state)
                      (er soft ctx
                          type-error-string
                          field name type))
                     ((and non-memoizable
                           (not (getpropc type 'non-memoizable nil wrld)))
                      (er soft ctx
                          child-stobj-memoizable-error-string
                          name type))
                     ((null initp) (value nil))
                     (t (er soft ctx
                            "The :initially keyword must be omitted for a ~
                             :type specified as a stobj.  But for :type ~x0, ~
                             :initially is specified as ~x1 for the ~x2 field ~
                             of ~x3."
                            type init field name))))
              ((null type-term)
               (er soft ctx
                   type-error-string
                   field name type))
              (t
               (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 chk-acceptable-defstobj1 (name field-descriptors ftemps renaming
                                      non-memoizable ctx wrld state names
                                      const-names)

; We check whether it is legal to define name as a single-threaded
; object with the description given in field-descriptors.  We know
; name is a legal (and new) stobj name and we know that renaming is a
; symbol to symbol doublet-style alist.  But we know nothing else.  We
; either signal an error or return the world in which the event is to
; be processed (thus implementing redefinitions).  Names is, in
; general, the actual set of names that the defstobj event will
; introduce.  That is, it contains the images of the default names
; under the renaming alist.  We accumulate the actual names into it as
; we go and check that it contains no duplicates at the termination of
; this function.  All of the names in names are to be defined as
; functions with :VERIFY-GUARDS T.  See the comment above about
; Common Lisp compliance.

  (cond
   ((endp ftemps)
    (let* ((recog-name (defstobj-fnname name :recognizer :top renaming))
           (creator-name (defstobj-fnname name :creator :top renaming))
           (names (list* recog-name creator-name names)))
      (er-progn
       (chk-all-but-new-name recog-name ctx 'function wrld state)
       (chk-all-but-new-name creator-name ctx 'function wrld state)
       (chk-acceptable-defstobj-renaming name field-descriptors renaming
                                         ctx state nil)

; 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) non-memoizable ctx wrld
                                 state)
     (let* ((field (if (atom (car ftemps))
                       (car ftemps)
                     (car (car ftemps))))
            (type (if (consp (car ftemps))
                      (or (cadr (assoc-keyword :type
                                               (cdr (car ftemps))))
                          t)
                    t))
            (key2 (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 non-memoizable 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))))))))

(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))
          (cdr (assoc-eq :non-memoizable 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$
   (getpropc name 'stobj nil wrld)
   (let ((ev (get-event name wrld)))
     (and ev
          (assert$ (and (eq (car ev) 'defstobj)
                        (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 (getpropc name 'stobj nil 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.

  (cond
   ((not (symbolp name))
    (er soft ctx
        "The first argument of a DEFSTOBJ event must be a symbol.  Thus, ~x0 ~
          is ill-formed."
        (list* 'defstobj name args)))
   (t
    (mv-let
     (erp field-descriptors key-alist)
     (partition-rest-and-keyword-args args *defstobj-keywords*)
     (cond
      (erp
       (er soft ctx
           "The keyword arguments to the DEFSTOBJ event must appear after all ~
            field descriptors.  The allowed keyword arguments are ~&0, and ~
            these may not be duplicated, and must be followed by the ~
            corresponding value of the keyword argument.  Thus, ~x1 is ~
            ill-formed."
           *defstobj-keywords*
           (list* 'defstobj name args)))
      ((redundant-defstobjp name args wrld)
       (value 'redundant))
      (t
       (let ((renaming (cdr (assoc-eq :renaming key-alist)))
             (inline (cdr (assoc-eq :inline key-alist)))
             (congruent-to (cdr (assoc-eq :congruent-to key-alist)))
             (non-memoizable (cdr (assoc-eq :non-memoizable key-alist))))
         (cond
          ((not (booleanp inline))
           (er soft ctx
               "DEFSTOBJ requires the :INLINE keyword argument to have a ~
                Boolean value.  See :DOC defstobj."))
          ((not (booleanp non-memoizable))
           (er soft ctx
               "DEFSTOBJ requires the :NON-MEMOIZABLE 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
                (getpropc congruent-to 'absstobj-info nil wrld))
           (er soft ctx
               "The symbol ~x0 is the name of an abstract stobj in the ~
                current ACL2 world, so it is not legal for use as the ~
                :CONGRUENT-TO argument of DEFSTOBJ."
               congruent-to))
          ((and congruent-to
                (not (congruent-stobj-fields
                      field-descriptors
                      (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))
          ((and congruent-to
                (not (eq non-memoizable
                         (getpropc congruent-to 'non-memoizable nil wrld))))
           (er soft ctx
               "Congruent stobjs must agree on whether or not they are ~
                specified as :NON-MEMOIZABLE.  However, this fails for the ~
                proposed stobj, ~x0, which is specified as :CONGRUENT-TO the ~
                stobj ~x1, since ~x2 is specified with :NON-MEMOIZABLE T but ~
                ~x3 is not.  See :DOC defstobj."
               name
               congruent-to
               (if non-memoizable name congruent-to)
               (if non-memoizable congruent-to name)))
          (t
           (er-progn

; The defstobj name itself is not subject to renaming.  So we check it
; before we even bother to check the well-formedness of the renaming alist.

            (chk-all-but-new-name name ctx 'stobj wrld state)
            (cond ((or (eq name 'I)
                       (eq name 'V))
                   (er soft ctx
                       "DEFSTOBJ does not allow single-threaded objects with ~
                        the names ~x0 or ~x1 because those symbols are used ~
                        as formals, along with the new stobj name itself, in ~
                        ``primitive'' stobj functions that will be defined."
                       'i 'v))
                  (t (value nil)))
            (chk-legal-defstobj-name name state)
            (cond ((not (doublet-style-symbol-to-symbol-alistp renaming))
                   (er soft ctx
                       "The :RENAMING argument to DEFSTOBJ must be an alist ~
                        containing elements of the form (sym sym), where each ~
                        element of such a doublet is a symbol. Your argument, ~
                        ~x0, is thus illegal."
                       renaming))
                  (t (value nil)))
            (er-let*
                ((wrld1 (chk-just-new-name name nil 'stobj nil ctx wrld state))
                 (wrld2 (chk-just-new-name (the-live-var name)
                                           nil 'stobj-live-var nil ctx wrld1
                                           state)))
              (chk-acceptable-defstobj1 name field-descriptors field-descriptors
                                        renaming non-memoizable
                                        ctx wrld2 state nil nil))))))))))))

; Essay on Defstobj Definitions

; Consider the following defstobj:

;   (defstobj $st
;     (flag :type t :initially run)
;     (pc   :type (integer 0 255) :initially 128)
;     (mem  :type (array (integer 0 255) (256)) :initially 0)
;     :renaming ((pc pcn)))

; If you call (defstobj-template '$st '((flag ...) ...)) you will get
; back a ``template'' which is sort of a normalized version of the
; event with the renaming applied and all the optional slots filled
; appropriately.  (See the definition of defstobj-template for details.)
; Let template be that template.

; To see the logical definitions generated by this defstobj event, invoke
;   (defstobj-axiomatic-defs '$st template (w state))

; To see the raw lisp definitions generated, invoke
;   (defstobj-raw-defs '$st template nil (w state))

; The *1* functions for the functions are all generated by oneifying
; the axiomatic defs.

; To see the deconsts generated, invoke
;   (defstobj-defconsts
;     (strip-accessor-names (access defstobj-template template
;                                   :field-templates))
;     0)

; It is important the guard conjectures for these functions be
; provable!  They are assumed by the admission process!  To prove
; the guards for the defstobj above, it helped to insert the following
; lemma after the defun of memp but before the definition of memi.

;   (defthm memp-implies-true-listp
;     (implies (memp x)
;              (true-listp x)))

; Even without this lemma, the proof succeeded, though it took much
; longer and involved quite a few generalizations and inductions.

; If you change any of the functions, I recommend generating the axiomatic
; defs for a particular defstobj such as that above and proving the guards.

; Up through v2-7 we also believed that we ensured that the guards in the
; axiomatic defs are sufficient for the raw defs.  However, starting with v2-8,
; this became moot because of the following claim: the raw Lisp functions are
; only called on live stobjs (this change, and others involving :inline, were
; contributed by Rob Sumners).  We believe this claim because of the following
; argument.  Note that there is an exception for the recognizer, which can be
; applied to an ordinary object, but we do not consider this exception here.
;
;   a) The *1* function now has an additional requirement that not only does
;      guard checking pass, but also, all of the stobjs arguments passed in
;      must be the live stobjs in order to execute raw Common Lisp.
;   b) Due to the syntactic restrictions that ACL2 enforces, we know that the
;      direct correspondence between live stobjs and stobj arguments in the
;      raw Common Lisp functions will persist throughout evaluation.
;      -- This can be proven by induction over the sequence of function calls
;         in any evaluation.
;      -- The base case is covered by the binding of stobj parameters to
;         the global live stobj in the acl2-loop, or by the restrictions
;         placed upon with-local-stobj and stobj-let.
;      -- The induction step is proven by the signature requirements of
;         functions that access and/or update stobjs.

; A reasonable question is: Should the guard for resize-name be
; strengthened so as to disallow sizes of at least (1- (expt 2 28))?
; Probably there is no need for this.  Logically, there is no such
; restriction; it is OK for the implementation to insist on such a
; bound when actually executing.

; We introduce the idea of the "template" of a defstobj, which includes a
; normalized version of the field descriptors under the renaming.  See
; basis-a.lisp for defrec forms defstobj-field-template and defstobj-template.

(defun defstobj-field-fns-axiomatic-defs (top-recog var n field-templates wrld)

; Wrld is normally a logical world, but it can be nil when calling this
; function from raw Lisp.

; Warning: 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 field-templates)
    nil)
   (t (let* ((field-template (car field-templates))
             (type (access defstobj-field-template
                           field-template
                           :type))
             (arrayp (and (consp type) (eq (car type) 'array)))
             (init0 (access defstobj-field-template
                            field-template
                            :init))
             (creator (get-stobj-creator (if arrayp (cadr type) type)
                                         wrld))
             (init (if creator
                       `(non-exec (,creator))
                     (kwote init0)))
             (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 (access defstobj-field-template
                                    field-template
                                    :accessor-name))
             (updater-name (access defstobj-field-template
                                   field-template
                                   :updater-name))
             (length-name (access defstobj-field-template
                                  field-template
                                  :length-name))
             (resize-name (access defstobj-field-template
                                  field-template
                                  :resize-name))
             (resizable (access defstobj-field-template
                                field-template
                                :resizable)))
        (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 field-templates) 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 field-templates) wrld))))))))

(defun defstobj-axiomatic-init-fields (field-templates wrld)

; Keep this in sync with defstobj-raw-init-fields.

  (cond
   ((endp field-templates) nil)
   (t (let* ((field-template (car field-templates))
             (type (access defstobj-field-template
                           field-template
                           :type))
             (arrayp (and (consp type) (eq (car type) 'array)))
             (array-size (and arrayp (car (caddr type))))
             (init0 (access defstobj-field-template
                            field-template
                            :init))
             (creator (get-stobj-creator (if arrayp (cadr type) type)
                                         wrld))
             (init (if creator
                       `(non-exec (,creator))
                     (kwote init0))))
        (cond
         (arrayp
          (cons `(make-list ,array-size :initial-element ,init)
                (defstobj-axiomatic-init-fields (cdr field-templates) wrld)))
         (t ; whether the type is given or not is irrelevant
          (cons init
                (defstobj-axiomatic-init-fields
                  (cdr field-templates) 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 (access defstobj-template template :field-templates)))
    (append
     (defstobj-component-recognizer-axiomatic-defs name template
       field-templates wrld)
     (cons
      (defstobj-creator-fn
        (access defstobj-template template :creator)
        field-templates wrld)
      (defstobj-field-fns-axiomatic-defs
        (access defstobj-template template :recognizer)
        name 0 field-templates wrld)))))

(defun put-stobjs-in-and-outs1 (name field-templates wrld)

; See put-stobjs-in-and-outs for a table that explains what we're doing.

  (cond
   ((endp field-templates) wrld)
   (t (let* ((field-template (car field-templates))
             (type (access defstobj-field-template field-template
                           :type))
             (acc-fn (access defstobj-field-template field-template
                             :accessor-name))
             (upd-fn (access defstobj-field-template field-template
                             :updater-name))
             (length-fn (access defstobj-field-template field-template
                                :length-name))
             (resize-fn (access defstobj-field-template field-template
                                :resize-name)))
        (put-stobjs-in-and-outs1
         name
         (cdr field-templates)
         (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 (access defstobj-template template :recognizer))
        (creator-name (access defstobj-template template :creator))
        (field-templates (access defstobj-template template :field-templates)))
    (put-stobjs-in-and-outs1 name
                             field-templates
                             (putprop creator-name
                                      'STOBJS-OUT
                                      (list name)
                                      (putprop recog-name
                                               'STOBJS-IN
                                               (list name)
                                               wrld)))))

(defun defconst-name-alist (lst n)
  (if (endp lst)
      nil
    (cons (cons n (defconst-name (car lst)))
          (defconst-name-alist (cdr lst) (1+ n)))))

(defun accessor-array (name field-names)
  (let ((len (length field-names)))
    (compress1 name
               (cons `(:HEADER :DIMENSIONS (,len)
                               :MAXIMUM-LENGTH ,(+ 1 len)
                               :DEFAULT nil ; should be ignored
                               :NAME ,name
                               :ORDER :none)
                     (defconst-name-alist field-names 0)))))

(defun put-defstobj-invariant-risk (field-templates wrld)

; See put-invariant-risk.

  (cond ((endp field-templates) wrld)
        (t (let* ((field-template (car field-templates))
                  (type (access defstobj-field-template field-template :type)))
             (put-defstobj-invariant-risk
              (cdr field-templates)
              (cond ((eq type t)
                     wrld)
                    (t

; The following example from Jared Davis and Sol Swords shows why even arrays
; with elements of type t need to be considered for invariant-risk.

;   To start:

;       (defstobj foo
;         (foo-ch  :type character :initially #\a)
;         (foo-arr :type (array t (3))))

;   The idea is to cause an invalid write to foo-arr that will
;   overwrite foo-ch.  To do this, it is helpful to know the
;   relative addresses of foo-ch and foo-arr.  We can find this
;   out from raw Lisp, but once we know it, it seems pretty
;   reliable, so in the final version there's no need to enter
;   raw Lisp.

;       :q
;       (let ((ch-addr  (ccl::%address-of (aref *the-live-foo* 0)))
;             (arr-addr (ccl::%address-of (aref *the-live-foo* 1))))
;         (list :ch   ch-addr
;               :arr  arr-addr
;               :diff (- ch-addr arr-addr)))
;       (lp)

;   An example result on one invocation on our machine is:

;       (:CH 52914053289693 :ARR 52914053289501 :DIFF 192)

;   When we quit ACL2 and resubmit this, we typically get
;   different offsets for CH and ARR, but the :DIFF seems to be
;   consistently 192.  (In principle, it probably could
;   sometimes be different because it probably depends on how
;   the memory allocation happens to fall out, but in practice
;   it seems to be reliable).  If you want to reproduce this and
;   your machine gets a different result, you may need to adjust
;   the index that you write to to provoke the problem.

;   Since CCL's (array t ...) probably uses 8-byte elements, we
;   should write to address (/ 192 8) = 24.  To do that we will
;   need a program mode function that writes to foo-arri to
;   avoid ACL2's guards from preventing the out-of-bounds write.

;       (defun attack (n v foo)
;         (declare (xargs :mode :program :stobjs foo))
;         (update-foo-arri n v foo))

;   Now we can do something like this:

;       (attack 24 100 foo)

;   After the attack, (foo-ch foo) returns something that Emacs
;   prints as #\^Z, and (char-code (foo-ch foo)) reports 800,
;   which is of course not valid for an ACL2 character.

                     (let ((updater (access defstobj-field-template
                                            field-template
                                            :updater-name)))
                       (putprop updater 'invariant-risk updater wrld)))))))))

(defun defstobj-fn (name args state event-form)

; Warning: If this event ever generates proof obligations (other than those
; that are always skipped), remove it from the list of exceptions in
; install-event just below its "Comment on irrelevance of skip-proofs".

  (with-ctx-summarized
   (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-templates (access defstobj-template template
                                          :field-templates))
                 (field-names (strip-accessor-names field-templates))
                 (defconsts (defstobj-defconsts field-names 0))
                 (field-const-names (strip-cadrs defconsts))
                 (ax-def-lst (defstobj-axiomatic-defs name template wrld1))
                 (raw-def-lst (defstobj-raw-defs name template nil wrld1))
                 (recog-name (access defstobj-template template :recognizer))
                 (creator-name (access defstobj-template template :creator))
                 (names

; Warning: Each updater should immediately follow the corresponding accessor --
; and, this is guaranteed by the call of defstobj-axiomatic-defs, above) -- so
; that the 'stobj property laid down below 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))
                 (congruent-to (access defstobj-template template
                                       :congruent-to))
                 (non-memoizable (access defstobj-template template
                                         :non-memoizable)))
            (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.

                (let* ((wrld2 (w state))
                       (wrld3
                        (put-defstobj-invariant-risk
                         field-templates
                         (putprop
                          name 'congruent-stobj-rep
                          (and congruent-to
                               (congruent-stobj-rep congruent-to wrld2))
                          (putprop-unless
                           name 'non-memoizable non-memoizable nil
                           (putprop

; Here I declare that name is Common Lisp compliant.  Below I similarly declare
; the-live-var.  All elements of the namex list of an event must have the same
; symbol-class.

                            name 'symbol-class :common-lisp-compliant
                            (put-stobjs-in-and-outs
                             name template

; Rockwell Addition: It is convenient for the recognizer to be in a
; fixed position in this list, so I can find out its name.

                             (putprop
                              name 'stobj
                              (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.

#-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)
  (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)
        'state
        (list 'quote event-form)))

(defun concrete-stobj (st wrld)
  (let ((absstobj-info
         (getpropc st 'absstobj-info nil wrld)))
    (and absstobj-info
         (access absstobj-info
                 (getpropc st 'absstobj-info nil wrld)
                 :st$c))))

(defmacro defabsstobj-missing-events (&whole event-form
                                             name
                                             &key
                                             concrete recognizer creator
                                             corr-fn exports protect-default
                                             congruent-to)
  (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 (msg "( DEFABSSTOBJ-MISSING-EVENTS ~x0 ...)" name)) ; ctx
        'state
        (list 'quote event-form)))

(defun redundant-defabsstobjp (name event-form wrld)
  (and (getpropc name 'stobj nil wrld)
       (equal event-form (get-event name wrld))))

(defun absstobj-correspondence-concl-lst (stobjs-out i st$c corr-fn)
  (cond ((endp stobjs-out) nil)
        (t (cons (let ((qi (kwote i)))
                   (fcons-term* (if (eq (car stobjs-out) st$c)
                                    corr-fn
                                  'equal)
                                (fcons-term* 'mv-nth qi 'lhs)
                                (fcons-term* 'mv-nth qi 'rhs)))
                 (absstobj-correspondence-concl-lst
                  (cdr stobjs-out) (1+ i) st$c corr-fn)))))

(defun 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 (getpropc fn 'stobj-function nil wrld))
     :once)
    ((getpropc fn 'recursivep nil wrld)

; We can't predict how many updates fn will make to st.

     t)
    ((getpropc fn 'constrainedp nil wrld)

; Fn might be attachable, so we can't predict how many updates fn will make to
; st.

     t)
    (t (let ((body (getpropc fn 'unnormalized-body nil wrld)))
         (assert$ body
                  (stobj-updates-p st body wrld))))))

(defun stobj-updates-p (st term wrld)

; It is always sound for this function to return t.  If it returns :once, then
; st is updated at most once by the execution of term.  If it returns nil, then
; st is not updated by the execution of term.

; Consider for example:

;   (defstobj st fld)
;   (defun foo (a st)
;     (declare (xargs :stobjs st))
;     (let* ((b (cons a a))
;            (st (update-fld b st)))
;       (mv b st)))

; Then we have:

;   ACL2 !>(getpropc 'foo 'unnormalized-body)
;   ((LAMBDA (B ST)
;            ((LAMBDA (ST B) (CONS B (CONS ST 'NIL)))
;             (UPDATE-FLD B ST)
;             B))
;    (CONS A A)
;    ST)
;   ACL2 !>

; Notice that for the inner lambda application, the unique update is in an
; argument, and for the 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 nil 'function nil ctx wrld
                                        state))))
      (cond
       ((or congruent-to
            (member-eq (ld-skip-proofsp state)
                       '(include-book include-book-with-locals)))

; We allow the :correspondence, :preserved, and :guard-thm theorems to be
; local.

        (value (cons missing wrld)))
       (t (chk-defabsstobj-method-lemmas method st st$c st$ap corr-fn
                                         missing wrld state))))))

(defun 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
                                        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))
   ((getpropc st$c 'absstobj-info nil wrld)
    (er soft ctx
        "The symbol ~x0 is the name of an abstract stobj in the current ACL2 ~
         world, so it is not legal for use as the :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)
                   (getpropc congruent-to 'absstobj-info nil wrld))))

; Here, we only check that congruent-to is a candidate for a congruent abstract
; stobj.  The check is elsewhere that it is truly congruent to the proposed
; abstract stobj.  But at least we will know that congruent-to, if non-nil,
; does name some abstract stobj; see the binding of old-absstobj-info in
; defabsstobj-fn1.

    (er soft ctx
        "The :CONGRUENT-TO parameter of a DEFABSSTOBJ must either be nil or ~
         the name of an existing abstract stobj, but the value ~x0 is ~
         neither.  ~@1."
        congruent-to see-doc))
   (t
    (er-progn
     (chk-all-but-new-name name ctx 'stobj wrld state)
     (chk-legal-defstobj-name name state)
     (er-let* ((wrld1 (chk-just-new-name name nil 'stobj nil ctx wrld state))
               (wrld2 (chk-just-new-name (the-live-var name)
                                         nil 'stobj-live-var nil ctx wrld1
                                         state)))
       (chk-acceptable-defabsstobj1 name st$c st$ap corr-fn

; Keep the recognizer and creator first and second in our call to
; chk-acceptable-defabsstobj1.  See the comment about
; chk-acceptable-defabsstobj1 in defabsstobj-fn1, and also note that the first
; two methods must be for the recognizer and creator in defabsstobj-raw-defs,
; which is called in defabsstobj-fn1, where it consumes the methods we return
; here.

                                    (list* recognizer creator exports)
                                    (list* :RECOGNIZER :CREATOR nil)
                                    protect-default congruent-to see-doc ctx
                                    wrld2 state nil nil))))))

(defun defabsstobj-axiomatic-defs (st$c methods)
  (cond
   ((endp methods) nil)
   (t (cons (let ((method (car methods)))
              (mv-let (name formals guard-post logic exec stobjs)
                      (mv (access absstobj-method method :NAME)
                          (access absstobj-method method :FORMALS)
                          (access absstobj-method method :GUARD-POST)
                          (access absstobj-method method :LOGIC)
                          (access absstobj-method method :EXEC)
                          (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))

; We use mbe, rather than just its :logic component, because we want to track
; functions that might be called in raw Lisp, in particular for avoiding the
; violation of important invariants; see put-invariant-risk.

                              (mbe :logic (,logic ,@formals)
                                   :exec (,exec ,@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 put-defabsstobj-invariant-risk (st-name methods wrld)

; See put-invariant-risk.

  (cond ((endp methods) wrld)
        (t (let* ((method (car methods))
                  (guard (access absstobj-method method :GUARD-POST)))
             (put-defabsstobj-invariant-risk
              st-name
              (cdr methods)
              (cond ((or (equal guard *t*)
                         (not (member-eq st-name
                                         (access absstobj-method method
                                                 :STOBJS-OUT))))
                     wrld)
                    (t (putprop (access absstobj-method method :NAME)
                                'invariant-risk
                                (access absstobj-method method :NAME)
                                wrld))))))))

(defun defabsstobj-fn1 (st-name st$c recognizer creator corr-fn exports
                                protect-default congruent-to missing-only
                                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 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
                     (getpropc congruent-to 'absstobj-info nil 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.

                    (let* ((wrld2 (w state))
                           (wrld3
                            (put-defabsstobj-invariant-risk
                             st-name
                             methods
                             (putprop
                              st-name 'congruent-stobj-rep
                              (and congruent-to
                                   (congruent-stobj-rep congruent-to wrld2))
                              (putprop-unless
                               st-name
                               'non-memoizable
                               (getpropc st$c 'non-memoizable nil wrld2)
                               nil
                               (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
                               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 ctx state event-form)))

(defun create-state ()
  (declare (xargs :guard t))
  (coerce-object-to-state *default-state*))

(defmacro with-local-state (mv-let-form)
  `(with-local-stobj state ,mv-let-form))

; Essay on Nested Stobjs

; After Version_6.1 we introduced a new capability: allowing fields of stobjs
; to themselves be stobjs or arrays of stobjs.  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

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

(defun push-untouchable-fn (name fn-p state event-form)

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

  (with-ctx-summarized
   (if (output-in-infixp state)
       event-form
     (cond ((symbolp name)
            (msg "( PUSH-UNTOUCHABLE ~x0 ~x1)" name fn-p))
           (t "( PUSH-UNTOUCHABLE ...)")))
   (let ((wrld (w state))
         (event-form (or event-form
                         (list 'push-untouchable name fn-p)))
         (names (if (symbolp name) (list name) name))
         (untouchable-prop (cond (fn-p 'untouchable-fns)
                                 (t 'untouchable-vars))))
     (cond
      ((not (symbol-listp names))
       (er soft ctx
           "The argument to push-untouchable must be either a non-nil symbol ~
            or a non-empty true list of symbols and ~x0 is neither."
           name))
      ((subsetp-eq names (global-val untouchable-prop wrld))
       (stop-redundant-event ctx state))
      (t
       (let ((bad (if fn-p
                      (collect-never-untouchable-fns-entries
                       names
                       (global-val 'never-untouchable-fns wrld))
                      nil)))
         (cond
          ((null bad)
           (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))
          (t (er soft ctx
                 "You have tried to make ~&0 an untouchable function.  ~
                  However, ~#0~[this function is~/these functions are~] ~
                  sometimes introduced into proofs by one or more ~
                  metatheorems or clause processors having well-formedness ~
                  guarantees.   If you insist on making ~#0~[this name~/these ~
                  names~] untouchable you must redefine the relevant ~
                  metafunctions and clause processors so they do not create ~
                  terms involving ~#0~[it~/them~] and prove and cite ~
                  appropriate :WELL-FORMEDNESS-GUARANTEE theorems.  The ~
                  following data structure may help you find the relevant ~
                  events to change.  The data structure is an alist pairing ~
                  each function name above with information about all the ~
                  metatheorems or clause processors that may introduce that ~
                  name.  The information for each metatheorem or clause ~
                  processor is the name of the correctness theorem, the name ~
                  of the metafunction or clause processor verified by that ~
                  metatheorem, the name of the well-formedness guarantee for ~
                  that metafunction or clause processor, and analogous ~
                  information about any hypothesis metafunction involved.  ~
                  All of these events (and possibly their supporting ~
                  functions and lemmas) must be fixed so that the names you ~
                  now want to be untouchable are not produced.~%~X12"
                 (strip-cars bad)
                 bad
                 nil)))))))))

(defun remove-untouchable-fn (name fn-p state event-form)

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

  (with-ctx-summarized
   (if (output-in-infixp state)
       event-form
     (cond ((symbolp name)
            (msg "( REMOVE-UNTOUCHABLE ~x0 ~x1)" name fn-p))
           (t "( REMOVE-UNTOUCHABLE ...)")))
   (let ((wrld (w state))
         (event-form (or event-form
                         (list 'remove-untouchable name fn-p)))
         (names (if (symbolp name) (list name) name))
         (untouchable-prop (cond (fn-p 'untouchable-fns)
                                 (t 'untouchable-vars))))
     (cond
      ((not (symbol-listp names))
       (er soft ctx
           "The argument to remove-untouchable must be either a non-nil ~
            symbol or a non-empty true list of symbols and ~x0 is neither."
           name))
      ((not (intersectp-eq names (global-val untouchable-prop wrld)))
       (stop-redundant-event ctx state))
      (t
       (let ((old-untouchable-prop (global-val untouchable-prop wrld)))
         (install-event name
                        event-form
                        'remove-untouchable
                        0
                        nil
                        nil
                        nil
                        nil
                        (global-set
                         untouchable-prop
                         (set-difference-eq old-untouchable-prop names)
                         wrld)
                        state)))))))

(defun def-body-lemmas (def-bodies lemmas)
  (cond ((endp def-bodies)
         nil)
        (t (cons (find-runed-lemma (access def-body (car def-bodies)
                                           :rune)
                                   lemmas)
                 (def-body-lemmas (cdr def-bodies) lemmas)))))

(defmacro show-bodies (fn)
  (declare (xargs :guard (or (symbolp fn)
                             (and (true-listp fn)
                                  (eql (length fn) 2)
                                  (eq (car fn) 'quote)
                                  (symbolp (cadr fn))))))
  (let ((fn (if (symbolp fn) fn (cadr fn))))
    `(let* ((wrld (w state))
            (fn (deref-macro-name ',fn (macro-aliases wrld)))
            (lemmas (def-body-lemmas
                      (getpropc fn 'def-bodies nil wrld)
                      (getpropc fn 'lemmas nil wrld))))
       (cond (lemmas
              (pprogn (fms "Definitional bodies available for ~x0, current ~
                            one listed first:~|"
                           (list (cons #\0 fn))
                           (standard-co state) state nil)
                      (print-info-for-rules
                       (info-for-lemmas lemmas t (ens-maybe-brr state) wrld)
                       (standard-co state) state)))
             (t (er soft 'show-bodies
                    "There are no definitional bodies for ~x0."
                    fn))))))

(defun set-body-fn1 (rune def-bodies acc)
  (cond ((null def-bodies) ; error
         nil)
        ((equal rune (access def-body (car def-bodies) :rune))
         (cons (car def-bodies)
               (revappend acc (cdr def-bodies))))
        (t (set-body-fn1 rune
                         (cdr def-bodies)
                         (cons (car def-bodies) acc)))))

(defun set-body-fn (fn name-or-rune state event-form)

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

  (with-ctx-summarized
   (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
           (getpropc fn 'def-bodies nil wrld))
          (def-bodies
            (and fn
                 old-def-bodies
                 (cond ((equal rune
                               (access def-body (car old-def-bodies)
                                       :rune))
                        :redundant)
                       (t (set-body-fn1 rune old-def-bodies nil))))))
     (cond
      ((null def-bodies)
       (er soft ctx
           "No definitional body was found for function ~x0 with rune ~
            ~x1.  See :DOC set-body."
           fn rune))
      ((eq def-bodies :redundant)
       (stop-redundant-event ctx state))
      (t (install-event rune event-form 'set-body 0 nil nil nil ctx
                        (putprop fn 'def-bodies def-bodies wrld)
                        state))))))

; Section:  trace/untrace

#-acl2-loop-only
(progn

(defparameter *trace-evisc-tuple*
  nil)

(defparameter *trace-evisc-tuple-world*
  nil)

(defun trace-evisc-tuple ()
  (cond ((and *trace-evisc-tuple-world*
              (not (eq *trace-evisc-tuple-world* (w *the-live-state*))))
         (set-trace-evisc-tuple t *the-live-state*)
         *trace-evisc-tuple*)
        (t
         *trace-evisc-tuple*)))
)

(defun trace-multiplicity (name state)

; Returns nil for functions unknown to ACL2.

  (let ((stobjs-out

; Return-last cannot be traced, so it is harmless to get the stobjs-out here
; without checking if name is return-last.

         (getpropc name 'stobjs-out)))
    (and stobjs-out
         (length stobjs-out))))

(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 (getpropc fn 'formals t wrld)
             t))))

(defun trace$-er-msg (fn)
  (msg "Ignoring request to trace function ~x0, because"
       fn))

(defun decls-and-doc (forms)
  (cond ((endp forms)
         nil)
        ((or (stringp (car forms))
             (and (consp (car forms))
                  (eq (caar forms) 'declare)))
         (cons (car forms)
               (decls-and-doc (cdr forms))))
        (t nil)))

(defun trace$-when-gcond (gcond form)
  (if gcond
      `(when ,gcond ,form)
    form))

(defun 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)
  #+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 kwd)
  (and (consp x)
       (keywordp (car x))
       (or (and (member-eq (car x) '(:fmt :fmt!))
                (consp (cdr x))
                (null (cddr x)))
           (er hard 'trace$
               "Illegal ~x0 value.  A legal ~x0 value starting with a ~
                keyword must be of the form (:FMT x).  The ~x0 value ~x1 ~
                is therefore illegal."
               kwd x))
       (car x)))

(defun chk-trace-options (fn predefined trace-options formals ctx wrld state)
  (let ((notinline-tail (assoc-keyword :notinline trace-options))
        (multiplicity-tail (assoc-keyword :multiplicity trace-options)))
    (cond
     ((and notinline-tail
           (not (member-eq (cadr notinline-tail)
                           '(t nil :fncall))))

; We are tempted to use a hard error here so that we don't see the message
; about trace! printed by trace$-fn-general.  But then instead we see a message
; suggesting the use of trace, which is very odd here, since we are trying to
; trace!  So we'll just live with seeing a not very helpful message about
; trace!.

      (er soft ctx
          "The only legal values for trace option :NOTINLINE are ~&0.  The ~
           value ~x1 is thus illegal."
          '(t nil :fncall)
          (cadr notinline-tail)))
     ((and multiplicity-tail
           (not (natp (cadr multiplicity-tail))))
      (er soft ctx
          "The value of trace option :MULTIPLICITY must be a non-negative ~
           integer value.  The value ~x0 is thus illegal."
          (cadr multiplicity-tail)))
     ((and predefined
           (or (eq fn 'return-last)
               (and notinline-tail
                    (not (eq (cadr notinline-tail) :fncall))
                    (or (member-eq fn (f-get-global 'program-fns-with-raw-code
                                                    state))
                        (member-eq fn (f-get-global 'logic-fns-with-raw-code
                                                    state))
                        (not (ttag wrld))))))
      (cond
       ((eq fn 'return-last)
        (er soft ctx
            "Due to its special nature, tracing of ~x0 is not allowed."
            fn))
       ((or (member-eq fn (f-get-global 'program-fns-with-raw-code
                                        state))
            (member-eq fn (f-get-global 'logic-fns-with-raw-code
                                        state)))

; We could probably just arrange not to trace the *1* function in this case.
; But for now we'll cause an error.

        (er soft ctx
            "The ACL2 built-in function ~x0 has special code that will not be ~
             captured properly when creating code for its traced executable ~
             counterpart.  It is therefore illegal to specify a value for ~
             :NOTINLINE other than :FNCALL unless there is an active trust ~
             tag.  There may be an easy fix, so contact the ACL2 implementors ~
             if this error presents a hardship."
            fn))
       (t
        (er soft ctx
            "The function ~x0 is built into ACL2.  It is therefore illegal to ~
             specify a value for :NOTINLINE other than :FNCALL unless there ~
             is an active trust tag."
            fn))))
     ((ttag wrld)
      (value nil))
     (t
      (let* ((cond-tail (assoc-keyword :cond  trace-options))
             (entry-tail (assoc-keyword :entry trace-options))
             (exit-tail (assoc-keyword :exit trace-options))
             (evisc-tuple-tail (assoc-keyword :evisc-tuple trace-options)))
        (er-progn
         (if cond-tail
             (chk-trace-options-aux
              (cadr cond-tail) :cond formals ctx wrld state)
           (value nil))
         (if entry-tail
             (chk-trace-options-aux
              (if (trace$-value-msgp (cadr entry-tail) :entry)
                  (cadr (cadr entry-tail))
                (cadr entry-tail))
              :entry formals ctx wrld state)
           (value nil))
         (if exit-tail
             (chk-trace-options-aux
              (if (trace$-value-msgp (cadr exit-tail) :exit)
                  (cadr (cadr exit-tail))
                (cadr exit-tail))
              :exit formals ctx wrld state)
           (value nil))
         (if (and evisc-tuple-tail
                  (not (member-eq (cadr evisc-tuple-tail)
                                  '(:print :no-print))))
             (chk-trace-options-aux
              (cadr evisc-tuple-tail) :evisc-tuple formals ctx wrld state)
           (value nil))))))))

(defun memoize-off-trace-error (fn ctx)
  (er hard ctx
      "Memoized function ~x0 is to be traced or untraced, but its ~
       symbol-function differs from the :MEMOIZED-FN field of its memoization ~
       hash-table entry.  Perhaps the trace or untrace request occurred in ~
       the context of ~x1; at any rate, it is illegal."
      fn ctx))

(defun untrace$-fn1 (fn state)
  #-acl2-loop-only
  (let* ((old-fn (get fn 'acl2-trace-saved-fn))
         (*1*fn (*1*-symbol? fn))
         (old-*1*fn (get *1*fn 'acl2-trace-saved-fn))
         #+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))
         (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))
         (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.

      (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 (getpropc fn 'stobj-function nil wrld))
         (form (cltl-def-from-name1 fn stobj-function t wrld)))
    (oneify-cltl-code
     (cond ((or (getpropc fn 'constrainedp nil wrld)
                (getpropc fn 'non-executablep nil wrld))
            nil)
           ((eq (symbol-class fn wrld) :program)
            :program) ; see oneify-cltl-code
           (t :logic))
     (cdr form)
     stobj-function
     wrld
     trace-rec-for-none)))

(defun trace$-fn-general (trace-spec ctx state)
  (let* ((fn (car trace-spec))
         (trace-options (cdr trace-spec))
         (native (cadr (assoc-keyword :native trace-options)))
         (wrld (w state))
         (stobj-function
          (and (not (assoc-keyword :def trace-options)) ; optimization
               (getpropc fn 'stobj-function nil wrld)))
         #-acl2-loop-only (*inside-trace$* t)
         (def (or (cadr (assoc-keyword :def trace-options))
                  (let ((defun+def
                          (cltl-def-from-name1 fn stobj-function nil wrld)))
                    (cond (defun+def (cdr defun+def))
                          ((and stobj-function
                                (cltl-def-from-name1 fn stobj-function t wrld))
                           :macro)
                          (t nil)))
                  (and (getpropc fn 'constrainedp nil wrld)
                       (let ((formals (getpropc fn 'formals t wrld)))
                         (assert$ (not (eq formals t))
                                  (list fn
                                        formals
                                        (null-body-er fn formals t)))))))
         (formals-tail (assoc-keyword :formals trace-options))
         (formals-default (and (not formals-tail)
                               (atom def)
                               (not native) ; else formals doesn't much matter
                               (getpropc fn 'formals t wrld)))
         (formals (cond (formals-tail (cadr formals-tail))
                        ((consp def) (cadr def))
                        (t formals-default)))
         (evisc-tuple (cadr (assoc-keyword :evisc-tuple trace-options)))
         (compile (cadr (assoc-keyword :compile trace-options)))
         (predefined ; (acl2-system-namep fn wrld)
          (getpropc fn 'predefined nil wrld)))
    (cond
     ((eq def :macro)
      (assert$
       stobj-function
       (cond
        ((getpropc stobj-function 'absstobj-info nil wrld)
         (er very-soft ctx
             "~x0 cannot be traced, because it is a macro in raw Lisp, ~
              introduced with the defabsstobj event for abstract stobj ~x1."
             fn
             stobj-function))
        (t
         (er very-soft ctx
             "~x0 cannot be traced, because it is a macro in raw Lisp: its ~
              introducing defstobj event (for stobj ~x1) was supplied with ~
              :INLINE T."
             fn
             stobj-function)))))
     ((eq formals-default t)
      (cond ((getpropc fn 'macro-body nil wrld)
             (er very-soft ctx
                 "~x0 is an ACL2 macro, hence cannot be traced in ACL2.~@1"
                 fn
                 (let ((sym (deref-macro-name fn (macro-aliases wrld))))
                   (cond ((eq sym fn) "")
                         (t (msg "  Perhaps you meant instead to trace the ~
                                  corresponding function, ~x0."
                                 sym))))))
            (t
             (er very-soft ctx
                 "~@0 this symbol does not have an ACL2 function definition.  ~
                  Consider using option :native, :def, or :formals.  See :DOC ~
                  trace$."
                 (trace$-er-msg fn)))))
     ((and def
           (not (equal (cadr def) formals)))
      (er very-soft ctx
          "~@0 the formals list, ~x1, does not match the definition's formals ~
           ~x2."
          (trace$-er-msg fn)
          formals
          (cadr def)))
     ((not (symbol-listp formals))
      (er very-soft ctx
          "~@0 the provided formals is not a true list of symbols."
          (trace$-er-msg fn)))
     ((and (keywordp evisc-tuple)
           (not (member-eq evisc-tuple '(:print :no-print))))
      (er very-soft ctx
          "~@0 the only legal keyword values for option :evisc-tuple are ~
           :print and :no-print."
          (trace$-er-msg fn)))
     ((member-eq fn '(wormhole-eval))
      (er very-soft ctx
          "~@0 it is illegal (for ACL2 implementation reasons) to trace ~x1."
          (trace$-er-msg fn)
          fn))
     ((and (not native)
           (equal (symbol-package-name fn) *main-lisp-package-name*))
      (er very-soft ctx
          "~@0 the ACL2 trace$ utility must be used with option :native for ~
           function symbols in the main Lisp package, ~x1.  See :DOC trace$."
          (trace$-er-msg fn)
          *main-lisp-package-name*))
     ((and compile native)
      (er very-soft ctx
          "~@0 we do not support compilation in trace specs (via keyword ~
           :compile) when :native is present, as in trace spec ~x1.  Consider ~
           removing :compile and performing compilation separately."
          (trace$-er-msg fn)
          trace-spec))
     (t
      (mv-let
       (erp val state)
       (chk-trace-options fn predefined trace-options formals ctx wrld state)
       (declare (ignore val))
       (if erp
           (if (or (ttag wrld)
                   (eq fn 'return-last))
               (value nil)
             (er very-soft ctx
                 "It is possible that you can use TRACE! to avoid the above ~
                  error (but consider that only with great care!).  See :DOC ~
                  trace!."))
         (let* ((state ; this handles *1* function if appropriate
                 (maybe-untrace$-fn fn state))
                (new-trace-specs
                 (cons trace-spec (f-get-global 'trace-specs state))))
           (cond
            ((and (not native) (null def))
             (er very-soft ctx
                 "ACL2 found no definition for ~x0.  Consider supplying the ~
                  :def trace option.  See :DOC trace$."
                 fn))
            (t
             (pprogn

; We update the value of 'trace-specs before modifying symbol-functions, since
; if we reverse the order then it is possible that we would interrupt between
; compilation of the raw Lisp and *1* function, after which (untrace$) would
; not untrace the raw Lisp function.  Note that untrace$ is a silent no-op if
; 'trace-specs has entries that are not truly traced -- see untrace$-fn1 -- so
; better that 'trace-specs have a value that is too large than too small.

              (f-put-global 'trace-specs new-trace-specs state)
              (cond
               (native
                #-acl2-loop-only
                (let* ((trace-options-1
                        (remove-keyword :multiplicity
                                        (remove-keyword :native
                                                        trace-options)))
                       (new-trace-options

; ACL2 has redefined the underlying Lisp trace for GCL, Allegro CL, and CCL so
; that they recognize the :exit keyword, and we take advantage of that here if
; (unlikely though that may be) #-acl2-mv-as-values is also true.  When
; #+acl2-mv-as-values holds, there is no need to specify :exit here.

                        #+(and (not acl2-mv-as-values)
                               (or gcl allegro ccl))
                        (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)))
                        #-(and (not acl2-mv-as-values)
                               (or gcl allegro ccl))
                        (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)
  (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-pre-eval-print nil
                    :ld-post-eval-print nil
                    :ld-error-action :error))
               (value :invisible))))

(defmacro trace! (&rest fns)
  (let ((form
         `(with-ubt!
           (with-output
            :off :all
            (with-output
             :on (error warning warning!)
             (make-event
              (progn (defttag :trace!)
                     (progn! (er-let* ((specs (trace$ ,@fns)))
                                      (value (list 'value-triple
                                                   (kwote specs))))))))))))
    #-acl2-loop-only

; We use ld so that this can work in raw Lisp.  We allow a different
; macroexpansion in raw Lisp because we know that no function will ever call
; this macro, since with-output is prohibited inside code.  With this raw Lisp
; code, one can call trace! in raw Lisp, which is handy for example when
; calling break-on-error.  Of course, no trust tag note will be printed in raw
; Lisp -- but all bets are off anyhow in raw Lisp!

    `(ld '(,form))
    #+acl2-loop-only
    form))

(defmacro untrace$ (&rest fns)
  `(untrace$-fn ',fns state))

(defun open-trace-file-fn (filename state)

; Logically, this function opens a channel to the given file.  But there is no
; logical accounting for subsequent writes to that channel on behalf of
; tracing.  We view those subsequent writes as being to the file, but not the
; channel, in analogy to how cw prints to the screen but does not modify the
; contents of *standard-co*.

  (mv-let (chan state)
          (open-output-channel filename :character state)
          (cond
           (chan #-acl2-loop-only
                 (setq *trace-output*
                       (get-output-stream-from-channel chan))
                 (pprogn
                  (if (equal (f-get-global 'trace-co state) *standard-co*)
                      state
                    (close-output-channel (f-get-global 'trace-co state)
                                          state))
                  (f-put-global 'trace-co chan state)))
           (t (prog2$
               (er hard 'open-trace-file
                   "Unable to open file ~s0 for trace output."
                   filename)
               state)))))

(defmacro open-trace-file (filename)
  (declare (xargs :guard (stringp filename)))
  `(pprogn (close-trace-file-fn t state)
           (open-trace-file-fn ,filename state)))

(defun close-trace-file-fn (quiet-p state)
  #-acl2-loop-only
  (setq *trace-output* (get-output-stream-from-channel *standard-co*))
  (if (equal (f-get-global 'trace-co state) *standard-co*)
      (if quiet-p
          state
        (prog2$
         (er hard 'close-trace-file
             "No change: trace is already written to standard output.~%")
         state))
    (pprogn (close-output-channel (f-get-global 'trace-co state) state)
            (f-put-global 'trace-co *standard-co* state))))

(defmacro close-trace-file ()
  '(close-trace-file-fn nil state))

(defmacro break-on-error (&optional (on 't))

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

  (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)
  (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 ((ffn-symb-p 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 state
                                        :force-info 'weak) ; conservative
                            nil ; gstack
                            ttree
                            nil ; bkptr
                            )
          (declare (ignore failure-reason))
          (mv wonp unify-subst ttree)))
        (t (mv-let
            (forcep bind-flg)
            (binding-hyp-p hyp unify-subst wrld)
            (let ((hyp (if forcep (fargn hyp 1) hyp)))
              (cond
               (bind-flg
                (mv t
                    (cons (cons (fargn hyp 1)
                                (sublis-var unify-subst (fargn hyp 2)))
                          unify-subst)
                    ttree))
               (t
                (mv-let
                 (lookup-hyp-ans unify-subst ttree)
                 (lookup-hyp hyp type-alist wrld unify-subst ttree)
                 (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
              "~@x~|~
               ~ ~ ~#c~[New term~/Conclusion~]: ~Y3t~|~
               ~ ~ Hypotheses: ~#b~[<none>~/~Y4t~]~|~
               ~#c~[~ ~ Equiv: ~ye~|~/~]~
               ~#s~[~/~ ~ Substitution: ~Yat~|~]~
               ~#5~[~/~
                    ~ ~ ~@f variable: ~&6~/~
                    ~ ~ ~@f variables: ~&6~sn~]~
               ~#7~[~/  WARNING:  One of the hypotheses is (equivalent to) NIL, ~
               and hence will apparently be impossible to relieve.~]~|"))
         (pprogn
          (fms fmt-string
               (list (cons #\x "")
                     (cons #\c (if (eq caller 'show-rewrites) 0 1))
                     (cons #\3 (untrans0 subst-rhs term-id-iff
                                         abbreviations))
                     (cons #\s (if pl-p 1 0))
                     (cons #\a (untranslate-subst-abb unify-subst
                                                      abbreviations
                                                      state))
                     (cons #\b (if subst-hyps 1 0))
                     (cons #\e equiv)
                     (cons #\4 (untrans0-lst subst-hyps t abbreviations))
                     (cons #\f (if pl-p "Free" "Remaining free"))
                     (cons #\5 (zero-one-or-more (length free)))
                     (cons #\6 free)
                     (cons #\n "")
                     (cons #\7 (if (member-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 #\x
                                   (let ((extra
                                          (untranslate-subst-abb
                                           (alist-difference-eq
                                            unify-subst-2
                                            unify-subst)
                                           abbreviations
                                           state)))
                                     (cond
                                      (extra ; always true?
                                       (msg
                                        "~ ~ Additional bindings: ~X0t"
                                        extra))
                                      (t ""))))
                             (cons #\c (if (eq caller 'show-rewrites) 0 1))
                             (cons #\3 (untrans0
                                        (sublis-var unify-subst-2 rhs)
                                        term-id-iff abbreviations))
                             (cons #\s (if pl-p 1 0))
                             (cons #\a (untranslate-subst-abb unify-subst-2
                                                              abbreviations
                                                              state))
                             (cons #\b (if subst-hyps-2 1 0))
                             (cons #\e equiv)
                             (cons #\4 (untrans0-lst subst-hyps-2 t
                                                     abbreviations))
                             (cons #\f (if pl-p "Free" "Remaining free"))
                             (cons #\5 (if (eql (length free-2) 1)
                                           1
                                         2))
                             (cons #\6 free-2)
                             (cons #\n (if (null free-2)
                                           "[none]"
                                         ""))
                             (cons #\7 (if (member-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))
            (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)))
           (cond
            (pl-p
             (show-rewrite-linear
              caller index col rune
              (if (eq caller 'show-rewrites)
                  (access rewrite-rule lemma :nume)
                (access linear-lemma lemma :nume))
              nil ; show-more
              subst-hyps
              nil ; subst-hyps-2, irrelevant
              unify-subst
              nil ; unify-subst-2,  irrelevant
              free
              nil ; free-2, irrelevant
              result abbreviations term-id-iff ens enabled-only-flg
              (and (eq caller 'show-rewrites)
                   (access sar sar :equiv))
              t ; pl-p
              state))
            (t
             (mv-let
              (show-more subst-hyps-2 unify-subst-2)
              (cond ((and free subst-hyps)

; Then we try to find at least a partial extension of unify-subst that
; eliminates some hypotheses.

                     (mv-let (subst-hyps-2 unify-subst-2 ttree)
                             (unrelieved-hyps rune hyps alist type-alist t
                                              w state ens nil)
                             (declare (ignore ttree))
                             (cond ((equal unify-subst-2 unify-subst)
                                    (assert$
                                     (equal subst-hyps-2 subst-hyps)
                                     (mv nil subst-hyps unify-subst)))
                                   (t
                                    (mv t subst-hyps-2 unify-subst-2)))))
                    (t (mv nil subst-hyps unify-subst)))
              (show-rewrite-linear
               caller index col rune
               (if (eq caller 'show-rewrites)
                   (access rewrite-rule lemma :nume)
                 (access linear-lemma lemma :nume))
               show-more subst-hyps subst-hyps-2 unify-subst unify-subst-2
               free
               (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))
               nil ; pl-p
               state))))))))
     (show-rewrites-linears
      caller (cdr app-rules) col abbreviations term-id-iff ens type-alist
      enabled-only-flg pl-p w state)))))

(defun expand-assumptions-1 (term)
  (case-match term
    (('if a b ''nil)
     (append (expand-assumptions-1 a) (expand-assumptions-1 b)))
    ((equality-p a b)
     (if (or (and (eq equality-p 'eq)
                  (or (and (consp a) (eq (car a) 'quote) (symbolp (cadr a)))
                      (and (consp b) (eq (car b) 'quote) (symbolp (cadr b)))))
             (and (eq equality-p 'eql)
                  (or (and (consp a) (eq (car a) 'quote) (eqlablep (cadr a)))
                      (and (consp b) (eq (car b) 'quote) (eqlablep (cadr b))))))
         (list term (mcons-term* 'equal a b))
       (list term)))
    (& (list term))))

(defun expand-assumptions (x)

; If x is (and a b) then we get (list a b), etc.

  (declare (xargs :guard (true-listp x)))
  (if x
      (append (expand-assumptions-1 (car x))
              (expand-assumptions (cdr x)))
    nil))

(defun hyps-type-alist (assumptions ens wrld state)

; Note that the force-flg arg to type-alist-clause is nil here, so we shouldn't
; wind up with any assumptions in the returned tag-tree. Also note that we
; return (mv contradictionp type-alist fc-pair-lst), where actually fc-pair-lst
; is a ttree if contradictionp holds; normally we ignore fc-pair-lst otherwise.

  (forward-chain-top 'show-rewrites
                     (dumb-negate-lit-lst (expand-assumptions assumptions))
                     nil
                     (ok-to-force-ens ens)
                     nil ; do-not-reconsiderp
                     wrld ens (match-free-override wrld) state))

(defun show-rewrites-linears-fn (caller rule-id enabled-only-flg ens
                                        current-term abbreviations term-id-iff
                                        all-hyps geneqv pl-p state)

; Pl-p is true when we are calling this function on behalf of :pl, and is false
; when we are calling it on behalf of the proof-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
                     (getpropc (ffn-symb current-term) 'lemmas nil w)
                     1 (or name rune) index w))
                   (t
                    (applicable-linear-rules1
                     current-term
                     (getpropc (ffn-symb current-term) 'linear-lemmas nil w)
                     1 (or name rune) index)))))
             (cond
              ((null app-rules)
               (cond (pl-p state)
                     ((and index (> index 1))
                      (fms "~|*** There are fewer than ~x0 applicable ~s1 ~
                            rules. ***~%"
                           (list (cons #\0 index)
                                 (cons #\1 (if (eq caller 'show-rewrites)
                                               "rewrite"
                                             "linear")))
                           (standard-co state) state
                           nil))
                     (t (fms "~|*** There are no applicable ~s0 rules. ***~%"
                             (list (cons #\0 (if (eq caller 'show-rewrites)
                                                 "rewrite"
                                               "linear")))
                             (standard-co state) state nil))))
              (t
               (show-rewrites-linears
                caller
                app-rules
                (floor (length app-rules) 10)
                abbreviations term-id-iff
                ens hyps-type-alist
                enabled-only-flg pl-p w state)))))))))))

(defun show-meta-lemmas1 (lemmas rule-id term wrld ens state)
  (cond
   ((endp lemmas) state)
   (t
    (pprogn
     (let* ((lemma (car lemmas))
            (rune (and (eq (access rewrite-rule lemma :subclass)
                           'meta)
                       (access rewrite-rule lemma :rune))))
       (cond ((and rune ; hence lemma is a meta lemma
                   (or (null rule-id)
                       (if (symbolp rule-id)
                           (eq rule-id (base-symbol rune))
                         (equal rule-id rune))))
              (let* ((fn (access rewrite-rule lemma :lhs))
                     (extendedp (access rewrite-rule lemma :rhs))
                     (args (meta-fn-args term extendedp ens state)))
                (mv-let
                 (erp new-term latches)
                 (ev-fncall-meta fn args state)
                 (declare (ignore latches))
                 (cond ((or erp
                            (equal new-term term)
                            (not (termp new-term wrld)))
                        state)
                       (t
                        (let ((hyp-fn (access rewrite-rule lemma :hyps)))
                          (mv-let
                           (erp hyp latches)
                           (if hyp-fn
                               (ev-fncall-meta
                                hyp-fn
                                (meta-fn-args term extendedp ens state)
                                state)
                             (mv nil *t* nil))
                           (declare (ignore latches))
                           (cond
                            ((or erp (not (termp hyp wrld)))
                             state)
                            (t
                             (fms
                              "~Y01~|~
                               ~ ~ New term: ~Y2t~|~
                               ~ ~ Hypothesis: ~Y3t~|~
                               ~ ~ Equiv: ~y4~|"
                              (list (cons #\0 rune)
                                    (cons #\1 nil)
                                    (cons #\2 new-term)
                                    (cons #\3 (untranslate hyp nil wrld))
                                    (cons #\4 (access rewrite-rule lemma
                                                      :equiv))
                                    (cons #\t
                                          (term-evisc-tuple nil state)))
                              (standard-co state) state nil))))))))))
             (t state)))
     (show-meta-lemmas1 (cdr lemmas) rule-id term wrld ens state)))))

(defun show-meta-lemmas (term rule-id ens state)
  (cond ((and (nvariablep term)
              (not (fquotep term))
              (not (flambdap (ffn-symb term))))
         (let ((wrld (w state)))
           (show-meta-lemmas1 (getpropc (ffn-symb term) 'lemmas nil wrld)
                              rule-id term wrld ens state)))
        (t state)))

(defun decoded-type-set-from-tp-rule (tp unify-subst wrld ens)
  (mv-let
   (ts type-alist ttree)
   (type-set-with-rule1 unify-subst
                        (access type-prescription tp :vars)
                        (ok-to-force-ens ens)
                        nil ; dwp, as in known-whether-nil (see relieve-hyp)
                        nil ; type-alist
                        nil ; ancestors
                        ens
                        wrld
                        (access type-prescription tp :basic-ts)
                        nil ; ttree
                        nil ; pot-lst
                        nil ; pt
                        nil ; backchain-limit
                        )
   (declare (ignore type-alist ttree))
   (decode-type-set ts)))

(defun show-type-prescription-rule (rule unify-subst type-alist abbreviations
                                         wrld ens state)
  (let ((rune (access type-prescription rule :rune))
        (nume (access type-prescription rule :nume))
        (hyps (access type-prescription rule :hyps)))
    (pprogn
     (fms "~x1~#2~[~/ (disabled)~]"
          (list (cons #\1 rune)
                (cons #\2 (if (enabled-numep nume ens) 0 1)))
          (standard-co state) state nil)
     (let ((fmt-string
            "~ ~ Type: ~Y01~|~
             ~ ~ Hypotheses: ~#b~[<none>~/~Y4t~]~|~
             ~ ~ Substitution: ~Yat~|~
             ~#5~[~/~
                  ~ ~ Remaining free variable: ~&6~/~
                  ~ ~ Remaining free variables: ~&6~sn~]~
             ~#7~[~/  WARNING:  One of the hypotheses is (equivalent to) NIL, ~
                  and hence will apparently be impossible to relieve.~]~|"))
       (mv-let
        (subst-hyps unify-subst ttree)
        (unrelieved-hyps rune hyps unify-subst type-alist nil wrld state ens nil)
        (declare (ignore ttree))
        (let ((free (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
                 (getpropc (ffn-symb term) 'type-prescriptions nil wrld)
                 term rule-id hyps-type-alist abbreviations wrld ens
                 state))))))
        (t

; Presumably we are inside the proof-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-maybe-brr 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 ens 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-maybe-brr state))
           (name (deref-macro-name name (macro-aliases wrld))))
      (cond
       ((function-symbolp name wrld)
        (print-info-for-rules
         (append
          (info-for-lemmas
           (getpropc name 'lemmas nil wrld)
           t ens wrld)
          (info-for-linear-lemmas
           (getpropc name 'linear-lemmas nil wrld)
           t ens wrld)
          (info-for-type-prescriptions
           (getpropc name 'type-prescriptions nil wrld)
           t ens wrld)
          (info-for-forward-chaining-rules
           (getpropc name 'forward-chaining-rules nil wrld)
           t ens wrld)
          (let ((elim-rule (getpropc name 'eliminate-destructors-rule nil wrld)))
            (and elim-rule
                 (info-for-eliminate-destructors-rule
                  elim-rule t ens wrld)))
          (info-for-induction-rules
           (getpropc name 'induction-rules nil wrld)
           t ens wrld))
         (standard-co state) state))
       (t (er soft 'pl
              "If the argument to PL is a symbol, then it must be a function ~
               symbol in the current world 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)
  (list 'pl-fn name 'state))

(defmacro pl2 (form rule-id)
  (list 'pl2-fn form rule-id ''pl2 'state))

; Essay on Include-book-dir-alist

; ACL2 supports two alists that associate keywords with absolute directory
; pathnames, to be used as values of the :dir argument of include-book and ld:
; the include-book-dir!-table, and the :include-book-dir-alist field of the
; acl2-defaults-table.  The macros add-include-book-dir and
; add-include-book-dir! provide ways to extend these alists to allow additional
; legal values for :dir.  Up through ACL2 Version_3.6.1, when
; add-include-book-dir was executed in raw Lisp it would be ignored, because it
; macroexpanded to a table event.  But consider a file loaded in raw Lisp, say
; when we are in raw-mode and are executing an include-book command with a :dir
; argument.  If that :dir value were defined by an add-include-book-dir event
; also evaluated in raw Lisp, and hence ignored, then that :dir value would not
; really be defined after all and the include-book would fail.

; The above problem with raw-mode could be explained away by saying that
; raw-mode is a hack, and you get what you get.  But Version_4.0 introduced the
; loading of compiled files before corresponding event processing, which causes
; routine evaluation of add-include-book-dir, add-include-book-dir!, and
; include-book in raw Lisp.

; Therefore we maintain for raw Lisp variants of these two alists: state
; globals 'raw-include-book-dir-alist and 'raw-include-book-dir!-alist.  The
; values of these variables are initially :ignore, meaning that we are to use
; the two tables, not the state globals.  But when the values are not :ignore,
; then they are alists to use in place of the corresponding table values.  We
; guarantee that every embedded event form that defines handling of :dir values
; for include-book does so in a manner that works when loading compiled files,
; and we weakly extend this guarantee to raw-mode as well (weakly, since we
; cannot perfectly control raw-mode; but a trust tag is necessary to enter
; raw-mode so our guarantee need not be ironclad).  The above :ignore value
; must then be set to a legitimate include-book-alist when inside include-book
; or (ideally) in raw-mode, and should remain :ignore when not in those
; contexts.  When the value of 'raw-include-book-dir-alist is not :ignore, then
; execution of add-include-book-dir will extend the value of
; 'raw-include-book-dir-alist instead of modifying the acl2-defaults-table.
; Whenever we execute include-book in raw Lisp, we use this value instead of
; the one in the acl2-defaults-table, by binding it to nil upon entry.  Thus,
; any add-include-book-dir will be local to the book, which respects the
; semantics of include-book.  We bind it to nil because that is also how
; include-book works: the acl2-defaults-table initially has an empty
; :include-book-dir-alist field (see process-embedded-events).  Of course,
; add-include-book-dir! corresponds to the include-book-dir!-table, not to the
; acl2-defaults-table, and its effect is not local to a book.  Thus, we handle
; 'raw-include-book-dir!-alist a bit differently from how we handle
; 'raw-include-book-dir-alist, though similarly: we bind it to nil in
; include-book-raw-top, at the top level of the entry into raw Lisp (for early
; load of compiled files) from include-book, bindings state global
; 'raw-include-book-dir!-alist to the current value of the
; include-book-dir!-table.

; In order to be able to rely on the above scheme, we disallow any direct table
; update of the include-book-dir!-table or of the :include-book-dir-alist field
; of the acl2-defaults-table.  We use the state global
; 'modifying-include-book-dir-alist for this purpose, which is globally nil but
; is bound to t by add-include-book-dir and related macros.  We insist that it
; be non-nil in chk-table-guard.  We considered making such a check instead in
; chk-embedded-event-form, but that would have been more awkward, and more
; importantly, it would have allowed such direct updates when developing a book
; interactively but not when certifying the book, which could provide a rude
; surprise to the user at certification time.

; End of Essay on Include-book-dir-alist

(defun acl2-defaults-table-local-ctx-p (state)
  (let ((wrld (w state)))
    (or (global-val 'include-book-path wrld)
        (f-get-global 'certify-book-info state)
        (in-encapsulatep (global-val 'embedded-event-lst wrld)
                         nil))))

(defun change-include-book-dir (keyword dir0 caller state)

; Caller is add-include-book-dir, add-include-book-dir!,
; delete-include-book-dir!, or delete-include-book-dir.  Dir is nil if and only
; caller is one of the latter two.

; See the Essay on Include-book-dir-alist.

  (declare (xargs :guard (state-p state)
                  :mode :program))
  (let* ((ctx (if dir0
                 (cons caller keyword)
               (msg "~x0" (list caller keyword))))
         (bang-p (member-eq caller '(add-include-book-dir!
                                     delete-include-book-dir!)))
         (dir (and dir0
                   (sysfile-to-filename dir0 state))))
    (cond ((not (if dir
                    (member-eq caller '(add-include-book-dir
                                        add-include-book-dir!))
                  (member-eq caller '(delete-include-book-dir
                                      delete-include-book-dir!))))

; We do this check at runtime, rather than in the guard, so that, for the sake
; of efficient execution, we can include it in the list of functions given to
; oneify-cltl-code whose *1* function is defined simply to call the raw Lisp
; function.  An added benefit is that we can check here that dir is not nil.

           (cond
            ((and (null dir)
                  (member-eq caller '(add-include-book-dir
                                      add-include-book-dir!)))
             (er soft ctx
                 "It is illegal to call ~x0 with a directory argument of nil."
                 caller))
            (t
             (er soft ctx
                 "Internal error: Illegal call of change-include-book-dir: ~
                  ~x0 is ~x1 but ~x2 is ~x3 (expected ~v4)."
                 'dir dir 'caller caller
                 (if dir
                     '(add-include-book-dir add-include-book-dir!)
                   '(delete-include-book-dir delete-include-book-dir!))))))
          ((or (not (keywordp keyword))
               (eq keyword :SYSTEM))
           (er soft ctx
               "The first argument of ~x0 must be a keyword (see :DOC ~
                keywordp) other than :SYSTEM, but ~x1 is not."
               caller keyword))
          ((and dir (not (stringp dir)))
           (er soft ctx
               "The second argument of ~x0 must be a string or of the form ~
                (:SYSTEM . string), but ~x1 is not."
               caller dir))
          (t
           (state-global-let*
            ((inhibit-output-lst (cons 'summary (@ inhibit-output-lst)))
             (modifying-include-book-dir-alist t))
            (let ((dir (and dir
                            (maybe-add-separator
                             (extend-pathname (cbd) dir state))))
                  (raw-p (raw-include-book-dir-p state))
                  (wrld (w state)))
              (mv-let
               (old alt)
               (cond
                (raw-p
                 (cond
                  (bang-p
                   (mv (f-get-global 'raw-include-book-dir!-alist
                                     state)
                       (f-get-global 'raw-include-book-dir-alist
                                     state)))
                  (t
                   (mv (f-get-global 'raw-include-book-dir-alist
                                     state)
                       (f-get-global 'raw-include-book-dir!-alist
                                     state)))))
                (bang-p
                 (mv (table-alist 'include-book-dir!-table wrld)
                     (cdr (assoc-eq :include-book-dir-alist
                                    (table-alist 'acl2-defaults-table
                                                 wrld)))))
                (t
                 (mv (cdr (assoc-eq :include-book-dir-alist
                                    (table-alist 'acl2-defaults-table
                                                 wrld)))
                     (table-alist 'include-book-dir!-table wrld))))
               (let ((old-pair (assoc-eq keyword old))
                     (alt-pair (assoc-eq keyword alt)))
                 (cond
                  ((and dir
                        (not (absolute-pathname-string-p dir t (os wrld))))

; The call above of maybe-add-separator should make this branch dead code, but
; we leave it here for robustness, e.g., in case we change that call.

                   (er soft ctx
                       "The second argument of ~x0 must represent a ~
                        directory, in particular ending with character '~s1', ~
                        but ~x2 does not."
                       caller *directory-separator-string* dir))
                  ((and dir
                        (equal (cdr old-pair) dir))
                   (stop-redundant-event ctx state))
                  ((if dir
                       (or old-pair alt-pair) ; already bound
                     alt-pair)                ; bound in the wrong table
                   (mv-let
                    (other-add other-delete)
                    (cond (bang-p
                           (mv 'add-include-book-dir
                               'delete-include-book-dir))
                          (t
                           (mv 'add-include-book-dir!
                               'delete-include-book-dir!)))
                    (cond ((null dir) ; hence alt-pair
                           (er soft ctx
                               "The keyword ~x0 was previously bound to ~
                                directory ~x1 by a call of ~x2.  Perhaps you ~
                                intended to call ~x3 instead of ~x4."
                               keyword (cdr alt-pair) other-add other-delete
                               caller))
                          (alt-pair
                           (er soft ctx
                               "The keyword ~x0 was previously bound to ~
                                directory ~x1 by a call of ~x2.  To bind ~x0 ~
                                with ~x3 first evaluate ~x4."
                               keyword
                               (cdr alt-pair)
                               other-add
                               caller
                               (list other-delete keyword)))
                          (t (er soft ctx
                                 "The keyword ~x0 was previously bound to ~
                                  directory ~x1.  If you intend to override ~
                                  the old setting with directory ~x2, first ~
                                  evaluate ~x3."
                                 keyword
                                 (cdr old-pair)
                                 dir
                                 (list (cond (bang-p 'delete-include-book-dir!)
                                             (t 'delete-include-book-dir))
                                       keyword))))))
                  ((and (null dir)
                        (null (cdr old-pair)))
                   (stop-redundant-event ctx state))
                  (t (let ((new (cond (dir (acons keyword dir old))
                                      (t (delete-assoc-eq keyword old)))))
                       (er-progn
                        (cond
                         (raw-p
                          (pprogn
                           (cond (bang-p
                                  (f-put-global 'raw-include-book-dir!-alist
                                                new
                                                state))
                                 (t
                                  (f-put-global 'raw-include-book-dir-alist
                                                new
                                                state)))
                           (value nil)))
                         ((not bang-p)
                          (table-fn 'acl2-defaults-table
                                    (list :include-book-dir-alist
                                          (kwote new))
                                    state
                                    (list 'table
                                          'acl2-defaults-table
                                          ':include-book-dir-alist
                                          (kwote new))))
                         (dir
                          (table-fn 'include-book-dir!-table
                                    (list keyword (kwote dir))
                                    state
                                    (list 'table
                                          'include-book-dir!-table
                                          keyword
                                          (kwote dir))))
                         (t
                          (table-fn 'include-book-dir!-table
                                    (list nil (kwote new) :clear)
                                    state
                                    (list 'table
                                          'include-book-dir!-table
                                          nil
                                          (kwote new)
                                          :clear))))
                        (value new)))))))))))))

(defun add-custom-keyword-hint-fn (key uterm1 uterm2 state)

; We translate uterm1 and uterm2 to check the syntactic requirements and we
; cause errors if we don't like what we see.  BUT we store the untranslated
; uterm1 and uterm2 in the custom-keywords-table!  The reason is that the
; invariant on the table cannot 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))))))))))

#-acl2-loop-only
(defmacro reset-prehistory (&rest args)
  (declare (ignore args))
  nil)

#+acl2-loop-only
(defmacro reset-prehistory (&whole event-form &optional permanent-p)

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

  (declare (xargs :guard (member-eq permanent-p '(t nil))))
  (list 'reset-prehistory-fn
        (list 'quote permanent-p)
        'state
        (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)
  (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 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)
         (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)
                   (f-get-global 'skip-reset-prehistory state)))
          (pprogn (observation ctx
                               "~x0 events with permanent-p=nil are skipped ~
                                when ~@1.  See :DOC reset-prehistory."
                               'reset-prehistory
                               (cond
                                ((f-get-global 'certify-book-info state)
                                 "certifying books")
                                ((eq (f-get-global 'ld-skip-proofsp state)
                                     'include-book)
                                 "including books or during the second pass ~
                                  of an encapsulate")
                                (t "state global 'skip-reset-prehistory has a ~
                                    non-nil value")))
                  (value :skipped)))
         (t
          (let* ((wrld (w state))
                 (event-form (or event-form
                                 (list 'reset-prehistory permanent-p)))
                 (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 (getpropc fn 'formals t wrld)
                                       t))
                              (symbol-alistp val))))
  (let ((commutative (cdr (assoc-eq :commutative val))))
    (cond ((null commutative) t)
          ((not (eql (len (getpropc fn 'formals t 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 (getpropc commutative 'theorem nil 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 non-memoizable-stobjs (stobjs-in wrld)
  (cond ((endp stobjs-in) nil)
        ((getpropc (car stobjs-in) 'non-memoizable nil wrld)
         (cons (car stobjs-in)
               (non-memoizable-stobjs (cdr stobjs-in) wrld)))
        (t (non-memoizable-stobjs (cdr stobjs-in) wrld))))

(defun filter-absstobjs (lst wrld abs conc)
  (cond ((endp lst) (mv (reverse abs) (reverse conc)))
        ((getpropc (car lst) 'absstobj-info nil wrld)
         (filter-absstobjs (cdr lst) wrld (cons (car lst) abs) conc))
        (t
         (filter-absstobjs (cdr lst) wrld abs (cons (car lst) conc)))))

(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)
                         (getpropc key 'formals t wrld)
                       t))
        (key-class (symbol-class key wrld))
        (condition (and val (cdr (assoc-eq :condition-fn val))))
        (inline (and val (cdr (assoc-eq :inline val))))
        (aokp (and val (cdr (assoc-eq :aokp val)))))
    (let ((result
           (cond
            ((eq key-formals t)
             (er hard ctx
                 "~@0~x1 is not a function symbol."
                 str key))
            ((and (or condition (cdr (assoc-eq :inline val)))

; The preceding term says that we are not profiling.  Why not replace it simply
; with condition, allowing :inline t?  Perhaps we could, but that would require
; a bit of thought since memoization with :inline t will modify recursive
; calls, and we would need to be sure that this replacement doesn't violate
; syntactic restrictions.  We can think about this if someone has reason to
; memoize with :condition nil but not :inline nil.

                  (member-eq 'state (stobjs-in key wrld)))
             (er hard ctx
                 "~@0~x1 takes ACL2's STATE as an argument (illegal except ~
                  for profiling)."
                 str key))
            ((not (booleanp aokp))
             (er hard ctx
                 "~@0:aokp has a non-Boolean value, ~x1."
                 str aokp))
            ((and (or condition (cdr (assoc-eq :inline val)))

; See comment above for the case of 'state.

                  (non-memoizable-stobjs (stobjs-in key wrld) wrld))
             (mv-let
              (abs conc)
              (filter-absstobjs (non-memoizable-stobjs (stobjs-in key wrld)
                                                       wrld)
                                wrld nil nil)
              (cond
               ((null abs)
                (er hard ctx
                    "~@0~x1 has input stobj~#2~[ ~&2~/s ~&2, each~] ~
                     introduced with :NON-MEMOIZABLE T.  See :DOC defstobj."
                    str key conc))
               ((null conc)
                (er hard ctx
                    "~@0~x1 has input abstract stobj~#2~[ ~&2~/s ~&2, each ~
                     of~] whose corresponding concrete stobj was introduced ~
                     with :NON-MEMOIZABLE T.  See :DOC defstobj."
                    str key abs))
               (t
                (er hard ctx
                    "~@0~x1 has input concrete stobj~#2~[ ~&2~/s ~&2, each~] ~
                     introduced with :NON-MEMOIZABLE T.  ~x1 also has input ~
                     abstract stobj~#3~[ ~&2~/s ~&3, each of~] whose ~
                     corresponding concrete stobj was introduced with ~
                     :NON-MEMOIZABLE T.  See :DOC defstobj."
                    str key conc abs)))))
            ((and (or condition (cdr (assoc-eq :inline val)))

; See comment above for the case of 'state.

                  (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 (illegal except for profiling)."
                   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))
            ((getpropc key 'constrainedp nil 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))
            ((and inline
                  (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 unless :RECURSIVE is nil."
                 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)
                                         (getpropc condition 'formals t wrld)
                                       t)))
                   (val-guard (and condition
                                   (if (symbolp condition)
                                       (getpropc condition 'guard *t* 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 (getpropc key 'guard *t* 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 add-suffix-to-fn (sym suffix)

; We add a suffix to sym to create a legal function symbol.  Thus, we avoid
; creating a name in the "COMMON-LISP" package, since ACL2 won't allow such a
; name to be a function symbol.

  (if (equal (symbol-package-name sym)
             *main-lisp-package-name*)
      (intern (concatenate 'string (symbol-name sym) suffix)
              "ACL2")
    (add-suffix sym suffix)))

(mutual-recursion

(defun fsubcor-var (vars terms form)

; This analogue of subcor-var uses fcons-term instead of cons-term, in order to
; avoid losing the structure of form.  For example, (fsubcor-var (x) ('3)
; (consp x)) evaluates to (consp '3) rather than to nil.

  (declare (xargs :guard (and (symbol-listp vars)
                              (pseudo-term-listp terms)
                              (equal (length vars) (length terms))
                              (pseudo-termp form))))
  (cond ((variablep form)
         (subcor-var1 vars terms form))
        ((fquotep form) form)
        (t (fcons-term (ffn-symb form)
                       (fsubcor-var-lst vars terms (fargs form))))))

(defun fsubcor-var-lst (vars terms forms)
  (declare (xargs :guard (and (symbol-listp vars)
                              (pseudo-term-listp terms)
                              (equal (length vars) (length terms))
                              (pseudo-term-listp forms))))
  (cond ((endp forms) nil)
        (t (cons (fsubcor-var vars terms (car forms))
                 (fsubcor-var-lst vars terms (cdr forms))))))

)

(defun print-gv-form (guard-fn guard tguard vars args ignorable substitute ctx
                               state)

; If tguard is non-nil, then guard is nil and should be created by
; untranslating tguard (perhaps after substitution).  Args are always in
; translated form.

  (let ((wrld (w state)))
    (cond
     (substitute
      (er-let* ((tguard (if (null tguard)
                            (translate guard '(nil) nil t ctx wrld state)
                          (value tguard))))
        (value (untranslate (fsubcor-var vars args tguard) t wrld))))
     (t
      (let ((guard (if tguard
                       (untranslate tguard t wrld)
                     guard)))
        (value `(flet ((,guard-fn
                        ,vars
                        ,@(and ignorable
                               `((declare (ignorable ,@vars))))
                        ,guard))
                  (,guard-fn ,@(untranslate-lst args nil wrld)))))))))

(defun print-gv-conjunct (guard-fn formals conjuncts args index
                                   len-all-conjuncts fn substitute ctx state)
  (cond
   ((endp conjuncts)
    (er soft ctx
        "It is surprising that ~x0 yields no conjunct of the guard of ~x1 ~
         that evaluates to ~x2.  Sorry!  Try ~x0 without the :conjunct ~
         keyword argument."
        'print-gv
        fn
        nil))
   (t (let* ((conjunct (car conjuncts))
             (alist (restrict-alist-to-all-vars (pairlis$ formals args)
                                                conjunct))
             (f1 (strip-cars alist))
             (a1 (strip-cdrs alist)))
        (er-let* ((form (print-gv-form guard-fn
                                       nil      ; guard
                                       conjunct ; tguard
                                       f1 a1 nil substitute ctx state)))
          (mv-let (erp stobjs-out/replaced-val state)
            (trans-eval form ctx state t)
            (cond (erp
                   (value (msg "Evaluation causes an error:~|~x0"
                               conjunct)))
                  ((cdr stobjs-out/replaced-val)
                   (print-gv-conjunct guard-fn formals (cdr conjuncts) args
                                      (1+ index)
                                      len-all-conjuncts fn substitute ctx
                                      state))
                  (t
                   (value (msg "Showing guard conjunct (#~x0 of ~x1) that ~
                                evaluates to nil:~|~%~x2."
                               index len-all-conjuncts form))))))))))

(defun print-gv1 (fn-guard-stobjsin-args conjunct substitute ctx 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 (add-suffix-to-fn fn "{GUARD}")))

; Note: (nth 2 fn-guard-stobjsin-args) is the stobjs-in of fn, but we don't
; need it.

    (if conjunct
        (let ((conjuncts (flatten-ands-in-lit (guard fn nil wrld))))
          (print-gv-conjunct guard-fn formals conjuncts args 1
                             (length conjuncts) fn substitute ctx state))
      (print-gv-form guard-fn guard nil formals args t substitute ctx state))))

(defun print-gv-fn (evisc-tuple conjunct substitute state)
  (prog2$
   (wormhole 'ev-fncall-guard-er-wormhole
             '(lambda (whs)
                (set-wormhole-entry-code whs :ENTER))
             nil
             `(er-progn
               (let ((info ; see save-ev-fncall-guard-er
                      (wormhole-data (f-get-global 'wormhole-status state))))
                 (cond ((null info)
                        (pprogn
                         (fms "There is no guard violation to debug.~|~%"
                              nil (standard-co state) state nil)
                         (value nil)))
                       (t
                        (er-let* ((val (print-gv1 info ',conjunct ',substitute
                                                  'print-gv state)))
                          (pprogn
                           (fms ,(if conjunct
                                     "~@0~|~%"
                                   "~x0~|~%")
                                (list (cons #\0 val))
                                (standard-co state) state ',evisc-tuple)
                           (value nil))))))
               (value :q))
             :ld-prompt  nil
             :ld-missing-input-ok nil
             :ld-pre-eval-filter :all
             :ld-pre-eval-print  nil
             :ld-post-eval-print :command-conventions
             :ld-evisc-tuple nil
             :ld-error-triples  t
             :ld-error-action :error
             :ld-query-control-alist nil
             :ld-verbose nil)
   (value :invisible)))

(defun set-print-gv-defaults-fn (state evisc-tuple evisc-tuple-p
                                       conjunct conjunct-p
                                       substitute substitute-p)
  (declare (xargs :guard t :mode :program))
  (cond
   ((and (null evisc-tuple-p)
         (null conjunct-p)
         (null substitute-p)) ; optimization, really
    (value (f-get-global 'print-gv-defaults state)))
   (t
    (let ((ctx 'set-print-gv-defaults))
      (cond ((not (or (null evisc-tuple)
                      (eq evisc-tuple :restore)
                      (standard-evisc-tuplep evisc-tuple)))
             (er soft ctx
                 "Illegal evisc-tuple: ~x0"
                 evisc-tuple))
            ((not (or (booleanp conjunct)
                      (eq conjunct :restore)))
             (er soft ctx
                 "Illegal value for :conjunct (must be Boolean): ~x0"
                 conjunct))
            ((not (or (booleanp substitute)
                      (eq substitute :restore)))
             (er soft ctx
                 "Illegal value for :conjunct (must be Boolean): ~x0"
                 substitute))
            (t (let* ((alist (f-get-global 'print-gv-defaults state))
                      (alist (cond ((not evisc-tuple-p)
                                    alist)
                                   ((eq evisc-tuple :restore)
                                    (delete-assoc-eq :evisc-tuple alist))
                                   (t
                                    (put-assoc-eq :evisc-tuple evisc-tuple alist))))
                      (alist (cond ((not conjunct-p)
                                    alist)
                                   ((eq conjunct :restore)
                                    (delete-assoc-eq :conjunct alist))
                                   (t
                                    (put-assoc-eq :conjunct conjunct alist))))
                      (alist (cond ((not substitute-p)
                                    alist)
                                   ((eq substitute :restore)
                                    (delete-assoc-eq :substitute alist))
                                   (t
                                    (put-assoc-eq :substitute substitute
                                                  alist)))))
                 (pprogn (f-put-global 'print-gv-defaults alist state)
                         (value alist)))))))))

(defmacro set-print-gv-defaults (&key (evisc-tuple 'nil evisc-tuple-p)
                                      (conjunct 'nil conjunct-p)
                                      (substitute 'nil substitute-p))
  `(set-print-gv-defaults-fn state
                             ,evisc-tuple ,evisc-tuple-p
                             ,conjunct ,conjunct-p
                             ,substitute ,substitute-p))

(defmacro print-gv-evisc-tuple ()
  '(evisc-tuple nil                     ; print-level
                nil                     ; print-length
                (world-evisceration-alist state nil)
                nil ; hiding-cars
                ))

(defmacro print-gv-default (key)
  (declare (xargs :guard (member-eq key ; avoid capture
                                    '(:evisc-tuple
                                      :conjunct
                                      :substitute))))
  (let* ((name (symbol-name key))
         (key-p (intern (concatenate 'string name "-P") "ACL2"))
         (default (if (eq key :evisc-tuple)
                      '(print-gv-evisc-tuple)
                    nil)))
    `(cond (,key-p ,(intern name "ACL2"))
           (t '(let ((pair (assoc-eq ,key (f-get-global 'print-gv-defaults state))))
                 (if pair (cdr pair) ,default))))))

(defmacro print-gv (&key (evisc-tuple 'nil evisc-tuple-p)
                         (conjunct 'nil conjunct-p)
                         (substitute 'nil substitute-p))
  `(print-gv-fn ,(print-gv-default :evisc-tuple)
                ,(print-gv-default :conjunct)
                ,(print-gv-default :substitute)
                state))

(defun disable-iprint-ar (state)
  (cond ((iprint-enabledp state)

; A comment in rollover-iprint-ar explains conditions that allow a certain
; multiplier of 4 to enable 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))
  (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))
  `(set-evisc-tuple-fn ,evisc-tuple
                       ,iprint ,iprint-p
                       ,sites ,sites-p
                       state))

(defmacro top-level (form &rest declares)
  `(mv-let (erp val state)
           (ld '((pprogn ; ensure initialization
                  (f-put-global 'top-level-errorp nil state)
                  (value :invisible))
                 (with-output
                  :off :all
                  :on error
                  (defun top-level-fn (state)
                    (declare (xargs :mode :program :stobjs state)
                             (ignorable state))
                    ,@declares
                    ,form))
                 (ld '((pprogn
                        (f-put-global 'top-level-errorp t state)
                        (value :invisible))
                       (top-level-fn state)
                       (pprogn
                        (f-put-global 'top-level-errorp nil state)
                        (value :invisible)))
                     :ld-post-eval-print :command-conventions
                     :ld-error-action :return
                     :ld-error-triples t)
                 (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
      (getpropc name 'constrainedp
                '(:error
                  "See defattach-unknown-constraints-error:  expected to find ~
                   a 'constrainedp property where we did not.")
                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))
                             ((getpropc f 'macro-body nil 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 (f-get-global 'boot-strap-flg state)))
                 (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
                             (getpropc f 'constraint-lst t 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 (getpropc f 'non-executablep nil
                                                      wrld)
                                            :program)))

; Is it legal to attach for execution?  A 'constraint-lst property alone isn't
; enough, because a defined function can have a constraint-lst; for example, g
; has a Common Lisp defun (so we can't attach to it) yet it also has a non-nil
; 'constraint-lst property.

; (encapsulate
;  ((f (x) t))
;  (local (defun f (x) x))
;  (defun g (x) (f x))
;  (defthm some-prop (equal (g x) (f x))))

; A 'constrainedp property alone isn't enough either, because defchoose
; introduces a 'constrainedp property of t but doesn't provide a
; 'constraints-lst property.  That might be OK, depending on how we gather
; constraints; but defchoose is an unusual case and for now we won't consider
; it.

                              (or (eq constraint-lst t) ; property is missing
                                  (not (getpropc f 'constrainedp nil wrld))))

; We cause an error: the function is not permitted an executable attachment.
; The only challenge is to provide a useful error message.

                         (er soft ctx
                             "It is illegal to attach to function symbol ~x0, ~
                              because it was introduced with ~x1.~@2"
                             f
                             (if (getpropc f 'defchoose-axiom nil 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))
                                     ((getpropc g 'macro-body nil 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 (f-get-global 'boot-strap-flg state)
                             (ttag wrld))))
               (er soft ctx
                   "It is illegal to specify a non-nil value of :SKIP-CHECKS ~
                    for defattach unless there is an active trust tag."))
              (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 state
                                              :displayed-goal ugoal
                                              :otf-flg otf-flg)
                                   hints ens wrld ctx state)))))
          (prove-defattach-guards1 (1+ i)
                                   n
                                   (cdr attachment-alist-tail)
                                   attachment-alist
                                   (cdr helpers-lst)
                                   ctx ens wrld state
                                   (cons-tag-trees ttree1 ttree))))))))

(defun prove-defattach-guards (attachment-alist helpers-lst ctx ens wrld state)

; This function is based on prove-corollaries, but instead of being given
; corollaries, we are given an attachment-alist with pairs (f . g) such that
; the guard of f must be proved to imply the guard of g.  Helpers-lst is a list
; of alists corresponding positionally to attachment-alist, each of which binds
; elements of *defattach-keys* to values to help with the respective proof.
; Like prove, we return an error triple; the non-erroneous value is a ttree
; 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 state
                                       :displayed-goal ugoal
                                       :otf-flg otf-flg)
                            hints ens wrld ctx state)))))
           (value ttree)))))))))

; Essay on Merging Attachment Records

; See the Essay on Defattach for relevant background.  Our goal in this Essay
; is to describe the process whereby we check for loops in the extended
; ancestor relation and, more generally, compute that relation as a transitive
; closure.

; Let S be the siblings relation: thus S(f1,f2) holds if f1 and f2 are
; introduced in the same event.  Clearly S is an equivalence relation, and we
; will write S(f) to denote the canonical representative of that equivalence
; class, i.e., the canonical sibling of f.  A function f is canonical if S(f)
; is f.

; Recall from the Essay on Defattach that our goal is to reorder events in a
; manner that respects not only the original ancestor relation but also a new
; relation containing the ordered pair <g,f> for each attachment pair <f,g>,
; which we'll call the "immediate extended ancestor relation".  (Motivation:
; The < relation implements the use of an attachment equation in the evaluation
; chronology to define f in terms of g.)  However, for each such <g,f> added to
; that relation, we also add <g',f'> for each sibling g' of g and sibling f' of
; f.  We denote the ordinary ancestors relation as <|, which we also consider
; to respect ancestors: we include <f1',f2'> in this relation whenever f1' and
; f2' are siblings of f1 and f2 (respectively) and f1 is an ordinary ancestor
; of f2.  Finally, we define <+ as the transitive closure of the union of < and
; <|.

; The reordering argument in the Essay on Defattach provides the proof
; obligation that <+ must not contain loops.  Since f1 <+ f2 if and only if
; S(f1) <+ S(f2), we will use canonical siblings in our algorithms.  Indeed, it
; is convenient to think of all of these relations (<, <|, and <+) as being
; defined only on canonical function symbols.  Below, we denote as "f-canonical
; and "g-canonical" the function symbols S(f0) and S(g0), respectively, where
; <f0,g0> ranges over attachment pairs.

; We turn now to describe our transitive closure algorithm for computing <+.
; We create a data structure for each g-canonical function, g.  Each such g is
; associated with its canonical predecessors in each of the relations <| and <,
; and we use notation below such as "FNS" for either of these.  Then, we apply
; a "merge" operation to build up to the transitive closure.  If we encounter a
; loop, as described below, then we stop and report the loop.

; We present our algorithm using examples.  Assume that g1 initially has FNS1
; as its set of predecessors in either <| or <, and that g2 is similarly
; related to FNS2, where g1 < f1 and g2 < f2.  Thus there are attachment pairs
; <f1',g1'> and <f2',g2'> such that S(fi') = fi and S(gi') = gi; and we may
; write FNS1 <+ g1 and FNS2 <+ g2.  Now suppose f2 is in FNS1.  So we have this
; picture:

;                             FNS1 <+ g1
;                FNS2 <+ g2 < f2

; We thus associate with g1 a structure exhibiting the following path, obtained
; by merging the paths above using the attachment pair <f2,g2>.

;                FNS2 <+ g2 < f2 <+ g1

; More generally, we may or may not involve the "f field" (first component) of
; an attachment pair <f,g>.  Consider the following paths P0 and P1.

; P0:                                FNS2 <+ g2 < f2 <+ g1
; P1:   FNS4 <+ g4 <+ ... <+ x <+ g3 < f3

; We could merge using f3 if it is in FNS2, as in our previous example, or
; using g3 if it is in FNS2.  Respectively, the resulting merges of P1 into P0
; are:

;       FNS4 <+ g4 <+ ... <+ x <+ g3 < f3 <+ g2 < f2 <+ g1
;       FNS4 <+ g4 <+ ... <+ x <+ g3      <+ g2 < f2 <+ g1

; Let us call these an "f-merge" and a "g-merge", respectively, of P1 into P0.

; As an optimization, for the case FNS2 <| g2 we only allow a g-merge if P1
; consists entirely of FNS4 <+ g3 < f3.  To justify this optimization, suppose
; that P1 is as above where g4 is not g3.  We may restrict ourselves to
; constructing minimal paths.  We can thus rule out the case x <| g3, since
; otherwise we have y <+ x <| g3 <| g2, which by minimality and transitivity of
; <| implies that we have y < x <| g2.  So x is in FNS2, and we can form a path
; from FNS4 to g1 by doing an f-merge after stripping g3 from P1 (with y<x
; playing the role of g3<f3).

; In general, each such g1 is associated with a record structure that we refer
; to as an "attachment record", which includes a list of paths that is
; continually expanded by merging paths from other records into its existing
; paths.  We return later to a brief discussion of the implementation, in
; particular the relevant data structures.

; We employ a further optimization (function defattach-component-has-owner).
; Stored with each path is an "owner": the function symbol immediately
; following the initial set of functions, which we use to avoid attempting any
; merge that would be redundant in the sense that there is already a path with
; the same owner.  Consider again the merge candidate pictured above.

; P0:                                FNS2 <+ g2 < f2 <+ g1
; P1:   FNS4 <+ g4 <+ ... <+ x <+ g3 < f3

; Suppose we are considering a merge of these components, but the attachment
; record for g1 already has a component owned by g4.  Then we avoid considering
; such a merge, since the result would merely produce another <+-path from FNS4
; to g1.  (Note that we actually store both sorts of FNS4: the <-predecessors
; of g4 and the <|-predecessors of g4.)

; In particular, we never need merge two components from the same record, a
; fact we utilize in function defattach-merge-lst-lst.

; It is easy to see by induction that all paths built by this merging process
; stay inside the transitive closure (<*) of <+.  That is, our algorithm is
; sound.  For completeness, we first need a notion of "suitable" path x0 <+ x1
; <+ ... <+ xk (think of x0 as belonging to the FNS associated with x1),
; defined as follows.

; - We can write the path so that each arc joining consecutive elements is of
;   the form g < f or h <| g, where no two consecutive arcs both use <|.
; - Each element of the path is f-canonical or g-canonical.
; - The final arc in the path is of the form h < g or h <| g for some
;   g-canonical g.

; Clearly the f-merge and g-merge operations shown above preserve this notion
; of suitable path.  It is also clear that every minimal path of length at
; least 2 whose penultimate element is g-canonical is a suitable path.

; Thus, we need consider only suitable paths when forming the transitive
; closure.  We claim that after at least n full iterations of our algorithm
; (that is: attempting all possible pairwise merges at each iteration, and
; perhaps more), then every suitable path FNS <+ ... <+ g of length at most
; 2^N+1 is present.  This fact has a straightforward proof by induction on the
; length of a path, where the inductive step proceeds by dividing a path of
; length 2^N+1 into two pieces where the head of one is the tail of the other,
; one of length at most 2^(N-1) and the other of length at most 2^(N-1)+1.

; The argument above shows that in fact, the attachment record for every
; g-canonical g includes every <+-ancestor of g (again, considering only
; canonical function symbols), either as a member of the set FNS defined by FNS
; <| g' for some g-canonical g' <+ g, or else as such a g' (the owner of the a
; component's path for ordinary ancestor set FNS).

; As we compute the transitive closure, we look for loops.  Where do we look?
; First observe that if there is a loop, then the loop involves at least one
; use of <; so there is a loop connecting g to itself for some g-canonical g.
; By the argument above we know that we will at some point construct a path
; from g; thus g is in FNS where we have constructed FNS <+ h <+ ... g.  When
; that occurs, we report the loop.

; (Remark.  Notice that we are building up the set of extended ancestors of g
; in a manner that lets us report any loop that is found.  We may be able to
; change our algorithm to compute this set more efficiently by unioning all the
; FNS found into a single FNS for the entire attachment record, running the
; original algorithm only if a loop is detected; but that can wait.  The
; current approach may have the advantage that less needs to be thrown away
; when we erase, as with (defattach f nil).  End of remark.)

; Let's explore further how this works at the implementation level.

; Attachment records have the following fields, where we write x++y to denote
; the result of appending y to x unless x or y is a symbol, in which case it is
; treated as a list containing just that symbol.  For example, if x is (f1 f2)
; and y is either (f3) or f3, then x++y is (f1 f2 f3).

; - g
;   where g is g-canonical
; - ext-succ
;   (immediate) canonical successors of g in <
; - components
;   A list of components, each of which is an attachment-component record
;   having the following fields:
;     - path
;       a list of function symbols such that each element has relation < or <|
;       to the next
;     - ext-anc, ord-anc
;       the set of predecessors under < (respectively, <|) of the first element
;       of path++g; thus if path is empty then g else the first element of
;       path.  Note that we collect here only canonical function symbols.
; - pairs
;   list of all attachment pairs <f0,g0> such that S(g0) = g; thus, the
;   :ext-succ field is the set of S(f0) for all <f0,g0> in the :pairs field

; Note that the pairs field is used only by the code that erases attachment
; pairs, not by the code that merges paths.

; The notion of owner, introduced above, is realized in the following
; definition.

(defun attachment-component-owner (g path)

; Return the owner of an attachment-component, with :path field of path, that
; is in the :components field of an attachment record with :g field of g.

  (if path (car path) g))

; The initial attachment record for a given g has a unique component, with
; owner g and empty path, and whose ext-anc field (denoted fns<g) and ord-anc
; field (denoted fns<|g) are, respectively, the set of all immediate extended
; ancestors (i.e., <-predecessors) and of ordinary ancestors (i.e.,
; <|-predecessors) of g.  We maintain the invariant that this component is
; always the last one in the list of components of an attachment record.

; We can now build our algorithm from the bottom up.  The fundamental operation
; is (defattach-merge r1 r2), which merges r2 into r1 if there is such a merge.
; Function defattach-merge-lst takes a record r1 and list lst of records, and
; repeatedly merges the elements of lst into r1.  Function
; defattach-merge-lst-lst is called on a list of records and merges each record
; into each other record in the list.

; But we might find a cycle.  The above functions typically return (mv flg
; result), where: flg = nil if there has been no merging, in which case result
; is irrelevant; flg = 'loop if there has been merging, in which case result is
; the representation of a loop; or flg = t, in which case there has been
; merging but there is no loop.

; End of Essay on Merging Attachment Records

(defun defattach-component-has-owner (g g0 comps)

; See the Essay on Merging Attachment Records.

; Comps is a list of attachment components from an attachment record with :g
; field of g0.  We return true when there is a component from comps whose owner
; is g.  The idea is that we are considering whether to try to merge a
; component with path [FNS <+ g <+ ...]  into the set comps of components of
; some attachment record for g0.  If one of those components already contains
; such a path, then we return true to indicate that don't need another one.

  (cond ((endp comps) nil)
        (t (let ((path (access attachment-component (car comps) :path)))
             (or (eq g (attachment-component-owner g0 path))
                 (defattach-component-has-owner g g0 (cdr comps)))))))

(defun defattach-merge-into-component (g0 ext-succ0 comps0 ext-succ1 g1
                                          ord-anc1 ext-anc1 path1)

; See the Essay on Merging Attachment Records.  We return (mv flg x), where if
; flg is 'loop then x is a loop, and otherwise x is a list of components
; extending comps0, as described below, and flg is nil if x is exactly comps0,
; else t.

; We attempt a merge into some component of a record, R0, from a component of
; another record, R1.  The following picture illustrates the situation using
; parameter names from this function and local variables introduced in the code
; below, while omitting unneeded fields.

; R0:
; [:g g0
;  :ext-succ ext-succ0
;  :comps
;  (   ...
;      [:ord-anc ord-anc0
;       :ext-anc ext-anc0
;       :path path0 ; nil or (h0 ...)
;      ...)

; R1:
; (:ext-succ ext-succ1
;  :g g1
;  :comps ; comps1, which is the following list:
;   (
;      ...
;      [:ord-anc ord-anc1
;       :ext-anc ext-anc1
;       :path path1 ; nil
;      ...)

; First consider the f-merge case.  From R0 and R1 we have the following paths,
; where each anci is either ord-anci or ext-anci.

;                       anc0 <+ h0 <+ ... <+ g0
;   anc1 <+ ... <+ g1 < ext-succ1

; For an f-merge we need ext-succ1 and anc0 to intersect; suppose we find h in
; their intersection.  The resulting component then has this path:

;   anc1 <+ ... <+ g1 < h <+ h0 <+ ... <+ g0

; For the g-merge case we require either the use of ext-anc0 for anc0, or else
; that path1 = nil.  Then we can consider the following picture.

;                anc0 <+ h0 <+ ... <+ g0
;   anc1 <+ ... <+ g1

; We can merge if g1 is in anc0, obtaining:

;   anc1 <+ ... <+ g1 <+ h0 <+ ... <+ g0

; Suppose that the merge succeeds.  If g0 is in anc1, then we have a loop.  We
; also have a loop if ext-succ0 intersects anc1, say at h1:

;    h1  <+ ... <+ g1 <+ h0 <+ ... <+ g0 < h1

; If h1 is not 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 (getpropc (car symbols) 'defaxiom-supporter nil wrld)))
             (cond
              (prop (cons (msg "function symbol ~x0 supports defaxiom ~x1"
                               (car symbols) prop)
                          (defaxiom-supporter-msg-list (cdr symbols) wrld)))
              (t (defaxiom-supporter-msg-list (cdr symbols) wrld)))))))

(defun 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
                     (getpropc val2 'macro-body nil 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))

(defmacro defmacro-last (fn &key raw (top-level-ok 't))
  (declare (xargs :guard (and (symbolp fn)
                              (symbolp raw))))
  (let ((raw (or raw (add-suffix fn "-RAW"))))
    `(progn (defmacro ,fn (x y)
              (list 'return-last (list 'quote ',raw) x y))
            (table return-last-table ',raw '
                   ,(if top-level-ok fn (list fn))))))

; Formatted printing to strings requires local stobjs (actually
; with-local-state), so we place the relevant code below.  It could certainly
; go in later source files if that is desired.

(defconst *fmt-control-defaults*

; This constant should set up a state-global-let* binding for every state
; global variable that can have an effect on evaluation of a call of fms, fmt,
; or fmt1 (or their "!" versions), which are the functions on which we apply
; the macro channel-to-string.  The values for the margins are simply
; convenient large values.

  (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
                                  outside-loop-p)

; Form is a call of fms, fmt, or fmt1 (or their "!" versions) on variables.  To
; see why we make this restriction, consider the following form:

;   (channel-to-string
;    (f-put-global 'xxx (f-get-global 'term-evisc-tuple state) state)
;    chan)

; If you evaluate this form in raw-mode and then evaluate (@ xxx), you'll
; initially get :default.  But if then evaluate the form

;   (set-term-evisc-tuple (evisc-tuple 4 5 nil nil) state)

; and then evaluate the above channel-to-string call again, this time (@ xxx)
; evaluates to (NIL 4 5 NIL).  Thus, state changed even though
; channel-to-string generates a with-local-state call, which should not change
; state!

; If variable outside-loop-p (which is evaluated) is true, then evaluation of
; this form might be done more efficiently -- but it must be suitable for
; execution outside the loop or, if inside the loop, then without the
; evaluation of state-global-let* (or any other use of the
; *acl2-unwind-protect-stack*) for any state global modified by
; fmt-control-bindings.

; Note that fmt-controls 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

; Warning: Keep the two branches below in sync.

; We use acl2-unwind-protect and unwind-protect to guarantee that the new
; channel is finally closed.  See the comment about channels in
; mv-let-for-with-local-stobj.

          (cond
           (outside-loop-p
            `(unwind-protect
                 (state-free-global-let*
                  ,(fmt-control-bindings fmt-controls)
                  (mv-let (msg state)
                          (set-iprint-fn1
                           (case ,iprint-action
                             (:default :same)
                             ((nil) :reset)
                             (otherwise :reset-enable))
                           state)
                          (declare (ignore msg))
                          ,body0))
               (when (open-output-channel-p ,channel-var :character state)
                 (close-output-channel ,channel-var state))))
           (t
            `(acl2-unwind-protect

; We use acl2-unwind-protect to guarantee that the new channel is finally
; closed.  See the comment about channels in mv-let-for-with-local-stobj.

              "channel-to-string"
              (state-global-let*
               ,(fmt-control-bindings fmt-controls)
               (mv-let (msg state)
                       (set-iprint-fn1
                        (case ,iprint-action
                          (:default :same)
                          ((nil) :reset)
                          (otherwise :reset-enable))
                        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 ,(cond
                       (outside-loop-p
                        "ERROR: Failed to open string output channel to ~
                         report an error.")
                       (t '(er soft 'channel-to-string
                               "Implementation error: Unable to open a ~
                                channel to a string."))))))))
    `(with-local-state
      (mv-let
       (erp result state)
       (with-live-state ,body)
       (declare (ignore erp))
       ,(cond (extra-var `(mv (car result) (cdr result)))
              (t 'result))))))

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

#-acl2-loop-only
(defun hard-error-is-error (ctx str alist)
  (error "~a" (channel-to-string
               (error-fms-channel t ctx str alist chan state)
               chan nil nil :default t)))

; 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 be a memoized function symbol.  If m was memoized with :aok nil (the
; default), then the invariant maintained is simply that the
; :ext-anc-attachments field of the memoize-info-ht-entry record for m is nil.
; This implies the property we desire, that all stored entries for m are valid,
; because defattach events do not destroy the validity of stored results.  But
; in the case that f was memoized with :aok t, the :ext-anc-attachments field
; of the memoize-info-ht-entry record for m is a non-null fast alist whose keys
; are exactly the (canonical) extended ancestors of m, including the canonical
; sibling of m.  We maintain the invariant that the value of key f in this fast
; alist is itself an alist associating each sibling f' of f with its
; attachment, for each sibling f' that has an attachment.

; To summarize: in the :aok t case, we maintain the :ext-anc-attachments field
; to have the value described above, and every value stored in the memo table
; is correct with respect to the current attachments, which are those indicated
; in the :ext-anc-attachments field.  Thus, if a defattach event changes the
; attachment of (some sibling of) an extended ancestor, then the
; :ext-anc-attachments field is recalculated and stored anew.  If the only
; changes are to add new attachments, without changing or removing any existing
; attachments, then the memo table is not cleared; otherwise, it is.  The
; analogous actions are taken when we undo.

; For efficiency, we implement extend-world1, retract-world1, and recover-world
; so that they do not update such fields or clear memo-tables until all trips
; have been processed.  (This update is performed by
; update-memo-entries-for-attachments, which is called at the end of the above
; world updates, by update-wrld-structures.)  At that point we see whether any
; defattach event has been installed or undone, and then we see whether any
; memo-table's :ext-anc-attachments field needs to be recalculated, and whether
; furthermore the table needs to be invalidated, as discussed above.  For
; efficiency, we set a global variable, *defattach-fns*, to a list L of
; canonical siblings of all functions whose attachment may have been installed,
; eliminated, or changed.  We then restrict our check on :ext-anc-attachments
; fields (in update-memo-entries-for-attachments) to check attachments for
; siblings of functions in L.  In particular, if L is empty then nothing needs
; to be done.

; Start code supporting ext-ancestors-attachments.

(defun attachment-pairs (fns wrld acc)

; Accumulate into acc all attachment pairs (f . g) for f in fns.

  (cond ((endp fns) acc)
        (t (attachment-pairs
            (cdr fns)
            wrld
            (let ((pair (attachment-pair (car fns) wrld)))
              (cond (pair (cons pair acc))
                    (t acc)))))))

(defun sibling-attachments (f wrld)

; We return all attachment pairs (f0 . g0) for which f0 is a sibling of f.

  (attachment-pairs (siblings f wrld) wrld nil))

(defun ext-ancestors-attachments4 (fns wrld fal)
  (cond ((endp fns) fal)
        (t (ext-ancestors-attachments4
            (cdr fns)
            wrld
            (cond ((hons-get (car fns) fal)
                   fal)
                  (t (hons-acons (car fns)
                                 (sibling-attachments (car fns) wrld)
                                 fal)))))))

(defun ext-ancestors-attachments3 (components wrld fal)
  (cond ((endp components) fal)
        (t (ext-ancestors-attachments3
            (cdr components)
            wrld
            (let ((anc (access attachment-component (car components) :ord-anc))
                  (path (access attachment-component (car components) :path)))
              (ext-ancestors-attachments4
               (if path
                   (cons (car path) ; attachment-component-owner
                         anc)
                 anc)
               wrld
               fal))))))

(defun ext-ancestors-attachments2 (canon-gs arfal wrld canon-gs-fal fal)
  (cond ((endp canon-gs) fal)
        (t (let ((g (car canon-gs)))
             (cond ((hons-get g canon-gs-fal)
                    (ext-ancestors-attachments2
                     (cdr canon-gs) arfal wrld canon-gs-fal fal))
                   (t (let ((rec (cdr (hons-get g arfal))))
                        (ext-ancestors-attachments2
                         (cdr canon-gs) arfal wrld
                         (hons-acons g fal canon-gs-fal)
                         (let ((fal (hons-acons
                                     g
                                     (sibling-attachments (car canon-gs)
                                                          wrld)
                                     fal)))
                           (cond (rec (ext-ancestors-attachments3
                                       (access attachment rec :components)
                                       wrld
                                       fal))
                                 (t ; :skip-checks was used
                                  fal)))))))))))

(defun canonical-cdrs (alist wrld acc)
  (cond ((endp alist) acc)
        (t (canonical-cdrs (cdr alist)
                           wrld
                           (cons (canonical-sibling (cdar alist) wrld)
                                 acc)))))

(defun ext-ancestors-attachments1 (fns canon-gs arfal wrld fal)

; Arfal is a fast alist mapping g-canonical function symbols to attachment
; records.  We accumulate ordinary ancestors of members of fns, including those
; functions, into fal, as we accumulate immediate extended ancestors of members
; of fns into canon-gs.  Once fns is empty, however, we accumulate all extended
; ancestors of members of canon-gs (including those functions) into fal.

  (cond ((endp fns)
         (ext-ancestors-attachments2
          canon-gs arfal wrld 'ext-ancestors-attachments2 fal))
        ((hons-get (car fns) fal)
         (ext-ancestors-attachments1 (cdr fns) canon-gs arfal wrld fal))
        (t (let* ((alist (sibling-attachments (car fns) wrld))
                  (canon-gs (cond ((null alist) ; optimization
                                   canon-gs)
                                  (t (append (canonical-cdrs alist wrld nil)
                                             canon-gs)))))
             (ext-ancestors-attachments1
              (append (canonical-ancestors (car fns) wrld nil)
                      (cdr fns))
              canon-gs arfal wrld
              (hons-acons (car fns) alist fal))))))

(defun attachment-records-fal (attachment-records fal)
  (cond ((endp attachment-records) fal)
        (t (attachment-records-fal
            (cdr attachment-records)
            (hons-acons (access attachment (car attachment-records) :g)
                        (car attachment-records)
                        fal)))))

(defun ext-ancestors-attachments (f wrld)

; The implementation of this function uses hons-acons, so might only be
; efficient when #+hons (which was its intended use when written).

  (let ((g (canonical-sibling f wrld)))
    (ext-ancestors-attachments1 (cons g
                                      (canonical-ancestors g wrld nil))
                                nil
                                (attachment-records-fal
                                 (global-val 'attachment-records wrld)
                                 :attachment-records-fal)
                                wrld
                                f)))

(defun ext-anc-attachment-missing (alist wrld)

; See ext-anc-attachments-valid-p.

  (cond ((endp alist) nil)
        ((eq (cdar alist)
             (cdr (attachment-pair (caar alist) wrld)))
         (ext-anc-attachment-missing (cdr alist) wrld))
        (t (caar alist))))

(defun ext-anc-attachments-valid-p-1 (fns alist wrld)

; See ext-anc-attachments-valid-p.  We assume that for every pair (f . g) in
; alist, g is the attachment of f in wrld.

  (cond ((endp fns) t)
        ((or (assoc-eq (car fns) alist)
             (not (attachment-pair (car fns) wrld)))
         (ext-anc-attachments-valid-p-1 (cdr fns) alist wrld))
        (t nil)))

(defun ext-anc-attachments-valid-p (fns ext-anc-attachments 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))
             (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 f wrld)
                                                 alist
                                                 wrld))))))))

; Start definitions related to defun-inline.

; (defconst *inline-suffix* "$INLINE") ; moved above ec-call1-raw
(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 (add-suffix name suffix))
         (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)

; Implementor hint for "(5) Obscure Remark" in :DOC defun-inline 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.

  (defun-inline-form name formals lst 'defund *inline-suffix*))

(defmacro defun-notinline (name formals &rest lst)

; Warning: Keep this in sync with defund-notinline.

  (defun-inline-form name formals lst 'defun *notinline-suffix*))

(defmacro defund-notinline (name formals &rest lst)

; Warning: Keep this in sync with defun-inline.

  (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 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
      "( REGENERATE-TAU-DATABASE)")
    (let* ((wrld (w state))
           (event-form (or event-form
                           '(REGENERATE-TAU-DATABASE)))
           (boot-strap-auto-modep (cdar *tau-status-boot-strap-settings*))
           (user-auto-modep (tau-auto-modep wrld))
           (ens (ens state)))

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

      (er-let*
        ((wrld1 (regenerate-tau-database-fn1 boot-strap-auto-modep
                                             user-auto-modep
                                             ens ctx wrld state))
         (val (install-event t
                             event-form
                             'regenerate-tau-database
                             0
                             nil
                             nil
                             :protect
                             nil
                             wrld1 state)))
        (value t))))))

; Next comes support for time-tracker (but see axioms.lisp for
; time-tracker-fn).

(defun rational-to-decimal-string (x state)
  (declare (xargs :mode :program
                  :stobjs state
                  :guard (rationalp x)))
  (mv-let (channel state)
          (open-output-channel :string :character state)
          (pprogn (print-rational-as-decimal x channel state)
                  (er-let* ((str (get-output-stream-string$
                                  channel state nil)))
                           (pprogn (close-output-channel channel state)
                                   (value str))))))

#-acl2-loop-only
(progn

(defvar *time-tracker-alist* nil)

(defvar *time-tracker-disabled-p* nil)

(defstruct time-tracker

; When this structure is created for a given tag, Init is set to the current
; run-time.  Tracking is on when Latest is non-nil, in which case Latest marks
; the run-time at the time time-tracker was turned on (for an implicitly
; associated tag) with option :init.  Elapsed marks the total elapsed run-time
; accumulated with tracking active, except that if tracking is currently
; inactive (i.e., :latest is non-nil), then Elapsed does not include the
; run-time since Latest.  Times and Interval come from the :init option of
; time-tracker, though Times may have been cdr'ed; so these are a true-list of
; rationals and either a rational or nil, respectively.

; The Msg field is marked as :read-only simply because we currently see no
; reason to update that field.

  (init ; reset by :init
   (get-internal-time) :type rational :read-only t)
  (latest   ; reset by :init, :stop, and :start
   nil :type (or null rational))
  (elapsed  ; total time tracked, updated when updating Latest
   0 :type rational)
  (msg
   nil :read-only t)
  (times    ; can be updated by time-tracker with option :print?
   nil :type (satisfies rational-listp))
  (interval ; if non-nil, used for updating an 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.  Evaluate (~x1 '~x0 :INIT ...) to solve this ~
           problem.  See :DOC time-tracker."
          tag
          'time-tracker))
     ((not latest)
      (er hard 'time-tracker
          "It is illegal to specify :STOP for tag ~x0, because tracking for ~
           this tag is already in an inactive state.  Evaluate ~x1 to solve ~
           this problem.  See :DOC time-tracker."
          tag
          `(time-tracker ',tag :start)))
     (t (setf (time-tracker-elapsed tt)
              (+ (time-tracker-elapsed tt)
                 (- (get-internal-time) latest)))
        (setf (time-tracker-latest tt)
              nil)))))

(defun tt-start (tag &optional do-it)
  (let ((tt (cdr (assoc-eq tag *time-tracker-alist*))))
    (cond
     ((not tt)
      (er hard 'time-tracker
          "It is illegal to specify :START for tag ~x0, because this tag is ~
           not being tracked.  Evaluate (~x1 '~x0 :INIT ...) to solve this ~
           problem.  See :DOC time-tracker."
          tag
          'time-tracker))
     ((and (time-tracker-latest tt)
           (or (not do-it)
               (and (eval `(time-tracker ',tag :stop))
                    nil)))
      (er hard 'time-tracker
          "It is illegal to specify :START for tag ~x0, because tracking for ~
           this tag is already in an active state.  Evaluate ~x1 to solve ~
           this problem.  See :DOC time-tracker."
          tag
          `(time-tracker ',tag :stop)))
     (t (setf (time-tracker-latest tt)
              (get-internal-time))))))
)

; We originally defined defund in axioms.lisp, but now that its definition
; depends on remove-strings and other functions defined after axioms.lisp, we
; define it here.

#+acl2-loop-only
(defmacro defund (&rest def)
  (declare (xargs :guard (and (true-listp def)
                              (symbolp (car def))
                              (symbol-listp (cadr def)))))

  `(with-output
     :stack :push :off (summary event)
     (progn (with-output :stack :pop (defun ,@def))
            ,@(and (not (program-declared-p def))
                   `((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)

; Warning: Do not allow this function to modify state without reading the
; comment in chk-logic-subfunctions showing that if trans-eval is in :logic
; mode, then user-defined stobjs can be changed in a way inconsistent with
; logical definitions.

  (let ((wrld (w state)))
    (cond
     ((and (symbolp fn)
           (true-listp args)
           (let ((formals
                  (getpropc fn 'formals t 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
      (let ((msg
             (msg "~%~%Meta-level function Problem: Magic-ev-fncall attempted ~
                   to apply ~X02 to argument list ~X12.  This is illegal ~
                   because ~@3.  The meta-level function computation was ~
                   ignored.~%~%"
                  fn
                  args
                  (abbrev-evisc-tuple *the-live-state*)
                  (cond
                   ((not (symbolp fn))
                    (msg "~x0 is not a symbol" fn))
                   ((not (true-listp args))
                    (msg "that argument list is not a true list"))
                   ((eq (getpropc fn 'formals t wrld) t)
                    (msg "~x0 is not a known function symbol in the current ~
                          ACL2 logical world"
                         fn))
                   ((not (eql (length args)
                              (length (getpropc fn 'formals t wrld))))
                    (msg "The length of that args is ~x0, but ~x1 takes ~x2 ~
                          arguments"
                         (length args)
                         fn
                         (length (getpropc fn 'formals t wrld))))
                   (t
                    (assert (not (logicalp fn wrld)))
                    (msg "~x0 is not a logic-mode function symbol"
                         fn))))))
        (prog2$ (cw "~@0" msg)
                (mv t msg)))))))

(defun make-event-ctx (event-form)
  (msg "( MAKE-EVENT ~@0~@1)"
       (tilde-@-abbreviate-object-phrase (cadr event-form))
       (if (cddr event-form) " ..." "")))

(defun protected-eval (form on-behalf-of ctx state aok)

; We assume that this is executed under a revert-world-on-error, so that we do
; not have to protect the world here in case of error, though we do set the
; world back to the starting world when returning a non-erroneous error triple.
; Form should evaluate either to an ordinary value, val, or to (mv nil val
; state stobj1 ... stobjk), where k may be 0.  If so, we return (value (list*
; val new-kpa new-ttags-seen)), where new-kpa and new-ttags-seen are the
; known-package-alist and value of world global 'ttags-seen immediately after
; form is evaluated; and if not, we return a soft error.

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

(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))) 
              (expansion1b
               (value (or expansion1a

; Else the alleged embedded event form, from the expansion, is nil, presumably
; because of local.

                          *local-value-triple-elided*)))
              (stobjs-out-and-raw-result
               (do-proofs?
                do-proofsp
                (trans-eval

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

                 expansion1b
                 ctx state t))))
      (let ((raw-result (cdr stobjs-out-and-raw-result)))
        (cond ((car raw-result)
               (silent-error state))
              (t (let ((expansion1
                        (if (f-get-global 'boot-strap-flg state)
                            expansion1b
                          (make-include-books-absolute
                           expansion1b
                           (cbd)
                           nil
                           (primitive-event-macros)
                           nil ctx state))))
                   (value (list* expansion1
                                 (car stobjs-out-and-raw-result)
                                 (cadr raw-result))))))))))

(defun make-event-fn2-lst (expansion-lst whole-form in-encapsulatep
                                         check-expansion 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))
            (not expansion?)

; This case should not happen, because all make-event forms should already be
; expanded away when we do the Convert procedure of provisional certification,
; since a suitable expansion-alist should have been stored in the .pcert0 file.
; We include this check just for robustness.

            (eql (f-get-global 'make-event-debug-depth state)

; We only enforce the above consp requirement at the top-level.  If we have
; (make-event ... :check-expansion exp ...), and this event is admissible
; (perhaps when skipping proofs) then we know that the result will be exp and
; will be independent of the current state.  In particular, exp will not be a
; call of make-event if form is admissible.

                 0))
       (er soft ctx
           "Implementation error: You should not be seeing this message!  ~
            Please contact the ACL2 implementors.~|~%Make-event expansion is ~
            illegal during the Convert procedure of provisional certification ~
            (unless :check-expansion is supplied a consp argument or ~
            :expansion? is supplied a non-nil argument).  The form ~x0 is ~
            thus illegal.  The use of a .acl2x file can sometimes solve this ~
            problem.  See :DOC provisional-certification."
           whole-form))
      ((not (or (eq check-expansion nil)
                (eq check-expansion t)
                (consp check-expansion)))
       (er soft ctx
           "The check-expansion flag of make-event must be t, nil, or a cons ~
            pair.  The following check-expansion flag is thus illegal: ~x0.  ~
            See :DOC make-event."
           check-expansion))
      ((and expansion?
            (consp check-expansion))

; We considered allowing :EXPANSION? FORM1 and :CHECK-EXPANSION FORM2 (where
; FORM2 is not nil or t), and if someone presents a natural example for which
; this would be useful, we might do so.  But the semantics of this would be
; potentially confusing.  Which one is consulted when including a book or
; running in raw Lisp?  If FORM1 = FORM2, this looks redundant.  Otherwise,
; this is, oddly, inherently contradictory, in the sense that FORM1 should
; never be the expansion (unless one is deliberately arranging for evaluation
; of the make-event call to fail -- but there are simpler ways to do that).

; If we decide to support the combination of expansion? and (consp
; check-expansion), then we need to be careful to handle that combination --
; something we don't do now, but we code defensively, giving priority to (consp
; check-expansion).

       (er soft ctx
           "It is illegal to supply a non-nil value for the keyword argument ~
            :EXPANSION? of make-event when keyword argument :CHECK-EXPANSION ~
            is give a value other than T or NIL.  If you think you have a ~
            reason why such a combination should be supported, please contact ~
            the ACL2 implementors."))
      (t
       (revert-world-on-error
        (state-global-let*
         ((make-event-debug-depth (1+ (f-get-global 'make-event-debug-depth
                                                    state))))
         (let ((wrld (w state))
               (skip-check-expansion
                (and (consp check-expansion)
                     (let ((info (f-get-global 'certify-book-info state)))
                       (and info
                            (access certify-book-info info
                                    :include-book-phase))))))
           (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)
                        (not (f-get-global 'including-uncertified-p state))

; Even if expansion? is specified, we do not assume it's right if
; check-expansion is t.

                        (assert$ (iff check-expansion

; In code above, we disallowed the combination of non-nil expansion? with a
; consp value of :check-expansion.

                                      (eq check-expansion t))
                                 (not (eq check-expansion t))))
                   (value (list* expansion? nil nil)))
                  (skip-check-expansion
                   (value (list* check-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)))
                (need-event-landmark-p
                 (pprogn
                  (make-event-debug-post debug-depth expansion0 state)
                  (cond ((or (null new-ttags-seen)

; The condition above holds when the new ttags-seen is nil or was not computed.
; Either way, no addition has been made to the value of world global
; 'ttags-seen.

                             (equal new-ttags-seen
                                    (global-val 'ttags-seen wrld)))
                         (value nil))
                        (t (pprogn
                            (set-w 'extension
                                   (global-set 'ttags-seen new-ttags-seen
                                               wrld)
                                   state)
                            (value t))))))
                (wrld0 (value (w state)))
                (expansion1/stobjs-out/result
                 (make-event-fn1
                  expansion0 whole-form
                  (in-encapsulatep (global-val 'embedded-event-lst wrld0) nil)
                  check-expansion 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 (need-event-landmark-p ; optimization

; We lay down an event landmark if we aren't already looking at one.  Before we
; did so, an error was reported by print-redefinition-warning in the following
; example, because we weren't looking at an event landmark.

; (redef!)
; (make-event (er-progn (defttag t)
;                       (value '(value-triple nil))))

                                    (maybe-add-event-landmark state))
                                   (t (value nil)))
                             (value result))))))))))))))))))

(defun get-check-invariant-risk (state)
  (let ((pair (assoc-eq :check-invariant-risk
                        (table-alist 'acl2-defaults-table (w state))))
        (cir (f-get-global 'check-invariant-risk state)))
    (cond (pair (case (cdr pair) ; then take the "minimum" with cir
                  ((:ERROR :CLEAR) cir)
                  ((:WARNING) (if (eq cir :ERROR) :WARNING cir))
                  ((T) (if (eq cir nil) nil t))
                  (otherwise nil)))
          (t cir))))

(defmacro set-check-invariant-risk (x &optional table-p)

; In oneify-cltl-code we handle an "invariant-risk" that stobj invariants
; aren't violated upon ill-guarded calls of stobj updaters.  The idea is to
; force evaluation to use *1* functions down to those primitives, which always
; check their guards.  See also the comment in **1*-as-raw*.  Note that this
; is a separate issue from the lack of atomicity of some defabsstobj exports
; (which is implemented using *inside-absstobj-update*).

; There may be cases where this use of *1* functions may be slower than one
; likes.  By setting the invariant-risk mode to nil, one defeats that behavior;
; see :DOC set-check-invariant-risk.  This could be unsound, but since one
; needs an active trust tag to set this global, we take the position that
; setting it is much like redefining prove so that one always gets the "Q.E.D."

; Perhaps we will consider avoiding this use of *1* functions when the only
; danger of invariant violations is from local stobjs.  Since only :program
; mode functions are at issue (because a :logic mode function call only slips
; into raw Lisp when the function has been guard-verified and the call is
; guard-checked, and because raw-ev-fncall binds **1*-as-raw* to nil for
; :logic mode functions), it seems plausible that we can provide this
; optimization for local stobjs.  After all, local stobjs are let-bound rather
; than global; so it seems that during proofs, any local stobj encountered will
; either be created and destroyed during a computed hint or else will be
; modified only by :logic mode functions manipulated by the prover.  (Trusted
; clause processors might provide an exception, but then trust tags are
; involved, so it's their responsibility to do the right thing.)

; But we'll leave that for another day, if at all, as it seems risky and
; error-prone to implement.  In particular, we would likely need to track
; invariant-risk on a per-stobj basis, and built-ins (see
; initialize-invariant-risk) might not be associated with stobjs at all.

  (declare (xargs :guard (booleanp table-p)))
  (cond
   (table-p
    `(with-output
      :off :all :on (observation error)
      (progn (table acl2-defaults-table :check-invariant-risk ,x)
             (make-event
              (pprogn (if (and (not (eq ,x (get-check-invariant-risk state)))
                               (not (eq ,x :CLEAR)))
                          (observation 'set-check-invariant-risk
                                       "No change is being made in the value ~
                                        computed by ~x0.  This happens when ~
                                        the value of state global ~
                                        'check-invariant-risk is less than ~
                                        the new table value; see :DOC ~
                                        set-check-invariant-risk."
                                       '(get-check-invariant-risk state))
                        state)
                      (value '(value-triple ,x)))
              :check-expansion t))))
   ((and x (member-eq x *check-invariant-risk-values*))
    `(set-check-invariant-risk-fn ,x state))
   (t `(cond
        ((not (member-eq ,x '(t nil :ERROR :WARNING)))
         (er soft 'check-invariant-risk
             "Illegal value for ~x0: ~x1"
             'check-invariant-risk
             ',x))
        (t (er-progn
            (with-ubt!
             (with-output
              :off :all
              (with-output
               :on (error warning warning!)
               (progn (defttag :set-check-invariant-risk)
                      (progn! (set-check-invariant-risk-fn ,x state))))))
            (value nil)))))))

(defun set-check-invariant-risk-fn (x state)
  (declare (xargs :guard (member-eq x *check-invariant-risk-values*)))
  (progn$ (mbt (and (member-eq x *check-invariant-risk-values*) t))
          (cond ((and (null x)
                      (f-get-global 'check-invariant-risk state)
                      (not (ttag (w state))))
                 (er soft 'set-check-invariant-risk
                     "There must be an active trust tag to set '~x0 to ~x1."
                     'check-invariant-risk nil))
                (t (pprogn
                    (f-put-global 'check-invariant-risk x state)
                    (if (not (eq x (get-check-invariant-risk state)))
                        (observation 'set-check-invariant-risk
                                     "No change is being made in the value ~
                                      computed by ~x0, because the new value ~
                                      of state global 'check-invariant-risk ~
                                      is greater than the table value; see ~
                                      :DOC set-check-invariant-risk."
                                     '(get-check-invariant-risk state))
                      state)
                    (value x))))))

; read-file-into-string (must come after with-local-state is defined)

(defun read-file-into-string1 (channel state ans bound)

; Channel is an open input characater channel.  We read all the characters in
; the file and return the list of them.

  (declare (xargs :stobjs state
                  :guard (and (symbolp channel)
                              (open-input-channel-p channel :character state)
                              (character-listp ans)
                              (natp bound))
                  :measure (acl2-count bound)))
  (cond ((zp bound) ; file is too large
         (mv nil state))
        (t (mv-let
            (val state)
            (read-char$ channel state)
            (cond ((not (characterp val)) ; end of file
                   (mv (coerce (reverse ans) 'string)
                       state))
                  (t (read-file-into-string1 channel state (cons val ans)
                                             (1- bound))))))))

(defconst *read-file-into-string-bound*

; We rather arbitrarily set this value to the largest 64-bit CCL fixnum.  It is
; a strict upper bound on the size of a string we are willing to return from
; read-file-into-string, and it serves as a termination bound for our call of
; read-file-into-string1 inside read-file-into-string.

  (1- (ash 1 60)))

(encapsulate ()

(local
 (defthm stringp-read-file-into-string1
   (implies (car (read-file-into-string1 channel state ans bound))
            (stringp (car (read-file-into-string1 channel state ans bound))))))

(defun read-file-into-string2 (filename state)

; Parallelism wart: avoid potential illegal behavior caused by this function.
; A simple but expensive solution is probably to add a lock.  But with some
; thought one might provide for correct parallel evaluations of this function.
; Perhaps that's already the case!

  (declare (xargs :stobjs state :guard (stringp filename)))
  #-acl2-loop-only
  (declare (ignore state))
  #-acl2-loop-only
  (with-open-file
    (stream filename :direction :input :if-does-not-exist nil)
    (and stream
         (let ((len (file-length stream)))
           (and (< len *read-file-into-string-bound*)
                (let ((fwd (file-write-date filename)))
                  (or (check-against-read-file-alist filename fwd)
                      (push (cons filename fwd)
                            *read-file-alist*))

; The following #-acl2-loop-only code, minus the WHEN clause, is based on code
; found at http://www.ymeme.com/slurping-a-file-common-lisp-83.html and was
; authored by @sabetts, who is apparently Shawn Betts.  The URL above presents
; five implementations of file slurping and I found the discussion truly
; excellent.  Thank you @sabetts!

; The URL above says ``You can do anything you like with the code.''

                  (let ((seq (make-string len)))
                    (declare (type string seq))
                    (read-sequence seq stream)
                    (when (not (eql fwd (file-write-date filename)))
                      (error "Illegal attempt to call ~s concurrently with ~
                              some write to that file!~%See :DOC ~
                              read-file-into-string."
                             'read-file-into-string))
                    seq))))))
  #+acl2-loop-only
  (let* ((st (coerce-state-to-object state)))
    (mv-let
      (erp val)
      (with-local-state
       (mv-let
         (erp val state)
         (let ((state (coerce-object-to-state st)))
           (mv-let
             (chan state)
             (open-input-channel filename :character state)
             (cond
              ((or (null chan)
; The following is to simplify guard verification.
                   (not (state-p state)))
               (mv nil nil state))
              (t (pprogn
                  (f-put-global 'guard-checking-on t state)
                  (mv-let
                    (val state)
                    (ec-call ; guard verification here seems unimportant
                     (read-file-into-string1 chan state nil
                                             *read-file-into-string-bound*))
                    (pprogn
                     (ec-call ; guard verification here seems unimportant
                      (close-input-channel chan state))
                     (mv nil val state))))))))
         (mv erp val)))
      (declare (ignore erp))
      val)))
)

(defun read-file-into-string (filename state)
  (declare (xargs :stobjs state :guard (stringp filename)))
  (and (mbt (stringp filename))
       (read-file-into-string2 filename state)))