acl2-source 6.3-5 / usr / share / acl2-6.3 / axioms.lisp

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

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

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

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

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

; This file, axioms.lisp, serves two purposes.  First, it describes
; the theory of ACL2 by enumerating the axioms and definitions.
; Second, it implements in Common Lisp those functions of the theory
; which are not already provided in Common Lisp.  In some cases, the
; implementation of a function is identical to its axiomatization (cf.
; implies).  In other cases, we provide functions whose semantics are
; applicative but whose implementations are decidely ``von
; Neumann-esque''.  For example, we implement the array, property
; list, and io primitives with non-applicative techniques.

; This file is read by Common Lisp in two ways.  First, we bring ACL2
; into its initial state with the function boot-strap, which loads
; this file.  Second, this file is read and compiled in the
; implementation of ACL2 itself.  To support these two readings, we
; use the #+ and #- read macro feature of Common Lisp.  While we are
; loading this file in boot-strap, we arrange for *features* to
; contain the symbol :acl2-loop-only; otherwise, *features* does not
; contain :acl2-loop-only.  Thus, during boot-strap, forms immediately
; preceded by #+acl2-loop-only are ``seen'', whereas those
; immediately preceded by #-acl2-loop-only are invisible.  The
; converse is true when we are compiling and loading the code for
; ACL2.

; If a symbol described in CLTL is axiomatized here, then we give it
; exactly the same semantics as it has in CLTL, under restrictions for
; which we check.  (Actually, this is currently a lie about DEFUN,
; DEFMACRO, and PROGN, but we will provide someday a check that that
; those are only used in files in ways such that their ACL2 and Common
; Lisp meanings are prefectly consistent.)  Thus, when we talk about
; +, we really mean the Common Lisp +.  However, our + does not handle
; floating point numbers, so there is a guard on + that checks that
; its args are rationals.  The symbols in the list
; acl2::*common-lisp-symbols-from-main-lisp-package* are the symbols
; that we take as having a meaning in Common Lisp.  If a user wishes
; access to these in a package, then he can use the permanent value of
; the global *common-lisp-symbols-from-main-lisp-package* as an import
; list for defpkg.

; If we use a symbol that has a $ suffix, it is a symbol we have
; defined with a meaning that it is similar to the Common Lisp symbol
; without the $ suffix, but different in some way, e.g. princ$ takes a
; state arg and returns a state.

(in-package "ACL2")

; Leave the following as the second form in axioms.lisp.  It is read
; by acl2.lisp.  Leave the acl2:: prefix there, too.

; We are aware that as of this writing, various Lisp implementations deviate
; from the dpANS specification of the external symbols of the main Lisp
; package.  However, we will guarantee that variable names and logical names
; that lie in the main Lisp package will all come from this list, and in the
; case of variables, we will guarantee that they are not special variables.
; Note that however we handle this constant, it is crucial that its value be
; independent of the implementation, lest we can prove something about its
; length (say) in one Lisp that is false in another.  Our requirement on this
; list is that it allow the compiler to deal correctly with Common Lisp functions
; such as CAR that we are bringing into the ACL2 environment, and the dpANS list
; certainly satisfies that requirement.

(acl2::defconst acl2::*common-lisp-symbols-from-main-lisp-package*

; From the info page for dpANS, node "Symbols in the COMMON-LISP Package."
; The comments are from that page as well, though we have inserted "; "
; in front of each.

 '(

; The figures on the next twelve pages contain a complete enumeration of the
; 978 external symbols in the COMMON-LISP package.

  &allow-other-keys            *print-miser-width*
  &aux                         *print-pprint-dispatch*
  &body                        *print-pretty*
  &environment                 *print-radix*
  &key                         *print-readably*
  &optional                    *print-right-margin*
  &rest                        *query-io*
  &whole                       *random-state*
  *                            *read-base*
  **                           *read-default-float-format*
  ***                          *read-eval*
  *break-on-signals*           *read-suppress*
  *compile-file-pathname*      *readtable*
  *compile-file-truename*      *standard-input*
  *compile-print*              *standard-output*
  *compile-verbose*            *terminal-io*
  *debug-io*                   *trace-output*
  *debugger-hook*              +
  *default-pathname-defaults*  ++
  *error-output*               +++
  *features*                   -
  *gensym-counter*             /
  *load-pathname*              //
  *load-print*                 ///
  *load-truename*              /=
  *load-verbose*               1+
  *macroexpand-hook*           1-
  *modules*                    <
  *package*                    <=
  *print-array*                =
  *print-base*                 >
  *print-case*                 >=
  *print-circle*               abort
  *print-escape*               abs
  *print-gensym*               acons
  *print-length*               acos
  *print-level*                acosh
  *print-lines*                add-method

;   Figure 1-4: Symbols in the COMMON-LISP package (part one of twelve).


  adjoin                      atom          boundp
  adjust-array                base-char     break
  adjustable-array-p          base-string   broadcast-stream
  allocate-instance           bignum        broadcast-stream-streams
  alpha-char-p                bit           built-in-class
  alphanumericp               bit-and       butlast
  and                         bit-andc1     byte
  append                      bit-andc2     byte-position
  apply                       bit-eqv       byte-size
  apropos                     bit-ior       caaaar
  apropos-list                bit-nand      caaadr
  aref                        bit-nor       caaar
  arithmetic-error            bit-not       caadar
  arithmetic-error-operands   bit-orc1      caaddr
  arithmetic-error-operation  bit-orc2      caadr
  array                       bit-vector    caar
  array-dimension             bit-vector-p  cadaar
  array-dimension-limit       bit-xor       cadadr
  array-dimensions            block         cadar
  array-displacement          boole         caddar
  array-element-type          boole-1       cadddr
  array-has-fill-pointer-p    boole-2       caddr
  array-in-bounds-p           boole-and     cadr
  array-rank                  boole-andc1   call-arguments-limit
  array-rank-limit            boole-andc2   call-method
  array-row-major-index       boole-c1      call-next-method
  array-total-size            boole-c2      car
  array-total-size-limit      boole-clr     case
  arrayp                      boole-eqv     catch
  ash                         boole-ior     ccase
  asin                        boole-nand    cdaaar
  asinh                       boole-nor     cdaadr
  assert                      boole-orc1    cdaar
  assoc                       boole-orc2    cdadar
  assoc-if                    boole-set     cdaddr
  assoc-if-not                boole-xor     cdadr
  atan                        boolean       cdar
  atanh                       both-case-p   cddaar

;   Figure 1-5: Symbols in the COMMON-LISP package (part two of twelve).


  cddadr             clear-input                  copy-tree
  cddar              clear-output                 cos
  cdddar             close                        cosh
  cddddr             clrhash                      count
  cdddr              code-char                    count-if
  cddr               coerce                       count-if-not
  cdr                compilation-speed            ctypecase
  ceiling            compile                      debug
  cell-error         compile-file                 decf
  cell-error-name    compile-file-pathname        declaim
  cerror             compiled-function            declaration
  change-class       compiled-function-p          declare
  char               compiler-macro               decode-float
  char-code          compiler-macro-function      decode-universal-time
  char-code-limit    complement                   defclass
  char-downcase      complex                      defconstant
  char-equal         complexp                     defgeneric
  char-greaterp      compute-applicable-methods   define-compiler-macro
  char-int           compute-restarts             define-condition
  char-lessp         concatenate                  define-method-combination
  char-name          concatenated-stream          define-modify-macro
  char-not-equal     concatenated-stream-streams  define-setf-expander
  char-not-greaterp  cond                         define-symbol-macro
  char-not-lessp     condition                    defmacro
  char-upcase        conjugate                    defmethod
  char/=             cons                         defpackage
  char<              consp                        defparameter
  char<=             constantly                   defsetf
  char=              constantp                    defstruct
  char>              continue                     deftype
  char>=             control-error                defun
  character          copy-alist                   defvar
  characterp         copy-list                    delete
  check-type         copy-pprint-dispatch         delete-duplicates
  cis                copy-readtable               delete-file
  class              copy-seq                     delete-if
  class-name         copy-structure               delete-if-not
  class-of           copy-symbol                  delete-package

;     Figure 1-6: Symbols in the COMMON-LISP package (part three of twelve).


  denominator                    eq
  deposit-field                  eql
  describe                       equal
  describe-object                equalp
  destructuring-bind             error
  digit-char                     etypecase
  digit-char-p                   eval
  directory                      eval-when
  directory-namestring           evenp
  disassemble                    every
  division-by-zero               exp
  do                             export
  do*                            expt
  do-all-symbols                 extended-char
  do-external-symbols            fboundp
  do-symbols                     fceiling
  documentation                  fdefinition
  dolist                         ffloor
  dotimes                        fifth
  double-float                   file-author
  double-float-epsilon           file-error
  double-float-negative-epsilon  file-error-pathname
  dpb                            file-length
  dribble                        file-namestring
  dynamic-extent                 file-position
  ecase                          file-stream
  echo-stream                    file-string-length
  echo-stream-input-stream       file-write-date
  echo-stream-output-stream      fill
  ed                             fill-pointer
  eighth                         find
  elt                            find-all-symbols
  encode-universal-time          find-class
  end-of-file                    find-if
  endp                           find-if-not
  enough-namestring              find-method
  ensure-directories-exist       find-package
  ensure-generic-function        find-restart

;   Figure 1-7: Symbols in the COMMON-LISP package (part four of twelve).


  find-symbol                       get-internal-run-time
  finish-output                     get-macro-character
  first                             get-output-stream-string
  fixnum                            get-properties
  flet                              get-setf-expansion
  float                             get-universal-time
  float-digits                      getf
  float-precision                   gethash
  float-radix                       go
  float-sign                        graphic-char-p
  floating-point-inexact            handler-bind
  floating-point-invalid-operation  handler-case
  floating-point-overflow           hash-table
  floating-point-underflow          hash-table-count
  floatp                            hash-table-p
  floor                             hash-table-rehash-size
  fmakunbound                       hash-table-rehash-threshold
  force-output                      hash-table-size
  format                            hash-table-test
  formatter                         host-namestring
  fourth                            identity
  fresh-line                        if
  fround                            ignorable
  ftruncate                         ignore
  ftype                             ignore-errors
  funcall                           imagpart
  function                          import
  function-keywords                 in-package
  function-lambda-expression        incf
  functionp                         initialize-instance
  gcd                               inline
  generic-function                  input-stream-p
  gensym                            inspect
  gentemp                           integer
  get                               integer-decode-float
  get-decoded-time                  integer-length
  get-dispatch-macro-character      integerp
  get-internal-real-time            interactive-stream-p

;   Figure 1-8: Symbols in the COMMON-LISP package (part five of twelve).


  intern                                  lisp-implementation-type
  internal-time-units-per-second          lisp-implementation-version
  intersection                            list
  invalid-method-error                    list*
  invoke-debugger                         list-all-packages
  invoke-restart                          list-length
  invoke-restart-interactively            listen
  isqrt                                   listp
  keyword                                 load
  keywordp                                load-logical-pathname-translations
  labels                                  load-time-value
  lambda                                  locally
  lambda-list-keywords                    log
  lambda-parameters-limit                 logand
  last                                    logandc1
  lcm                                     logandc2
  ldb                                     logbitp
  ldb-test                                logcount
  ldiff                                   logeqv
  least-negative-double-float             logical-pathname
  least-negative-long-float               logical-pathname-translations
  least-negative-normalized-double-float  logior
  least-negative-normalized-long-float    lognand
  least-negative-normalized-short-float   lognor
  least-negative-normalized-single-float  lognot
  least-negative-short-float              logorc1
  least-negative-single-float             logorc2
  least-positive-double-float             logtest
  least-positive-long-float               logxor
  least-positive-normalized-double-float  long-float
  least-positive-normalized-long-float    long-float-epsilon
  least-positive-normalized-short-float   long-float-negative-epsilon
  least-positive-normalized-single-float  long-site-name
  least-positive-short-float              loop
  least-positive-single-float             loop-finish
  length                                  lower-case-p
  let                                     machine-instance
  let*                                    machine-type

;      Figure 1-9: Symbols in the COMMON-LISP package (part six of twelve).


  machine-version                mask-field
  macro-function                 max
  macroexpand                    member
  macroexpand-1                  member-if
  macrolet                       member-if-not
  make-array                     merge
  make-broadcast-stream          merge-pathnames
  make-concatenated-stream       method
  make-condition                 method-combination
  make-dispatch-macro-character  method-combination-error
  make-echo-stream               method-qualifiers
  make-hash-table                min
  make-instance                  minusp
  make-instances-obsolete        mismatch
  make-list                      mod
  make-load-form                 most-negative-double-float
  make-load-form-saving-slots    most-negative-fixnum
  make-method                    most-negative-long-float
  make-package                   most-negative-short-float
  make-pathname                  most-negative-single-float
  make-random-state              most-positive-double-float
  make-sequence                  most-positive-fixnum
  make-string                    most-positive-long-float
  make-string-input-stream       most-positive-short-float
  make-string-output-stream      most-positive-single-float
  make-symbol                    muffle-warning
  make-synonym-stream            multiple-value-bind
  make-two-way-stream            multiple-value-call
  makunbound                     multiple-value-list
  map                            multiple-value-prog1
  map-into                       multiple-value-setq
  mapc                           multiple-values-limit
  mapcan                         name-char
  mapcar                         namestring
  mapcon                         nbutlast
  maphash                        nconc
  mapl                           next-method-p
  maplist                        nil

;   Figure 1-10: Symbols in the COMMON-LISP package (part seven of twelve).


  nintersection         package-error
  ninth                 package-error-package
  no-applicable-method  package-name
  no-next-method        package-nicknames
  not                   package-shadowing-symbols
  notany                package-use-list
  notevery              package-used-by-list
  notinline             packagep
  nreconc               pairlis
  nreverse              parse-error
  nset-difference       parse-integer
  nset-exclusive-or     parse-namestring
  nstring-capitalize    pathname
  nstring-downcase      pathname-device
  nstring-upcase        pathname-directory
  nsublis               pathname-host
  nsubst                pathname-match-p
  nsubst-if             pathname-name
  nsubst-if-not         pathname-type
  nsubstitute           pathname-version
  nsubstitute-if        pathnamep
  nsubstitute-if-not    peek-char
  nth                   phase
  nth-value             pi
  nthcdr                plusp
  null                  pop
  number                position
  numberp               position-if
  numerator             position-if-not
  nunion                pprint
  oddp                  pprint-dispatch
  open                  pprint-exit-if-list-exhausted
  open-stream-p         pprint-fill
  optimize              pprint-indent
  or                    pprint-linear
  otherwise             pprint-logical-block
  output-stream-p       pprint-newline
  package               pprint-pop

;   Figure 1-11: Symbols in the COMMON-LISP package (part eight of twelve).


  pprint-tab                 read-char
  pprint-tabular             read-char-no-hang
  prin1                      read-delimited-list
  prin1-to-string            read-from-string
  princ                      read-line
  princ-to-string            read-preserving-whitespace
  print                      read-sequence
  print-not-readable         reader-error
  print-not-readable-object  readtable
  print-object               readtable-case
  print-unreadable-object    readtablep
  probe-file                 real
  proclaim                   realp
  prog                       realpart
  prog*                      reduce
  prog1                      reinitialize-instance
  prog2                      rem
  progn                      remf
  program-error              remhash
  progv                      remove
  provide                    remove-duplicates
  psetf                      remove-if
  psetq                      remove-if-not
  push                       remove-method
  pushnew                    remprop
  quote                      rename-file
  random                     rename-package
  random-state               replace
  random-state-p             require
  rassoc                     rest
  rassoc-if                  restart
  rassoc-if-not              restart-bind
  ratio                      restart-case
  rational                   restart-name
  rationalize                return
  rationalp                  return-from
  read                       revappend
  read-byte                  reverse

;   Figure 1-12: Symbols in the COMMON-LISP package (part nine of twelve).


  room                          simple-bit-vector
  rotatef                       simple-bit-vector-p
  round                         simple-condition
  row-major-aref                simple-condition-format-arguments
  rplaca                        simple-condition-format-control
  rplacd                        simple-error
  safety                        simple-string
  satisfies                     simple-string-p
  sbit                          simple-type-error
  scale-float                   simple-vector
  schar                         simple-vector-p
  search                        simple-warning
  second                        sin
  sequence                      single-float
  serious-condition             single-float-epsilon
  set                           single-float-negative-epsilon
  set-difference                sinh
  set-dispatch-macro-character  sixth
  set-exclusive-or              sleep
  set-macro-character           slot-boundp
  set-pprint-dispatch           slot-exists-p
  set-syntax-from-char          slot-makunbound
  setf                          slot-missing
  setq                          slot-unbound
  seventh                       slot-value
  shadow                        software-type
  shadowing-import              software-version
  shared-initialize             some
  shiftf                        sort
  short-float                   space
  short-float-epsilon           special
  short-float-negative-epsilon  special-operator-p
  short-site-name               speed
  signal                        sqrt
  signed-byte                   stable-sort
  signum                        standard
  simple-array                  standard-char
  simple-base-string            standard-char-p

;   Figure 1-13: Symbols in the COMMON-LISP package (part ten of twelve).


  standard-class             sublis
  standard-generic-function  subseq
  standard-method            subsetp
  standard-object            subst
  step                       subst-if
  storage-condition          subst-if-not
  store-value                substitute
  stream                     substitute-if
  stream-element-type        substitute-if-not
  stream-error               subtypep
  stream-error-stream        svref
  stream-external-format     sxhash
  streamp                    symbol
  string                     symbol-function
  string-capitalize          symbol-macrolet
  string-downcase            symbol-name
  string-equal               symbol-package
  string-greaterp            symbol-plist
  string-left-trim           symbol-value
  string-lessp               symbolp
  string-not-equal           synonym-stream
  string-not-greaterp        synonym-stream-symbol
  string-not-lessp           t
  string-right-trim          tagbody
  string-stream              tailp
  string-trim                tan
  string-upcase              tanh
  string/=                   tenth
  string<                    terpri
  string<=                   the
  string=                    third
  string>                    throw
  string>=                   time
  stringp                    trace
  structure                  translate-logical-pathname
  structure-class            translate-pathname
  structure-object           tree-equal
  style-warning              truename

;   Figure 1-14: Symbols in the COMMON-LISP package (part eleven of twelve).


  truncate                             values-list
  two-way-stream                       variable
  two-way-stream-input-stream          vector
  two-way-stream-output-stream         vector-pop
  type                                 vector-push
  type-error                           vector-push-extend
  type-error-datum                     vectorp
  type-error-expected-type             warn
  type-of                              warning
  typecase                             when
  typep                                wild-pathname-p
  unbound-slot                         with-accessors
  unbound-slot-instance                with-compilation-unit
  unbound-variable                     with-condition-restarts
  undefined-function                   with-hash-table-iterator
  unexport                             with-input-from-string
  unintern                             with-open-file
  union                                with-open-stream
  unless                               with-output-to-string
  unread-char                          with-package-iterator
  unsigned-byte                        with-simple-restart
  untrace                              with-slots
  unuse-package                        with-standard-io-syntax
  unwind-protect                       write
  update-instance-for-different-class  write-byte
  update-instance-for-redefined-class  write-char
  upgraded-array-element-type          write-line
  upgraded-complex-part-type           write-sequence
  upper-case-p                         write-string
  use-package                          write-to-string
  use-value                            y-or-n-p
  user-homedir-pathname                yes-or-no-p
  values                               zerop

;   Figure 1-15: Symbols in the COMMON-LISP package (part twelve of twelve).
))

; Leave this here.  It is read when loading acl2.lisp.

(defconst *common-lisp-specials-and-constants*

; In acl2-check.lisp we ensure that this constant is consistent with the
; underlying Common Lisp.  The draft proposed ANSI standard for Common Lisp
; specifies (see "The COMMON-LISP Package") exactly which symbols are external
; symbols of the Common Lisp package (not just initially, but always).  It also
; states, in "Constraints on the COMMON-LISP Package for Conforming
; Implementations," that: "conforming programs can use external symbols of the
; COMMON-LISP package as the names of local lexical variables with confidence
; that those names have not been proclaimed special by the implementation
; unless those symbols are names of standardized global variables."
; Unfortunately, we cannot seem to find out in a direct fashion just which
; variables are standardized global variables, i.e., global variables defined
; in the standard.  Our check handles this.

; Shortly before releasing Version  2.5 (6/00), we have checked that the above
; form returns NIL on Unix systems running Allegro 5.0 and 5.0.1 and GCL 2.2.1
; and 2.2.2, on a Windows 98 system (via John Cowles) running Allegro 5.0.1,
; and (after defining the requisite constants) on CMU Common Lisp 18a on a Unix
; system at UT.

; It is completely acceptable to add symbols to this list.  If one certifies a
; book in such an ACL2, it will be a legal certification in an ACL2 in which
; the following list has not been modified.  The only potential source of
; concern here is if one certifies a book in an ACL2 where this list has not
; been modified and then includes it, without recertification, in an ACL2 where
; this list has been added to.  At this point we have not checked that such an
; include-book would catch an inappropriate use of one of those added symbols.
; But that seems a relatively minor concern.

  '(* ** *** *BREAK-ON-SIGNALS* *COMPILE-FILE-PATHNAME*
      *COMPILE-FILE-TRUENAME* *COMPILE-PRINT* *COMPILE-VERBOSE* *DEBUG-IO*
      *DEBUGGER-HOOK* *DEFAULT-PATHNAME-DEFAULTS* *ERROR-OUTPUT*
      *FEATURES* *GENSYM-COUNTER* *LOAD-PATHNAME* *LOAD-PRINT*
      *LOAD-TRUENAME* *LOAD-VERBOSE* *MACROEXPAND-HOOK* *MODULES*
      *PACKAGE* *PRINT-ARRAY* *PRINT-BASE* *PRINT-CASE* *PRINT-CIRCLE*
      *PRINT-ESCAPE* *PRINT-GENSYM* *PRINT-LENGTH* *PRINT-LEVEL*
      *PRINT-LINES* *PRINT-MISER-WIDTH* *PRINT-PPRINT-DISPATCH*
      *PRINT-PRETTY* *PRINT-RADIX* *PRINT-READABLY* *PRINT-RIGHT-MARGIN*
      *QUERY-IO* *RANDOM-STATE* *READ-BASE* *READ-DEFAULT-FLOAT-FORMAT*
      *READ-EVAL* *READ-SUPPRESS* *READTABLE* *STANDARD-INPUT*
      *STANDARD-OUTPUT* *TERMINAL-IO* *TRACE-OUTPUT* + ++ +++ - / // ///
      ARRAY-DIMENSION-LIMIT ARRAY-RANK-LIMIT ARRAY-TOTAL-SIZE-LIMIT
      BOOLE-1 BOOLE-2 BOOLE-AND BOOLE-ANDC1 BOOLE-ANDC2 BOOLE-C1 BOOLE-C2
      BOOLE-CLR BOOLE-EQV BOOLE-IOR BOOLE-NAND BOOLE-NOR BOOLE-ORC1
      BOOLE-ORC2 BOOLE-SET BOOLE-XOR CALL-ARGUMENTS-LIMIT CHAR-CODE-LIMIT
      DOUBLE-FLOAT-EPSILON DOUBLE-FLOAT-NEGATIVE-EPSILON
      INTERNAL-TIME-UNITS-PER-SECOND LAMBDA-LIST-KEYWORDS
      LAMBDA-PARAMETERS-LIMIT LEAST-NEGATIVE-DOUBLE-FLOAT
      LEAST-NEGATIVE-LONG-FLOAT LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT
      LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT
      LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT
      LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT LEAST-NEGATIVE-SHORT-FLOAT
      LEAST-NEGATIVE-SINGLE-FLOAT LEAST-POSITIVE-DOUBLE-FLOAT
      LEAST-POSITIVE-LONG-FLOAT LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT
      LEAST-POSITIVE-NORMALIZED-LONG-FLOAT
      LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT
      LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT LEAST-POSITIVE-SHORT-FLOAT
      LEAST-POSITIVE-SINGLE-FLOAT LONG-FLOAT-EPSILON
      LONG-FLOAT-NEGATIVE-EPSILON MOST-NEGATIVE-DOUBLE-FLOAT
      MOST-NEGATIVE-FIXNUM MOST-NEGATIVE-LONG-FLOAT
      MOST-NEGATIVE-SHORT-FLOAT MOST-NEGATIVE-SINGLE-FLOAT
      MOST-POSITIVE-DOUBLE-FLOAT MOST-POSITIVE-FIXNUM
      MOST-POSITIVE-LONG-FLOAT MOST-POSITIVE-SHORT-FLOAT
      MOST-POSITIVE-SINGLE-FLOAT MULTIPLE-VALUES-LIMIT NIL PI
      SHORT-FLOAT-EPSILON SHORT-FLOAT-NEGATIVE-EPSILON
      SINGLE-FLOAT-EPSILON SINGLE-FLOAT-NEGATIVE-EPSILON T

; Added in Version  2.6 to support Allegro 6.0 on Windows 2000:

      REPLACE FILL CHARACTER =

; Added in Version  2.6 to support GCL on Windows:

      BREAK PRIN1

      ))

(defconst *stobj-inline-declare*

; This constant is being introduced in v2-8.  In this file it is only used in
; raw Lisp, specifically in the progn just below.  But it is also used in
; defstobj-field-fns-raw-defs so we define it in the ACL2 loop.

  '(declare (stobj-inline-fn t)))

; Essay on Hidden Packages

; Before Version_2.8, ACL2 was unsound because of a hole in its handling of
; packages.  The books in the example below can all be certified in
; Version_2.7, including the top-level book top.lisp, which concludes with a
; proof of nil.  The details are slightly tricky, but the basic idea is simple:
; it was possible for traces of a defpkg event, including the axiom it added
; about symbol-package-name, to disappear by making include-books local.  And
; thus, it was possible to prove contradictory theorems, using contradictory
; defpkg events in different locally included books, about the
; symbol-package-name of a symbol.  One solution would be to disallow defpkg
; events in the context of a local include-book (much as we do for defaxiom),
; but that is too restrictive to be practical, especially since non-local
; include-book forms are prohibited inside encapsulate.  So instead we track
; such "hidden" defpkg events; more on that below.

; Here is the example promised above.  The idea is to define a package "FOO"
; that does not import any symbol of name "A", so that the symbol FOO::A has
; symbol-package-name "FOO".  But we do this twice, where one time package
; "FOO" imports ACL2::B and the other time it does not.  The two cases
; introduce symbols (wit1) and (wit2), which we can prove are equal, basically
; because both are FOO::A.  But the result of interning "B" in the package of
; (wit1) or (wit2) is "FOO" in one case and "ACL2" in the other, which allows
; us to prove nil.  We have tried simpler approaches but ACL2 caught us in
; those cases.  We use local include-books below in order to avoid some of
; those catches by avoiding the use of FOO:: in wit1.lisp and wit2.lisp.

; ;;; file top.lisp
;
;   (in-package "ACL2")
;
;   (include-book "wit1")
;   (include-book "wit2")
;
;   ; The idea:
;   ; (wit1) = (wit2) by symbol-equality
;   ; But by evaluation (see wit1-prop and wit2-prop in the included books):
;   ;   (symbol-package-name (intern-in-package-of-symbol "B" (wit1))) = "FOO"
;   ;   (symbol-package-name (intern-in-package-of-symbol "B" (wit2))) = "ACL2"
;
;   (defthm bug
;     nil
;     :hints (("Goal" :use (wit1-prop
;                           wit2-prop
;                           (:instance symbol-equality
;                                      (s1 (wit1))
;                                      (s2 (wit2))))))
;     :rule-classes nil)
;
; ;;; file wit1.lisp
;
;   (in-package "ACL2")
;
;   (local (include-book "sub1"))
;
;   (encapsulate
;    ((wit1 () t))
;    (local (defun wit1 () (sub1)))
;    (local (in-theory (disable (wit1))))
;    (defthm wit1-prop
;      (and (symbolp (wit1))
;           (equal (symbol-name (wit1)) "A")
;           (equal (symbol-package-name (wit1)) "FOO")
;           (equal (symbol-package-name
;                   (intern-in-package-of-symbol "B" (wit1)))
;                  "FOO"))
;      :rule-classes nil))
;
; ;;; file sub1.lisp
;
;   (in-package "ACL2")
;
;   ; Portcullis:
;   ; (defpkg "FOO" nil)
;
;   (encapsulate
;    ((sub1 () t))
;    (local (defun sub1 () 'foo::a))
;    (defthm sub1-prop
;      (and (symbolp (sub1))
;           (equal (symbol-name (sub1)) "A")
;           (equal (symbol-package-name (sub1)) "FOO")
;           (equal (symbol-package-name
;                   (intern-in-package-of-symbol "B" (sub1)))
;                  "FOO"))))
;
; ;;; file wit2.lisp
;
;   (in-package "ACL2")
;
;   (local (include-book "sub2"))
;
;   (encapsulate
;    ((wit2 () t))
;    (local (defun wit2 () (sub2)))
;    (local (in-theory (disable (wit2))))
;    (defthm wit2-prop
;      (and (symbolp (wit2))
;           (equal (symbol-name (wit2)) "A")
;           (equal (symbol-package-name (wit2)) "FOO")
;           (equal (symbol-package-name
;                   (intern-in-package-of-symbol "B" (wit2)))
;                  "ACL2"))
;      :rule-classes nil))
;
; ;;; file sub2.lisp
;
;   (in-package "ACL2")
;
;   ; Portcullis:
;   ; (defpkg "FOO" '(b))
;
;   (encapsulate
;    ((sub2 () t))
;    (local (defun sub2 () 'foo::a))
;    (defthm sub2-prop
;      (and (symbolp (sub2))
;           (equal (symbol-name (sub2)) "A")
;           (equal (symbol-package-name (sub2)) "FOO")
;           (equal (symbol-package-name
;                   (intern-in-package-of-symbol "B" (sub2)))
;                  "ACL2"))))
;
; ;;; file sub1.acl2 (portcullis for sub1.lisp)
;
;   (value :q)
;   (lp)
;   (defpkg "FOO" nil)
;   (certify-book "sub1" 1)
;
; ;;; file sub2.acl2 (portcullis for sub2.lisp)
;
;   (value :q)
;   (lp)
;   (defpkg "FOO" '(b))
;   (certify-book "sub2" 1)

; The key to disallowing this unfortunate exploitation of defpkg axioms is to
; maintain an invariant, which we call "the package invariant on logical
; worlds."  Roughly put, this invariant states that if the world depends in any
; way on a defpkg event, then that defpkg event occurs explicitly in that
; world.  (This invariant, like many others, depends on not having executed any
; event in the world when state global ld-skip-proofsp has a non-nil value.
; Note that we guarantee that this property holds for any certification world;
; see chk-acceptable-certify-book.)  Let us say that a defpkg event "supports"
; a world if it is either in that world or it is in some book (including its
; portcullis) that is hereditarily included in the current world via a chain of
; include-book events, some of which may be local to books or to encapsulate
; events.  Then we can be more precise by stating the package invariant on
; logical worlds as follows: Every defpkg event that supports a logical world
; is present in the known-package-alist of that world.

; It is convenient to introduce the notion of a "hidden" defpkg event in a
; logical world as one that supports that world but is not present as an event
; in that world.  The discussion below relies on the presence of several fields
; in a known-package-alist entry; see make-package-entry.

; We guarantee the (above) package invariant on logical worlds starting with
; Version_2.8 by way of the following two actions, which allow include-book and
; encapsulate (respectively) to preserve this invariant.  Roughly speaking:
; action (1) extends a book's portcullis by any hidden defpkg supporting the
; book, so that the defpkg will not be missing from the world (thus violating
; the invariant) when we include the book; and action (2) puts a
; known-package-alist entry for each (hidden) defpkg introduced by a given
; encapsulate.

;   (1) Recall that when a book is successfully certified in an existing
;   certification world, we write the commands of that world to the book's
;   certificate, as so-called "portcullis commands."  We extend those
;   portcullis commands with defpkg events in two ways.  First, we add a defpkg
;   at the end of the portcullis commands for every known-package-alist entry
;   that has hidden-p fields equal to t (for example, because of a local
;   include-book in a top-level encapsulate), and hence is not an event in the
;   certification world.  We will of course not count these extra defpkgs when
;   checking against a numeric argument given to certify-book.  Second, for
;   each package entry present in the known-package-alist at the end of the
;   proof pass of certify-book that is not present at the end of the
;   include-book pass, we add a corresponding defpkg event to the end of the
;   portcullis commands.

;   Each defpkg event added to the portcullis as described above will have a
;   :book-path argument derived from the book-path field of a package-entry in
;   the known-package-alist, intended to represent the list of full book names
;   leading from the innermost book actually containing the corresponding
;   defpkg (in the car), up to the top-level such include-book (at the end of
;   the list).  Thus, when we evaluate that defpkg, the new package-entry in
;   known-package-alist is obtained by appending the current world's
;   include-book-path to the event's book-path.  The book-path field in the
;   package-entry can be used later when reporting an error during a package
;   conflict, so that the user can see the source of the defpkg that was added
;   to the portcullis under the hood.  Documentation topic hidden-death-package
;   explains hidden defpkgs in detail, and is referenced during such errors.

;   In order to keep the certificate size under control, we will check whether
;   the body of a hidden defpkg event to be added to the portcullis is a term
;   in the world where it will be evaluated, and that this term's value is
;   indeed the list of symbols associated with that package in the
;   known-package-alist (a necessary check for a hidden defpkg since that term
;   may have a different value in the world present at the time of the
;   executing of the defpkg).  If so, then we leave that term in place.
;   Otherwise, we replace it by the appropriate quoted list of symbols, though
;   we might still optimize by removing subsets that are commonly-used
;   constants (e.g. *acl2-exports* and
;   *common-lisp-symbols-from-main-lisp-package*), in favor of suitable calls
;   of append or union-eq.  Note that for hidden defpkg events encountered in a
;   book during its certification, our decision to put them at the end of the
;   certificate's portcullis commands, rather than the beginning, increases the
;   chances that the original defpkg's term can be retained.

;   (2) At the end of any encapsulate, the known-package-alist will be extended
;   with an entry for each introduced defpkg.  (We do this for every package in
;   the known-package-alist at the end of the first pass of the encapsulate
;   that was not there in the beginning, since these must all have been
;   introduced by include-book, and only local include-books are allowed by
;   encapsulate.)  Each such entry will have appropriate package-entry fields,
;   including hidden-p = t.

; Note that when we evaluate a defpkg in a world where that package exists but
; is hidden, the event will not be redundant, and we will change the hidden-p
; field to nil in the known-package-alist entry.  Other fields can be used for
; error reporting.  For example, if we attempt to introduce a defpkg when there
; is already a hidden defpkg conflicting with it, we can report the
; include-book path to the defpkg.

; Finally, we discuss how to ensure that :puff preserves the package invariant.
; Recall that the basic idea behind the implementation of :puff is the
; execution of function puffed-command-sequence to obtain a sequence of
; commands to execute after backing up through the given command.  It is
; straightforward to find the hidden defpkg events that occur in the
; known-package-alist of the world just after the command but not just before,
; and add corresponding defpkg events to the front of the
; puffed-command-sequence.  This preserves the invariant.

; End of Essay on Hidden Packages

(defmacro make-package-entry (&key name imports hidden-p book-path
                                   defpkg-event-form tterm)

; Normally we would use defrec here.  But defrec is defined in basis.lisp.
; Rather than move all the code relevant to defrec into axioms.lisp, we make
; our lives easy for now and simply define the relevant macros directly.  For
; the record (pun intended), here is the defrecord:

; (defrec package-entry
;   (name imports hidden-p book-path defpkg-event-form . tterm)
;   t)

; WARNING: We allow assoc-equal (actually its macro form, find-package-entry)
; to look up names in the known-package-alist, so keep the name as the car.
; Also note that name, imports, and hidden-p are accessed much more frequently
; than the rest, so these should all get relatively fast access.

  `(list* ,name      ; the package name
          ,imports   ; the list of imported symbols
          ,hidden-p  ; t if the introducing defpkg is hidden, else nil

 ; The remaining fields are used for messages only; they have no logical import.

          ,book-path ; a true list of full book names, where the path
                     ; from the first to the last in the list is intended to
                     ; give the location of the introducing defpkg, starting
                     ; with the innermost book

; The final fields are def and tterm, where def is the defpkg event that
; introduced this package and tterm is the translation of the body of that
; defpkg.  If this package-entry becomes hidden, we may use these fields to
; extend the portcullis commands in a book's certificate file.  In doing so, we
; use tterm if it is a term in the world w that is present at the point of
; insertion into the portcullis commands, except that better yet, we will use
; the originating untranslated term from the defpkg if that is the result of
; untranslating tterm in w.

          ,defpkg-event-form
          ,tterm
          ))

(defmacro find-package-entry (name known-package-alist)
  `(assoc-equal ,name ,known-package-alist))

(defmacro package-entry-name (package-entry)
  `(car ,package-entry))

(defmacro package-entry-imports (package-entry)
  `(cadr ,package-entry))

(defmacro package-entry-hidden-p (package-entry)
  `(caddr ,package-entry))

(defmacro package-entry-book-path (package-entry)
  `(cadddr ,package-entry))

(defmacro package-entry-defpkg-event-form (package-entry)
  `(car (cddddr ,package-entry)))

(defmacro package-entry-tterm (package-entry)
  `(cdr (cddddr ,package-entry)))

(defmacro find-non-hidden-package-entry (name known-package-alist)
  `(let ((entry (assoc-equal ,name ,known-package-alist)))
     (and (not (package-entry-hidden-p entry))
          entry)))

(defmacro remove-package-entry (name known-package-alist)
  `(delete-assoc-equal ,name ,known-package-alist))

(defmacro change-package-entry-hidden-p (entry value)
  `(let ((entry ,entry))
     (make-package-entry
      :name (package-entry-name entry)
      :imports (package-entry-imports entry)
      :hidden-p ,value
      :book-path (package-entry-book-path entry)
      :defpkg-event-form (package-entry-defpkg-event-form entry)
      :tterm (package-entry-tterm entry))))

(defmacro getprop (symb key default world-name world-alist)

; This definition formerly occurred after fgetprop and sgetprop, but since
; getprop is used in defpkg-raw we move it before defpkg-raw.  This move would
; not be necessary if we were always to load a source file before we load the
; corresponding compiled file, but with *suppress-compile-build-time* we do not
; load the latter (nor do we re-load the source file, as of this writing, for
; efficiency).

; We avoid cond here because it hasn't been defined yet!

  (if (equal world-name ''current-acl2-world)
      `(fgetprop ,symb ,key ,default ,world-alist)
    `(sgetprop ,symb ,key ,default ,world-name ,world-alist)))

#-acl2-loop-only
(progn

(defvar *user-stobj-alist* nil)

; The value of the above variable is an alist that pairs user-defined
; single-threaded object names with their live ones.  It does NOT
; contain an entry for STATE, which is not user-defined.

; The following SPECIAL VARIABLE, *wormholep*, when non-nil, means that we
; are within a wormhole and are obliged to undo every change visited upon
; *the-live-state*.  Clearly, we can undo some of them, e.g., f-put-globals, by
; remembering the first time we make a change to some component.  But other
; changes, e.g., printing to a file, we can't undo and so must simply disallow.
; We disallow all modifications to user stobjs.

; This feature is implemented so that we can permit the "wormhole window" to
; manipulate a "copy" of state without changing it.  The story is that wormhole,
; which does not take state as an arg and which always returns nil, is
; "actually" implemented by calling the familiar LD on a near image of the
; current state.  That near image is like the current state except that certain
; state globals have been set for wormhole.  In addition, we assume that the
; physical map between ACL2 channels and the outside world has been altered so
; that *standard-co*, *standard-ci*, and *standard-oi* now actually interact
; with the "wormhole window" streams.  Thus, even when *wormholep* is non-nil, we
; can allow i/o to those standard channels because it causes no change to the
; streams normally identified with those channels.  If, while *wormholep* is
; non-nil we are asked to make a change that would undoably alter the state, we
; print a soft-looking error message and abort.  If the requested change can be
; undone, we make the change after remembering enough to undo it.  When we exit
; the wormhole we undo the changes.

(defparameter *wormholep* nil)

; Below we define the function that generates the error message when
; non-undoable state changes are attempted within wormholes.  It throws
; to a tag that is set up within LP.  We do all that later.  Right now
; we just define the error handler so we can code the primitives.

(defun-one-output replace-bad-lisp-object (x)
  (if (bad-lisp-objectp x)
      (let ((pair (rassoc x *user-stobj-alist*)))
        (if pair
            (car pair)

; The following will be printed if we are looking at the value of a local stobj
; or of a stobj bound by stobj-let.

          '|<Unknown value>|))
    x))

(defun-one-output replace-bad-lisp-object-list (x)
  (if (null x)
      nil
    (cons (replace-bad-lisp-object (car x))
          (replace-bad-lisp-object-list (cdr x)))))

(defun-one-output wormhole-er (fn args)
  (error-fms nil 'wormhole
             "It is not possible to apply ~x0~#1~[~/ to ~&2~] in the current ~
              context because we are in a wormhole state."
             (list (cons #\0 fn)
                   (cons #\1 (if args 1 0))
                   (cons #\2 (replace-bad-lisp-object-list args)))
             *the-live-state*)
  (throw 'local-top-level :wormhole-er))

; The following parameter is where we will accumulate changes to
; state components that we will undo.

(defparameter *wormhole-cleanup-form* nil)

; The value of *wormhole-cleanup-form* is a lisp (but not ACL2) form that will
; be executed to cleanup the live state.  This form is built up incrementally
; by certain state changing primitives (e.g., f-put-global) so as to enable us
; to "undo" the effects of those primitives.  We store this undo information
; as an executable form (rather than, say, a list of "undo tuples") because of
; the interaction between this mechanism and our acl2-unwind-protect
; mechanism.  In particular, it will just happen to be the case that the
; *wormhole-cleanup-form* is always on the unwind protection stack (a true
; lisp global variable) so that if an abort happens while executing in a
; wormhole and we get ripped all the way out because of perfectly timed
; aborts, the undo cleanup form(s) will be at their proper places on the stack
; of cleanup forms and it will just look like certain acl2-unwind-protects were
; interrupted.  See the discussion in and around LD-FN.  The value of
; *wormhole-cleanup-form* is (PROGN save-globals undo-form1 ... undo-formk
; safety-set STATE).  The individual undo-formi are created and added to the
; *wormhole-cleanup-form* by push-wormhole-undo- formi, below.  The initial
; value of the cleanup form is (PROGN save-globals safety-set STATE) and new
; formis are added immediately after save-globals, making the final form a
; stack with save-globals always on top and the formi succeeding it in reverse
; order of their storage.  The save-globals form will save into a lisp special
; the final values of the global variables that are available only in the
; wormhole.  The save-globals form is complicated because it also contains a
; check that the cleanup form has never been completely executed.  It does
; this by checking the car of a cons that ``belongs'' to this incarnation of
; the form.  The safety-set at the end of the form sets the car of that cons
; to t.  We cannot prevent the possible partial re-execution of the unwind
; protection form in the face of repeated ill-timed ctrl-c's and we cannot
; really guarantee that a ctrl-c doesn't prevent the execution of the
; safety-set even though the ``real'' cleanup work has been successfully done.
; But the re-execution of the cleanup form can confuse the tracking of the
; brr-stack gstack and we installed this check just for an increased sense of
; sanity.  See the comment after wormhole1.

; We introduce a CLTL structure for the sole purpose of preventing the
; accidental printing of huge objects like the world.  If, in raw lisp, you
; write (make-cloaking-device :hint "world" :obj (w *the-live-state*)) then you
; get an object, x, that CLTL will print as <cloaked world> and from which the
; actual world can be recovered via (cloaking-device-obj x).

(defstruct (cloaking-device
            (:print-function
             (lambda (x stream k)
               (declare (ignore k))
               (format stream "<cloaked ~a>" (cloaking-device-hint x)))))
  hint obj)

(defun-one-output cloaked-set-w! (x state)

; We invented this function, which is merely set-w! but takes a cloaked world,
; just so we can print the *acl2-unwind-protect-stack* during debugging without
; getting the world printed.

  (set-w! (cloaking-device-obj x) state))

(defun-one-output assoc-eq-butlast-2 (x alist)

; This variant of assoc-eq is used in push-wormhole-undo-formi, for which alist
; is not a true alist but rather has two final elements that we do not want to
; consider.  It is run only in raw Lisp on "alists" of the form mentioned
; above.

  (cond ((endp (cddr alist)) nil)
        ((eq x (car (car alist))) (car alist))
        (t (assoc-eq-butlast-2 x (cdr alist)))))

(defun-one-output assoc-eq-equal-butlast-2 (x y alist)

; This variant of assoc-eq-equal is used in push-wormhole-undo-formi, for which
; alist is not a true alist but rather has two final elements that we do not
; want to consider.  It is run only in raw Lisp on "alists" of the form
; mentioned above.

  (cond ((endp (cddr alist)) nil)
        ((and (eq (car (car alist)) x)
              (equal (car (cdr (car alist))) y))
         (car alist))
        (t (assoc-eq-equal-butlast-2 x y (cdr alist)))))

(defun-one-output push-wormhole-undo-formi (op arg1 arg2)

; When a primitive state changing function is called while *wormholep*
; is non-nil it actually carries out the change (in many cases) but
; saves some undo information on the special *wormhole-cleanup-form*.
; The value of that special is (PROGN save-globals form1 ... formk
; safety-set STATE).  In response to this call we will add a new form,
; say form0, and will destructively modify *wormhole-cleanup-form* so
; that it becomes (PROGN save-globals form0 form1 ...  formk
; safety-set STATE).

; We modify *wormhole-cleanup-form* destructively because it shares
; structure with the *acl2-unwind-protect-stack* as described above.

; The convention is that the primitive state changer calls this function before
; making any change.  It passes us the essential information about the
; operation that must be performed to undo what it is about to do.  Thus, if we
; store a new value for a global var, v, whose old value was x, then op will be
; 'put-global, arg1 will be v, and arg2 will be x.  The formi we create will be
; (put-global 'v 'x *the-live-state*) and when that is executed it will undo
; the primitive state change.  Note that we do not know what the primitive
; actually was, e.g., it might have been a put-global but it might also have
; been a makunbound-global.  The point is that the 'put-global in our note is
; the operation that must be done at undo-time, not the operation that we are
; undoing.

; Furthermore, we need not save undo information after the first time
; we smash v.  So we don't necessarily store a formi.  But to implement this we
; have to know every possible formi and what its effects are.  That is why we
; insist that this function (rather than our callers) create the forms.

; To think about the avoidance of formi saving, consider the fact that the
; cleanup form, being a PROGN, will be executed sequentially -- -- undoing the
; state changes in the reverse order of their original execution.  Imagine that
; we in fact added a new formi at the front of the PROGN for each state change.
; Now think about it: if later on down the PROGN there is a form that will
; overwrite the effects of the form we are about to add, then there is no need
; to add it.  In particular, the result of evaluating all the forms is the same
; whether we add the redundant one or not.

  (cond ((null *wormhole-cleanup-form*)
         (interface-er
          "push-wormhole-undo-formi was called with an empty ~
           *wormhole-cleanup-form*.  Supposedly, push-wormhole-undo-formi is ~
           only called when *wormholep* is non-nil and, supposedly, when ~
           *wormholep* is non-nil, the *wormhole-cleanup-form* is too.")))
  (let ((qarg1 (list 'quote arg1))
        (undo-forms-and-last-two (cddr *wormhole-cleanup-form*)))
    (case op
      (put-global

; So we want to push (put-global 'arg1 'arg2 state).  But if there is already a
; form that will set arg1 or one that unbinds arg1, there is no point.

       (or (assoc-eq-equal-butlast-2 'put-global qarg1
                                     undo-forms-and-last-two)
           (assoc-eq-equal-butlast-2 'makunbound-global qarg1
                                     undo-forms-and-last-two)
           (and (eq arg1 'current-acl2-world)
                (assoc-eq-butlast-2 'cloaked-set-w!
                                    undo-forms-and-last-two))
           (setf (cddr *wormhole-cleanup-form*)
                 (cons (let ((put-global-form
                              `(put-global ,qarg1 (quote ,arg2)
                                           *the-live-state*)))

; We compress arrays for side-effect only, to ensure that we do not install a
; different global value than was there before.  Fortunately, we know that the
; arrays in question are already in compressed form, i.e., they satisfy
; array1p; so we believe that these side-effects do not change the array's
; alist (in the sense of eq), and hence the restored global value will be
; installed as an ACL2 array.  (If we're wrong, it's not a soundness issue --
; rather, we will see slow-array-warning messages.)

                         (cond ((eq arg1 'global-enabled-structure)
                                `(progn (let ((qarg2 (quote ,arg2)))
                                          (compress1 (access enabled-structure
                                                             qarg2
                                                             :array-name)
                                                     (access enabled-structure
                                                             qarg2
                                                             :theory-array)))
                                        ,put-global-form))
                               ((and (eq arg1 'iprint-ar)
                                     arg2)
                                `(progn (let ((qarg2 (quote ,arg2)))
                                          (compress1 'iprint-ar qarg2))
                                        ,put-global-form))
                               ((eq arg1 'trace-specs)
                                nil) ; handled by fix-trace-specs
                               (t put-global-form)))
                       (cddr *wormhole-cleanup-form*)))))
      (makunbound-global

; We want to push (makunbound-global 'arg1 state).  But if there is already
; a form that will make arg1 unbound or if there is a form that will
; give it a binding, this is redundant.

       (or (assoc-eq-equal-butlast-2 'put-global qarg1
                                     undo-forms-and-last-two)
           (assoc-eq-equal-butlast-2 'makunbound-global qarg1
                                     undo-forms-and-last-two)
           (and (eq arg1 'current-acl2-world)
                (assoc-eq-butlast-2 'cloaked-set-w!
                                    undo-forms-and-last-two))
           (setf (cddr *wormhole-cleanup-form*)
                 (cons `(makunbound-global ,qarg1 *the-live-state*)
                       (cddr *wormhole-cleanup-form*)))))
      (cloaked-set-w!
       (or (assoc-eq-butlast-2 'cloaked-set-w! undo-forms-and-last-two)
           (setf (cddr *wormhole-cleanup-form*)
                 (cons `(cloaked-set-w!
                         ,(make-cloaking-device
                           :hint "world"
                           :obj arg1)
                         *the-live-state*)
                       (cddr *wormhole-cleanup-form*)))))
      (otherwise
       (interface-er "Unrecognized op in push-wormhole-undo-formi,~
                          ~x0." op)))))

; The following symbol is the property under which we store Common
; Lisp streams on the property lists of channels.

(defconstant *open-input-channel-key*
  'acl2_invisible::|Open Input Channel Key|)

; The following symbol is the property under which we store the types
; of Common Lisp streams on the property lists of channels.

(defconstant *open-input-channel-type-key*
  'acl2_invisible::|Open Input Channel Type Key|)

(defconstant *open-output-channel-key*
  'acl2_invisible::|Open Output Channel Key|)

(defconstant *open-output-channel-type-key*
  'acl2_invisible::|Open Output Channel Type Key|)

(defconstant *non-existent-stream*
  'acl2_invisible::|A Non-Existent Stream|)

; We get ready to handle errors in such a way that they return to the
; top level logic loop if we are under it.

(defvar *acl2-error-p* nil)

(defun interface-er (&rest args)

; This function can conceivably be called before ACL2 has been fully
; compiled and loaded, so we check whether the usual error handler is
; around.

  (cond
   ((macro-function 'er)
    (eval
     `(let ((state *the-live-state*)
            (*acl2-error-p* t))
        (er soft 'acl2-interface
            ,@(let (ans)
                (dolist (a args)
                        (push (list 'quote a) ans))
                (reverse ans)))
        (error "ACL2 Halted"))))
   (t (error "ACL2 error:  ~a." args))))

#-acl2-loop-only
(declaim (inline

; Here we take a suggestion from Jared Davis and inline built-in functions,
; starting after Version_6.2, based on successful use of such inlining at
; Centaur Technology for many months on their local copy of ACL2.  Indeed, the
; original list below (added on June 16, 2013) comes directly from that copy,
; except for inclusion of aref1 and aref2 (as noted below).  As Jared said in a
; log message when he added inline declarations for 33 functions to a local
; copy of ACL2 at Centaur:

;   This should give us a useful speedup on CCL for many functions that recur
;   with ZP at the end.  I measured a 12% speedup for a naive FIB function.

; We are seeing perhaps 2% speedup on regressions, but we believe that this
; inlining could provide much greater benefit in some cases.

; Some of these functions could probably be inlined using the defun-inline
; feature of ACL2, but we prefer not to fight with the likely resulting
; boot-strapping problem during the ACL2 build.

; We may modify this list from time to time, for example based on user request.
; It surely is safe to add any function symbol to the list that is not defined
; recursively in raw Lisp (and maybe even if it is).  But of course that could
; interfere with tracing and redefinition, so care should be taken before
; adding a function symbol that might be traced or redefined.

; We endeavor to keep the list sorted alphabetically, simply to make it easy to
; search visually.

           acl2-numberp
           add-to-set-eq-exec
           aref1 ; already inlined in Version_6.2 and before
           aref2 ; already inlined in Version_6.2 and before
           booleanp
           complex-rationalp
           eqlablep
           fix
           fn-symb
           iff
           ifix
           implies
           integer-abs
           integer-range-p
           len
           member-equal
           natp
           nfix
           peek-char$
           posp
           quotep
           random$
           read-byte$
           read-char$
           realfix
           rfix
           signed-byte-p
           strip-cars
           strip-cdrs
           symbol-<
           unsigned-byte-p
           xor
           zip
           zp
           zpf
           )

; For ACL2 built on CMUCL 20D Unicode, an attempt failed on 9/12/2013 to
; certify the community book books/models/jvm/m1/defsys.lisp.  During
; debugging, we found a note that mentioned "*Inline-Expansion-Limit* (400)
; exceeded".  The following declaim form, which may be quite harmless, solves
; the problem.

         #+cmu
         (notinline len))

; We provide here ``raw'' implementations of basic functions that we
; ``wish'' were already in Common Lisp, to support primitives of the
; ACL2 logic.

; Some of the Common Lisp arithmetic primitives are n-ary functions.
; However, ACL2 supports only functions of fixed arity, to keep the
; logic simple.  But in practice we find we want to use the n-ary
; arithmetic symbols ourselves.  So in the logic we have binary-+ as
; the primitive binary addition function symbol, but we also have the
; macro +, which expands into a suitable number of uses of binary-+.
; Similarly for *, -, and /.  (The ACL2 user cannot invoke
; symbol-function, fboundp, macro-function or macroexpand, so it is no
; concern to the user whether we implement + as a macro or a
; function.)

(defun-one-output acl2-numberp (x)
  (numberp x))

(defun-one-output binary-+ (x y) (+ x y))

(defun-one-output binary-* (x y) (* x y))

(defun-one-output unary-- (x) (- x))

(defun-one-output unary-/ (x) (/ x))

; Below we define our top-level events as seen by the Common Lisp
; compiler.  For example, (defuns a b c) expands into a progn of defun
; forms, (defthm ...) is a no-op, etc.

(defparameter *in-recover-world-flg* nil)

; Warning:  Keep the initial value of the following defparameter identical to
; that of the ACL2 constant *initial-known-package-alist* below.

(defparameter *ever-known-package-alist*
  (list (make-package-entry :name "ACL2-INPUT-CHANNEL"
                            :imports nil)
        (make-package-entry :name "ACL2-OUTPUT-CHANNEL"
                            :imports nil)
        (make-package-entry :name "ACL2"
                            :imports *common-lisp-symbols-from-main-lisp-package*)
        (make-package-entry :name

; Warning: The following is just *main-lisp-package-name* but that is not
; defined yet.  If you change the following line, change the defconst of
; *main-lisp-package-name* below.

                            "COMMON-LISP"
                            :imports nil)
        (make-package-entry :name "KEYWORD"
                            :imports nil)))

; The known-package-alist of the state will grow and shrink as packages are
; defined and undone.  But *ever-known-package-alist* will just grow.  A
; package can be redefined only if its imports list is identical to that in its
; old definition.

(defvar **1*-symbol-key* (make-symbol "**1*-SYMBOL-KEY*"))

(defun *1*-symbol (x)
; Keep this in sync with *1*-symbol?.
  (or (get x **1*-symbol-key*)
      (setf (get x **1*-symbol-key*)
            (intern (symbol-name x)
                    (find-package-fast
                     (concatenate 'string
                                  *1*-package-prefix*
                                  (symbol-package-name x)))))))

(defun *1*-symbol? (x)
; Keep this in sync with *1*-symbol.  Returns nil if the *1* package doesn't
; exist.
  (let ((pack (find-package-fast (concatenate 'string
                                              *1*-package-prefix*
                                              (symbol-package-name x)))))
    (and pack
         (or (get x **1*-symbol-key*)
             (setf (get x **1*-symbol-key*)
                   (intern (symbol-name x)
                           pack))))))

(defmacro defun-*1* (fn &rest args)
  `(defun ,(*1*-symbol fn) ,@args))

(defparameter *defun-overrides* nil)

(defmacro defun-overrides (name formals &rest rest)

; This is basically defun, for a function that takes the live state and has a
; guard of t.  We push name onto *defun-overrides* so that add-trip knows to
; leave the *1* definition in place.

  (assert (member 'state formals :test 'eq))
  `(progn (push ',name *defun-overrides*) ; see add-trip
          (defun ,name ,formals
            ,@(butlast rest 1)
            (progn (chk-live-state-p ',name state)
                   ,(car (last rest))))
          (defun-*1* ,name ,formals
            (,name ,@formals))))

(defmacro defpkg (&whole event-form name imports
                         &optional doc book-path hidden-p)

; Keep this in sync with get-cmds-from-portcullis1, make-hidden-defpkg,
; equal-modulo-hidden-defpkgs, and (of course) the #+acl2-loop-only definition
; of defpkg.

  (declare (ignore doc hidden-p))
  (or (stringp name)
      (interface-er "Attempt to call defpkg on a non-string, ~x0."
                    name))
  `(defpkg-raw ,name ,imports ',book-path ',event-form))

(defmacro defuns (&rest lst)
  `(progn ,@(mapcar #'(lambda (x) `(defun ,@x))
                    lst)))

#+:non-standard-analysis
(defmacro defun-std (name formals &rest args)
  (list* 'defun
         name
         formals
         (append (butlast args 1)
                 (list (non-std-body name formals (car (last args)))))))

#+:non-standard-analysis
(defmacro defuns-std (&rest args)
  `(defuns ,@args))

(defmacro defthm (&rest args)
  (declare (ignore args))
  nil)

(defmacro defthmd (&rest args)
  (declare (ignore args))
  nil)

#+:non-standard-analysis
(defmacro defthm-std (&rest args)
  (declare (ignore args))
  nil)

(defmacro defaxiom (&rest args)
  (declare (ignore args))
  nil)

(defmacro skip-proofs (arg)
  arg)

(defmacro deflabel (&rest args)
  (declare (ignore args))
  nil)

(defmacro defdoc (&rest args)
  (declare (ignore args))
  nil)

(defmacro deftheory (&rest args)
  (declare (ignore args))
  nil)

(defun-one-output stobj-initial-statep-arr (n i arr init)
  (or (zp n)
      (and (equal (aref arr i) init)
           (stobj-initial-statep-arr (1- n) (1+ i) arr init))))

(defun-one-output stobj-initial-statep-entry (temp entry)

; Keep this function in sync with defstobj-raw-init-fields.  (See the comments
; about this function, below.)

  (let ((type (cadr temp))
        (init (caddr temp)))
    (cond
     ((and (consp type)
           (eq (car type) 'ARRAY))

; For stobj array fields, we need to check each entry in the array to make sure
; it is the initial value and we also need to check that the array has not been
; resized to a size different than the initial size.

      (let ((size (car (caddr type))))
        (and (equal (length entry) size)
             (stobj-initial-statep-arr size 0 entry init))))
     ((equal type t)

; For type "T", the stobj field is not "boxed" by defstobj-raw-init-fields.

      (equal entry init))
     (t

; For other types, the value is "boxed" by defstobj-raw-init-fields in a single
; entry array.

      (equal (aref entry 0) init)))))

(defun-one-output stobj-initial-statep1 (field-templates ndx stobj)
  (cond ((endp field-templates) t)
        (t (and (stobj-initial-statep-entry (car field-templates)
                                            (aref stobj ndx))
                (stobj-initial-statep1 (cdr field-templates)
                                       (1+ ndx)
                                       stobj)))))

(defun-one-output stobj-initial-statep (stobj field-templates)

; Stobj is the live object corresponding to some defstobj and
; field-templates is the field templates for the defstobj.  We return
; t or nil according to whether the live object is in the initial
; state.

; Each element of field-templates is of the form (recog-fn type
; init-val acc-fn upd-fn ...).  If type indicates an array, then it
; has the form (ARRAY typ (max)), and the indices of the array range
; from 0 to max-1, i.e., max is the first illegal index.

  (stobj-initial-statep1 field-templates 0 stobj))

(defun remove-stobj-inline-declare (x)
  (cond ((atom x) x)
        ((equal (car x) *stobj-inline-declare*)
         (cdr x))
        (t (cons (car x)
                 (remove-stobj-inline-declare (cdr x))))))

(defun congruent-stobj-rep-raw (name)
  (assert name)
  (let* ((d (get (the-live-var name)
                 'redundant-raw-lisp-discriminator))
         (ans (cddddr d)))
    (assert ans)
    ans))

; Note: The code below bothers me a little because of its impact on
; the toothbrush model.  In particular, it uses defstobj-raw-defs,
; which is defined far away in other-events.lisp.

(defmacro defstobj (name &rest args)

; Warning: If you change this definition, consider the possibility of making
; corresponding changes to the #-acl2-loop-only definition of defabsstobj.

; This function is run when we evaluate (defstobj name . args) in raw lisp.
; A typical such form is

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

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

; This function must contend with a problem analogous to the one addressed by
; acl2::defconst in acl2.lisp: the need to avoid re-declaration of the same
; stobj.  We use redundant-raw-lisp-discriminator in much the same way as in
; the raw lisp defmacro of acl2::defconst.

  (let* ((template (defstobj-template name args nil))
         (congruent-to (sixth template))
         (congruent-stobj-rep (if congruent-to
                                  (congruent-stobj-rep-raw congruent-to)
                                name))
         (init (defstobj-raw-init template))
         (the-live-name (the-live-var name)))
    `(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)
       #+hons ,@(and (null congruent-to)
                     `((defg ,(st-lst name) nil)))

; Now we lay down the defuns of the recognizers, accessors and updaters as
; generated by defstob-raw-defs.  The boilerplate below just adds the DEFUN to
; the front of each def generated, preserving the order of the defs as
; generated.  We deal here with the :inline case; note that
; *stobj-inline-declare* was added in defstobj-field-fns-raw-defs.

       ,@(mapcar (function (lambda (def)
                             (if (member-equal *stobj-inline-declare* def)
                                 (cons 'DEFABBREV
                                       (remove-stobj-inline-declare def))
                               (cons 'DEFUN def))))
                 (defstobj-raw-defs name template congruent-stobj-rep nil))
       ,@(defstobj-defconsts (strip-accessor-names (caddr template)) 0)
       (let* ((template ',template)
              (congruent-stobj-rep ',congruent-stobj-rep)
              (boundp (boundp ',the-live-name))
              (d (and boundp
                      (get ',the-live-name
                           'redundant-raw-lisp-discriminator)))

; d is expected to be of the form (DEFSTOBJ namep creator field-templates
; . congruent-stobj-rep).

              (ok-p (and boundp
                         (consp d)
                         (eq (car d) 'defstobj)
                         (consp (cdr d))
                         (eq (cadr d) (car template))
                         (consp (cddr d))
                         (eq (caddr d) (cadr template))
                         (equal (cadddr d) (caddr template))
                         (eq (cddddr d) congruent-stobj-rep)

; We also formerly required:

;                        (stobj-initial-statep (symbol-value ',the-live-name)
;                                              (caddr template))

; However, the stobj need not have its initial value; consider a redundant
; defstobj in a book whose certification world has already modified the stobj,
; or a defstobj in a book whose value is modified in a make-event later in that
; book.  Either way, ok-p would be false when this code is executed by loading
; the compiled file.

; We do not check the :doc, :inline, or :congruent-to fields, because these
; incur no proof obligations.  If a second pass of encapsulate, or inclusion of
; a book, exposes a later non-local defstobj that is redundant with an earlier
; local one, then any problems will be caught during local compatibility
; checks.

                         )))
         (cond
          (ok-p ',name)
          ((and boundp (not (raw-mode-p *the-live-state*)))
           (interface-er
            "Illegal attempt to redeclare the single-threaded object ~s0."
            ',name))
          (t

; Memoize-flush expects the variable (st-lst name) to be bound.

           (setf ,the-live-name ,init)
           (setf (get ',the-live-name 'redundant-raw-lisp-discriminator)
                 (list* 'defstobj (car template) (cadr template)
                        (caddr template) congruent-stobj-rep))
           (let ((old (and boundp

; Since boundp, then by a test made above, we also know (raw-mode-p state).
; This boundp test could be omitted, since otherwise we know that the assoc-eq
; call below will return nil; the boundp check is just an optimization.

                           (assoc-eq ',name *user-stobj-alist*))))
             (cond
              (old ; hence raw-mode
               (fms "Note:  Redefining and reinitializing 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))))))

(defmacro value-triple (&rest args)
  (declare (ignore args))
  nil)

(defmacro verify-termination-boot-strap (&rest args)
  (declare (ignore args))
  nil)

(defmacro verify-guards (&rest args)
  (declare (ignore args))
  nil)

(defmacro in-theory (&rest args)
  (declare (ignore args))
  nil)

(defmacro in-arithmetic-theory (&rest args)
  (declare (ignore args))
  nil)

(defmacro regenerate-tau-database (&rest args)
  (declare (ignore args))
  nil)

(defmacro push-untouchable (&rest args)
  (declare (ignore args))
  nil)

(defmacro remove-untouchable (&rest args)
  (declare (ignore args))
  nil)

(defmacro set-body (&rest args)
  (declare (ignore args))
  nil)

(defmacro table (&rest args)

; Note: The decision to make table a no-op in compiled files was not
; taken lightly.  But table, like defthm, has no effect on the logic.
; Indeed, like defthm, table merely modifies the world and if it is
; permitted in compiled code to ignore defthm's effects on the world
; then so too the effects of table.

  (declare (ignore args))
  nil)

(defmacro encapsulate (signatures &rest lst)

; The code we generate for the constrained functions in signatures is
; the same (except, possibly, for the formals) as executed in
; extend-world1 when we introduce an undefined function.

; Sig below may take on any of several forms, illustrated by
; the examples:

; ((fn * * $S * STATE) => (MV * STATE))
; (fn (x y $S z STATE)    (MV t STATE))
; (fn (x y $S z STATE)    (MV t STATE) :stobjs ($S))

; Because the first form above does not provide explicit formals, we
; generate them with gen-formals-from-pretty-flags when we process
; ENCAPSULATE in the logic.  So what do we do here in raw Lisp when an
; encapsulate is loaded?  We ignore all but the arity and generate (x1
; x2 ... xn).  We did not want to have to include
; gen-formals-from-pretty-flags in the toothbrush model.

; See the comment in defproxy about benign redefinition in raw Lisp by an
; encapsulate of a function introduced by defproxy.

  `(progn ,@(mapcar
             (function
              (lambda (sig)
                (let* ((fn (if (consp (car sig)) (caar sig) (car sig)))
                       (formals
                        (if (consp (car sig))
                            (let ((i 0))
                              (mapcar (function
                                       (lambda (v)
                                         (declare (ignore v))
                                         (setq i (+ 1 i))
                                         (intern (format nil "X~a" i)
                                                 "ACL2")))
                                      (cdar sig)))
                          (cadr sig))))
                  (list 'defun fn formals
                        (null-body-er fn formals t)))))
             signatures)
          ,@lst))

(defparameter *inside-include-book-fn*

; We trust include-book-fn and certify-book-fn to take care of all include-book
; processing without any need to call the raw Lisp include-book.  It seems that
; the only way this could be a bad idea is if include-book or certify-book
; could be called from a user utility, rather than at the top level, while
; inside a call of include-book-fn or certify-book-fn.  We disallow this in
; translate11.

  nil)

(defmacro include-book (user-book-name
                        &key
                        (load-compiled-file ':default)
                        uncertified-okp
                        defaxioms-okp
                        skip-proofs-okp
                        ttags
                        dir
                        doc)
  (declare (ignore uncertified-okp defaxioms-okp skip-proofs-okp ttags doc))
  `(include-book-raw ,user-book-name nil ,load-compiled-file ,dir
                     '(include-book . ,user-book-name)
                     *the-live-state*))

(defmacro certify-book (&rest args)
  (declare (ignore args))

; Unlike the embedded event forms such as DEFTHM, it is safe to cause an error
; here.  We want embedded event forms such as DEFTHM to be quietly ignored
; when books are included, but CERTIFY-BOOK is not an embedded event form, so
; it has no business being called from raw Lisp.

  (interface-er "Apparently you have called CERTIFY-BOOK from outside the ~
                 top-level ACL2 loop.  Perhaps you need to call (LP) first."))

(defmacro local (x)
  (declare (ignore x))
  nil)

(defmacro defchoose (&rest args)
  (let ((free-vars (caddr args)))
    `(defun ,(car args) ,free-vars
       ,(null-body-er (car args) free-vars nil))))

; Although defuns provides us conceptually with the right function for
; packaging together mutually recursive functions, we never use it
; because it hides things from standard Lisp editor indexing programs
; such as etags.  Instead, we use mutual-recursion.

(defmacro mutual-recursion (&rest lst)
  (cons 'progn lst))

(defmacro make-event (&whole event-form
                             form
                             &key
                             expansion? check-expansion on-behalf-of)
  (declare (ignore form on-behalf-of))
  (cond ((consp check-expansion)
         check-expansion)
        (expansion?)
        (t `(error ; not er; so certify-book and include-book fail
             "It is illegal to execute make-event in raw Lisp (including ~%~
              raw mode) unless :check-expansion is a cons, which represents ~%~
              the expected expansion.  If this error occurs when executing ~%~
              an include-book form in raw mode or raw Lisp, consider loading a ~%~
              corresponding file *@expansion.lsp instead; see :DOC ~%~
              certify-book.  If you are not in raw Lisp, then this is an ~%~
              ACL2 bug; please contact the ACL2 implementors and report the ~%~
              offending form:~%~%~s~%"
             ',event-form))))
)

(deflabel programming

; Be sure to include documentation for all functions in
; primitive-formals-and-guards.

  :doc
  ":Doc-Section Programming

  programming in ACL2~/

  This ~il[documentation] topic is a parent topic under which we include
  documentation topics for built-in functions, macros, and special forms
  (~pl[acl2-built-ins]) as well as topics for notions important to programming
  with ACL2.  If you don't find what you're looking for, see the Index or see
  individual topics that may be more directly appropriate; for example,
  ~pl[events] for top-level event constructorsr like ~ilc[defun].~/~/")

(deflabel acl2-built-ins
  :doc
  ":Doc-Section ACL2::Programming
  built-in ACL2 functions~/

  This ~il[documentation] topic is a parent topic under which we include
  documentation for built-in functions, macros, and special forms that are
  typically used in programming.  For others, including those typically used as
  top-level commands or those that create ~il[events] (~ilc[defun],
  ~ilc[defthm], and so on), documentation may be found as a subtopic of some
  other parent topic.  We do not document some of the more obscure functions
  provided by ACL2 that do not correspond to functions of Common Lisp.~/

  See any documentation for Common Lisp for more details on many of these
  functions.~/")

(deflabel miscellaneous
  :doc
  ":Doc-Section Miscellaneous

  a miscellany of documented functions and concepts
                 (often cited in more accessible ~il[documentation])~/~/

  Perhaps as the system matures this section will become more
  structured.~/")

;                          STANDARD CHANNELS

; Documentation is deferred until after (deflabel IO ...).

(defconst *standard-co* 'acl2-output-channel::standard-character-output-0)

(defconst *standard-oi* 'acl2-input-channel::standard-object-input-0)

(defconst *standard-ci* 'acl2-input-channel::standard-character-input-0)

;                            IF and EQUAL

; Convention:  when a term t is used as a formula it means
; (not (equal t nil))

; The following four axioms define if and equal but are not expressed
; in the ACL2 language.

;         (if NIL y z) = z

; x/=NIL -> (if x y z) = y

; (equal x x) = T

; x/=y -> (equal x y) = NIL


;                               LOGIC

#+acl2-loop-only
(defconst nil 'nil

; We cannot document a NIL symbol.

 " NIL, a symbol, represents in Common Lisp both the false truth value
 and the empty list.")

#+acl2-loop-only
(defconst t 't

; We cannot document a NIL symbol.  So, we do not document T either.

  "T, a symbol, represents the true truth value in Common Lisp.")

(defun insist (x)

; This function is used in guard-clauses-for-fn, so in order to be sure that
; it's in place early, we define it now.

  (declare (xargs :guard x :mode :logic :verify-guards t)
           (ignore x))
  nil)

(defun iff (p q)

  ":Doc-Section ACL2::ACL2-built-ins

  logical ``if and only if''~/

  ~c[Iff] is the ACL2 biconditional, ``if and only if''.  ~c[(iff P Q)]
  means that either ~c[P] and ~c[Q] are both false (i.e., ~c[nil]) or both true
  (i.e., not ~c[nil]).

  To see the ACL2 definition of this function, ~pl[pf].~/~/"

  (declare (xargs :guard t))
  (if p (if q t nil) (if q nil t)))

(defun xor (p q)

  ":Doc-Section ACL2::ACL2-built-ins

  logical ``exclusive or''~/

  ~c[Xor] is the ACL2 exclusive-or function.  ~c[(xor P Q)] means that either
  ~c[P] or ~c[Q], but not both, is false (i.e., ~c[nil]).

  To see the ACL2 definition of this function, ~pl[pf].~/~/"

  (declare (xargs :guard t))
  (if p (if q nil t) (if q t nil)))

#+acl2-loop-only
(defun eq (x y)

  ":Doc-Section ACL2::ACL2-built-ins

  equality of symbols~/

  ~c[Eq] is the function for determining whether two objects are
  identical (i.e., have the exact same store address in the current
  von Neumann implementation of Common Lisp).  It is the same as
  ~ilc[equal] in the ACL2 logic.~/

  ~c[Eq] is a Common Lisp function.  In order to ensure conformance
  with Common Lisp, the ACL2 ~il[guard] on ~c[eq] requires at least one of
  the arguments to ~c[eq] to be a symbol.  Common Lisp guarantees that
  if ~c[x] is a symbol, then ~c[x] is ~c[eq] to ~c[y] if and only if ~c[x]
  is ~ilc[equal] to ~c[y].  Thus, the ACL2 user should think of ~c[eq] as
  nothing besides a fast means for checking ~ilc[equal] when one argument
  is known to be a symbol.  In particular, it is possible that an
  ~c[eq] test will not even require the cost of a function call but
  will be as fast as a single machine instruction.~/"

  (declare (xargs :guard (if (symbolp x)
                             t
                           (symbolp y))
                  :mode :logic :verify-guards t))
  (equal x y))

(defun booleanp (x)

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for booleans~/

  ~c[(Booleanp x)] is ~c[t] if ~c[x] is ~c[t] or ~c[nil], and is ~c[nil] otherwise.~/

  ~l[generalized-booleans] for a discussion of a potential
  soundness problem for ACL2 related to the question:  Which Common
  Lisp functions are known to return Boolean values?

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard t))
  (if (eq x t)
      t
    (eq x nil)))

; We do not want to try to define defequiv at this point, so we use the
; expansion of (defequiv iff).

(defthm iff-is-an-equivalence
  (and (booleanp (iff x y))
       (iff x x)
       (implies (iff x y) (iff y x))
       (implies (and (iff x y) (iff y z))
                (iff x z)))
  :rule-classes (:equivalence))

(defun implies (p q)

  ":Doc-Section ACL2::ACL2-built-ins

  logical implication~/

  ~c[Implies] is the ACL2 implication function.  ~c[(implies P Q)] means
  that either ~c[P] is false (i.e., ~c[nil]) or ~c[Q] is true (i.e., not
  ~c[nil]).

  To see the ACL2 definition of this function, ~pl[pf].~/~/"

  (declare (xargs :mode :logic :guard t))
  (if p (if q t nil) t))

(defthm iff-implies-equal-implies-1
  (implies (iff y y-equiv)
           (equal (implies x y) (implies x y-equiv)))
  :rule-classes (:congruence))

(defthm iff-implies-equal-implies-2
  (implies (iff x x-equiv)
           (equal (implies x y) (implies x-equiv y)))
  :rule-classes (:congruence))

#+acl2-loop-only
(defun not (p)

  ":Doc-Section ACL2::ACL2-built-ins

  logical negation~/

  ~c[Not] is the ACL2 negation function.  The negation of ~c[nil] is ~c[t] and
  the negation of anything else is ~c[nil].~/

  ~c[Not] is a Common Lisp function.  See any Common Lisp documentation
  for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

 (declare (xargs :mode :logic :guard t))
 (if p nil t))

(defthm iff-implies-equal-not
  (implies (iff x x-equiv)
           (equal (not x) (not x-equiv)))
  :rule-classes (:congruence))

(defun hide (x)

  ":Doc-Section Miscellaneous

  hide a term from the rewriter~/

  ~c[Hide] is actually the ~il[identity] function:  ~c[(hide x) = x] for
  all ~c[x].  However, terms of the form ~c[(hide x)] are ignored by the
  ACL2 rewriter, except when explicit ~c[:expand] ~il[hints] are given
  for such terms (~pl[hints]) or when rewrite rules explicitly
  about ~c[hide] are available.  An ~c[:expand] hint that removes all
  calls of ~c[hide] is:
  ~bv[]
  :expand ((:free (x) (hide x)))
  ~ev[]
  The above hint can be particularly useful when ACL2's equality heuristics
  apply ~c[hide] to an equality after substituting it into the rest of the
  goal, if that goal (or a subgoal of it) fails to be proved.

  ~c[Hide] terms are also ignored by the induction heuristics.~/

  Sometimes the ACL2 simplifier inserts ~c[hide] terms into a proof
  attempt out of the blue, as it were.  Why and what can you do about
  it?  Suppose you have a constrained function, say ~c[constrained-fn], and
  you define another function, say ~c[another-fn], in terms of it, as in:
  ~bv[]
  (defun another-fn (x y z)
    (if (big-hairy-test x y z)
        (constrained-fn x y z)
        t))
  ~ev[]
  Suppose the term ~c[(another-fn 'a 'b 'c)] arises in a proof.  Since
  the arguments are all constants, ACL2 will try to reduce such a term
  to a constant by executing the definition of ~c[another-fn].
  However, after a possibly extensive computation (because of
  ~c[big-hairy-test]) the execution fails because of the unevaluable
  call of ~c[constrained-fn].  To avoid subsequent attempts to evaluate
  the term, ACL2 embeds it in a ~c[hide] expression, i.e., rewrites it
  to ~c[(hide (another-fn 'a 'b 'c))].

  You might think this rarely occurs since all the arguments of
  ~c[another-fn] must be constants.  You would be right except for one
  special case:  if ~c[another-fn] takes no arguments, i.e., is a
  constant function, then every call of it fits this case.  Thus, if
  you define a function of no arguments in terms of a constrained
  function, you will often see ~c[(another-fn)] rewrite to
  ~c[(hide (another-fn))].

  We do not hide the term if the executable counterpart of the
  function is disabled -- because we do not try to evaluate it in the
  first place.  Thus, to prevent the insertion of a ~c[hide] term into
  the proof attempt, you can globally disable the executable
  counterpart of the offending defined function, e.g.,
  ~bv[]
  (in-theory (disable (:executable-counterpart another-fn))).
  ~ev[]

  It is conceivable that you cannot afford to do this:  perhaps some
  calls of the offending function must be computed while others cannot
  be.  One way to handle this situation is to leave the executable
  counterpart enabled, so that ~c[hide] terms are introduced on the
  calls that cannot be computed, but prove explicit :~ilc[rewrite]
  rules for each of those ~c[hide] terms.  For example, suppose that in
  the proof of some theorem, thm, it is necessary to leave the
  executable counterpart of ~c[another-fn] enabled but that the call
  ~c[(another-fn 1 2 3)] arises in the proof and cannot be computed.
  Thus the proof attempt will introduce the term
  ~c[(hide (another-fn 1 2 3))].  Suppose that you can show that
  ~c[(another-fn 1 2 3)] is ~c[(contrained-fn 1 2 3)] and that such
  a step is necessary to the proof.  Unfortunately, proving the rewrite
  rule
  ~bv[]
  (defthm thm-helper
    (equal (another-fn 1 2 3) (constrained-fn 1 2 3)))
  ~ev[]
  would not help the proof of thm because the target term is hidden
  inside the ~c[hide].  However,
  ~bv[]
  (defthm thm-helper
    (equal (hide (another-fn 1 2 3)) (constrained-fn 1 2 3)))
  ~ev[]
  would be applied in the proof of thm and is the rule you should
  prove.

  Now to prove ~c[thm-helper] you need to use the two ``tricks'' which
  have already been discussed.  First, to eliminate the ~c[hide] term
  in the proof of ~c[thm-helper] you should include the hint
  ~c[:expand] ~c[(hide (another-fn 1 2 3))].  Second, to prevent the
  ~c[hide] term from being reintroduced when the system tries and fails
  to evaluate ~c[(another-fn 1 2 3)] you should include the hint
  ~c[:in-theory] ~c[(disable (:executable-counterpart another-fn))].
  Thus, ~c[thm-helper] will actually be:
  ~bv[]
  (defthm thm-helper
    (equal (hide (another-fn 1 2 3)) (constrained-fn 1 2 3))
    :hints
    ((\"Goal\" :expand (hide (another-fn 1 2 3))
             :in-theory (disable (:executable-counterpart another-fn)))))
  ~ev[]

  ~l[eviscerate-hide-terms] for how to affect the printing of ~c[hide]
  terms."

  (declare (xargs :guard t))
  x)

(defun rewrite-equiv (x)

; Documentation to be written.  This is experimental for Version_3.1, to be
; tried out by Dave Greve.

  (declare (xargs :mode :logic :guard t))
  x)

; As of ACL2 Version_2.5, we can compile with or without support for
; non-standard analysis.  To make maintenance of the two versions simpler,
; we define the macro "real/rationalp" which is defined as either realp or
; rationalp depending on whether the reals exist in the current ACL2
; universe or not.

(defmacro real/rationalp (x)

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for rational numbers (including real number in ACL2(r))~/

  For most ACL2 users, this is a macro abbreviating ~ilc[rationalp].  In
  ACL2(r) (~pl[real]), this macro abbreviates the predicate ~c[realp], which
  holds for real numbers as well (including rationals).  Most ACL2 users can
  ignore this macro and use ~ilc[rationalp] instead, but many community books
  use ~c[real/rationalp] so that these books will be suitable for ACL2(r) as
  well.~/~/"

  #+:non-standard-analysis
  `(realp ,x)
  #-:non-standard-analysis
  `(rationalp ,x))

(defmacro complex/complex-rationalp (x)

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for complex numbers~/

  For most ACL2 users, this is a macro abbreviating ~c[complex-rationalp];
  ~pl[complex-rationalp].  In ACL2(r) (~pl[real]), a complex number ~c[x] may
  have irrational real and imaginary parts.  This macro abbreviates the
  predicate ~c[complexp] in ACL2(r), which holds for such ~c[x].  Most ACL2
  users can ignore this macro and use ~ilc[complex-rationalp] instead.  Some
  community books use ~c[complex/complex-rationalp] so that they are suitable
  for ACL2(r) as well.~/~/"

  #+:non-standard-analysis
  `(complexp ,x)
  #-:non-standard-analysis
  `(complex-rationalp ,x))

; Comments labeled "RAG" are from Ruben Gamboa, pertaining to his work
; in creating ACL2(r) (see :doc real).

(defun true-listp (x)

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for proper (null-terminated) lists~/

  ~c[True-listp] is the function that checks whether its argument is a
  list that ends in, or equals, ~c[nil].

  To see the ACL2 definition of this function, ~pl[pf].~/~/"

  (declare (xargs :guard t :mode :logic))
  (if (consp x)
      (true-listp (cdr x))
    (eq x nil)))

(defun list-macro (lst)
  (declare (xargs :guard t))
  (if (consp lst)
      (cons 'cons
            (cons (car lst)
                  (cons (list-macro (cdr lst)) nil)))
      nil))

#+acl2-loop-only
(defmacro list (&rest args)

  ":Doc-Section ACL2::ACL2-built-ins

  build a list~/

  ~c[List] is the macro for building a list of objects.  For example,
  ~c[(list 5 6 7)] returns a list of length 3 whose elements are ~c[5],
  ~c[6], and ~c[7] respectively.  Also ~pl[list*].~/

  ~c[List] is defined in Common Lisp.  See any Common Lisp documentation
  for more information.~/"

  (list-macro args))

(defun and-macro (lst)
  (declare (xargs :guard t))
  (if (consp lst)
      (if (consp (cdr lst))
          (list 'if (car lst)
                (and-macro (cdr lst))
                nil)
        (car lst))
    t))

#+acl2-loop-only
(defmacro and (&rest args)

  ":Doc-Section ACL2::ACL2-built-ins

  conjunction~/

  ~c[And] is the macro for conjunctions.  ~c[And] takes any number of
  arguments.  ~c[And] returns ~c[nil] if one of the arguments is ~c[nil],
  but otherwise returns the last argument.  If there are no arguments,
  ~c[and] returns ~c[t].~/

  ~c[And] is a Common Lisp macro.  See any Common Lisp documentation
  for more information.~/"

 (and-macro args))

(defun or-macro (lst)
  (declare (xargs :guard t))
  (if (consp lst)
      (if (consp (cdr lst))
          (list 'if
                (car lst)
                (car lst)
                (or-macro (cdr lst)))
        (car lst))
    nil))

#+acl2-loop-only
(defmacro or (&rest args)

  ":Doc-Section ACL2::ACL2-built-ins

  disjunction~/

  ~c[Or] is the macro for disjunctions.  ~c[Or] takes any number of
  arguments and returns the first that is non-~c[nil], or ~c[nil] if
  there is no non-~c[nil] element.~/

  In the ACL2 logic, the macroexpansion of ~c[(or x y)] is an ~c[IF] term that
  appears to cause ~c[x] to be evaluated twice:
  ~bv[]
  ACL2 !>:trans (or x y)

  (IF X X Y)

  => *

  ACL2 !>
  ~ev[]
  If ~c[x] were replaced by an expression whose evaluation takes a long time,
  then such an expansion would be ineffecient.  However, don't be fooled: you
  can expect Common Lisp implementations to avoid this problem, say by
  generating a new variable, for example:
  ~bv[]
  ACL2 !>:q ; Exit the ACL2 loop and go into raw Common Lisp

  Exiting the ACL2 read-eval-print loop.  To re-enter, execute (LP).
  ACL2>(macroexpand '(or x y))

  (LET ((#:G5374 X)) (IF #:G5374 #:G5374 Y))
  T

  ACL2>
  ~ev[]

  ~c[Or] is a Common Lisp macro.  See any Common Lisp documentation
  for more information.~/"

   (or-macro args))

#+acl2-loop-only
(defmacro - (x &optional (y 'nil binary-casep))

; In the general case, (- x y) expands to (binary-+ x (unary-- y)).  But in the
; special case that y is a numeric constant we go ahead and run the unary--
; and we put it in front of x in the binary-+ expression so that it is in the
; expected "normal" form.  Thus, (- x 1) expands to (binary-+ -1 x).  Two forms
; of y allow this "constant folding": explicit numbers and the quotations of
; explicit numbers.

; Constant folding is important in processing definitions.  If the user has
; written (1- x), we translate that to (binary-+ -1 x) instead of to the more
; mechanical (binary-+ (unary-- 1) x).  Note that the type of the former is
; easier to determine that the latter because type-set knows about the effect
; of adding the constant -1 to a positive, but not about adding the term (- 1).

  (if binary-casep

; First we map 'n to n so we don't have so many cases.

      (let ((y (if (and (consp y)
                        (eq (car y) 'quote)
                        (consp (cdr y))
                        (acl2-numberp (car (cdr y)))
                        (eq (cdr (cdr y)) nil))
                   (car (cdr y))
                   y)))
        (if (acl2-numberp y)
            (cons 'binary-+
                  (cons (unary-- y)
                        (cons x nil)))
            (cons 'binary-+
                  (cons x
                        (cons (cons 'unary-- (cons y nil))
                              nil)))))
      (let ((x (if (and (consp x)
                        (eq (car x) 'quote)
                        (consp (cdr x))
                        (acl2-numberp (car (cdr x)))
                        (eq (cdr (cdr x)) nil))
                   (car (cdr x))
                   x)))
        (if (acl2-numberp x)
            (unary-- x)
            (cons 'unary-- (cons x nil))))))

(defthm booleanp-compound-recognizer
  (equal (booleanp x)
         (or (equal x t)
             (equal x nil)))
  :rule-classes :compound-recognizer)

(in-theory (disable booleanp))

; integer-abs is just abs if x is an integer and is 0 otherwise.
; integer-abs is used because we don't know that that (abs x) is a
; nonnegative integer when x is an integer.  By using integer-abs in
; the defun of acl2-count below we get that the type-prescription for
; acl2-count is a nonnegative integer.

(defun integer-abs (x)
  (declare (xargs :guard t))
  (if (integerp x)
      (if (< x 0) (- x) x)
      0))

(defun xxxjoin (fn args)

 " (xxxjoin fn args) spreads the binary function symbol fn over args, a list
 of arguments.  For example,

      (xxxjoin '+ '(1 2 3)) = '(+ 1 (+ 2 3)))."

  (declare (xargs :guard (if (true-listp args)
                             (cdr args)
                           nil)
                  :mode :program))
  (if (cdr (cdr args))
      (cons fn
            (cons (car args)
                  (cons (xxxjoin fn (cdr args))
                        nil)))
    (cons fn args)))

#+acl2-loop-only
(defmacro + (&rest rst)
  (if rst
      (if (cdr rst)
          (xxxjoin 'binary-+ rst)
          (cons 'binary-+ (cons 0 (cons (car rst) nil))))
      0))

; We now define length (and its subroutine len) so we can use them in
; acl2-count.

#-acl2-loop-only
(defun-one-output len2 (x acc)
  (cond ((atom x) acc)
        (t (len2 (cdr x) (1+ acc)))))

#-acl2-loop-only
(defun len1 (x acc)

; This function is an optimized version of len2 above, which is a simple
; tail-recursive implementation of len.

   (declare (type fixnum acc))
   (the fixnum ; to assist in ACL2's proclaiming
        (cond ((atom x) acc)
              ((eql (the fixnum acc) most-positive-fixnum)
               #+(or gcl ccl allegro sbcl cmu
                     (and lispworks lispworks-64bit))

; The error below is entirely optional, and can be safely removed from the
; code.  Here is the story.

; We cause an error for the Lisps listed above in order to highlight the
; violation of the following expectation for those Lisps: the length of a list
; is always bounded by most-positive-fixnum.  To be safe, we omit CLISP and
; 32-bit LispWorks (where most-positive-fixnum is only 16777215 and 8388607,
; respectively; see the Essay on Fixnum Declarations).  But for the Lisps in
; the above readtime conditional, we believe the above expectation because a
; cons takes at least 8 bytes and each of the lisps below has
; most-positive-fixnum of at least approximately 2^29.

               (error "We have encountered a list whose length exceeds ~
                       most-positive-fixnum!")
               -1)
              (t (len1 (cdr x) (the fixnum (+ (the fixnum acc) 1)))))))

(defun len (x)

  ":Doc-Section ACL2::ACL2-built-ins

  length of a list~/

  ~c[Len] returns the length of a list.~/

  A Common Lisp function that is appropriate for both strings and
  proper lists is ~c[length]; ~pl[length].  The guard for ~c[len] is ~c[t].

  (Low-level implementation note.  ACL2 provides a highly-optimized
  implementation of ~c[len], which is tail-recursive and fixnum-aware, that
  differs from its simple ACL2 definition.)

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard t :mode :logic))
  #-acl2-loop-only
  (return-from len
               (let ((val (len1 x 0)))
                 (if (eql val -1)
                     (len2 x 0)
                   val)))
  (if (consp x)
      (+ 1 (len (cdr x)))
      0))

#+acl2-loop-only
(defun length (x)

  ":Doc-Section ACL2::ACL2-built-ins

  length of a string or proper list~/

  ~c[Length] is the function for determining the length of a sequence.
  In ACL2, the argument is required to be either a ~ilc[true-listp] or a
  string.~/

  ~c[Length] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (if (true-listp x)
                             t
                             (stringp x))
                  :mode :logic))
  (if (stringp x)
      (len (coerce x 'list))
      (len x)))

#-acl2-loop-only
(defun-one-output complex-rationalp (x)
  (complexp x))

(defun acl2-count (x)

 ":Doc-Section ACL2::ACL2-built-ins

  a commonly used measure for justifying recursion~/

  ~c[(Acl2-count x)] returns a nonnegative integer that indicates the
  ``size'' of its argument ~c[x].~/

  All ~il[characters] and symbols have ~c[acl2-count 0].  The ~c[acl2-count] of a
  string is the number of ~il[characters] in it, i.e., its length.  The
  ~c[acl2-count] of a ~ilc[cons] is one greater than the sum of the ~c[acl2-count]s
  of the ~ilc[car] and ~ilc[cdr].  The ~c[acl2-count] of an integer is its absolute
  value.  The ~c[acl2-count] of a rational is the sum of the ~c[acl2-count]s
  of the numerator and denominator.  The ~c[acl2-count] of a complex
  rational is one greater than the sum of the ~c[acl2-count]s of the real
  and imaginary parts."

; We used to define the acl2-count of symbols to be (+ 1 (length
; (symbol-name x))) but then found it useful to make the acl2-count of
; NIL be 0 so that certain normalizations didn't explode the count.
; We then made the count of all symbols 0.  This broad stroke was not
; strictly necessary, as far as we can see, it just simplifies the
; definition of acl2-count and does not seem to affect the common
; recursions and inductions.

  (declare (xargs :guard t))
  (if (consp x)
      (+ 1
         (acl2-count (car x))
         (acl2-count (cdr x)))
      (if (rationalp x)
          (if (integerp x)
              (integer-abs x)
              (+ (integer-abs (numerator x))
                 (denominator x)))
          (if (complex/complex-rationalp x)
              (+ 1
                 (acl2-count (realpart x))
                 (acl2-count (imagpart x)))
              (if (stringp x)
                  (length x)
                  0)))))

; The following rewrite rule may be useful for termination proofs, but
; at this point it seems premature to claim any kind of understanding
; of how to integrate such rules with appropriate linear rules.

; (defthm acl2-count-consp
;   (implies (consp x)
;            (equal (acl2-count x)
;                   (+ 1
;                      (acl2-count (car x))
;                      (acl2-count (cdr x))))))

(defun cond-clausesp (clauses)
  (declare (xargs :guard t))
  (if (consp clauses)
      (and (consp (car clauses))
           (true-listp (car clauses))
           (< (len (car clauses)) 3)
           (cond-clausesp (cdr clauses)))
    (eq clauses nil)))

(defun cond-macro (clauses)
  (declare (xargs :guard (cond-clausesp clauses)))
  (if (consp clauses)
      (if (and (eq (car (car clauses)) t)
               (eq (cdr clauses) nil))
          (if (cdr (car clauses))
              (car (cdr (car clauses)))
            (car (car clauses)))
        (if (cdr (car clauses))
            (list 'if
                  (car (car clauses))
                  (car (cdr (car clauses)))
                  (cond-macro (cdr clauses)))

; We could instead generate the IF term corresponding to the expansion of the
; following OR term, and that is what we did through Version_3.3.  But the
; extra cost of further expanding this OR call is perhaps outweighed by the
; advantage that tools using macroexpand1 can see the OR, which is an odd macro
; in that its logical expansion can result in evaluating the first argument
; twice.

          (list 'or
                (car (car clauses))
                (cond-macro (cdr clauses)))))
    nil))

#+acl2-loop-only
(defmacro cond (&rest clauses)

  ":Doc-Section ACL2::ACL2-built-ins

  conditional based on if-then-else~/

  ~c[Cond] is the construct for IF, THEN, ELSE IF, ...  The test is
  against ~c[nil].  The argument list for ~c[cond] is a list of
  ``clauses'', each of which is a list.  In ACL2, clauses must have
  length 1 or 2.~/

  ~c[Cond] is a Common Lisp macro.  See any Common Lisp
  documentation for more information.~/"

  (declare (xargs :guard (cond-clausesp clauses)))
  (cond-macro clauses))

; The function eqlablep is :common-lisp-compliant even during the first pass,
; in order to support the definition of eql, which is in
; *expandable-boot-strap-non-rec-fns* and hence needs to be
; :common-lisp-compliant.

(defun eqlablep (x)

  ":Doc-Section ACL2::ACL2-built-ins

  the ~il[guard] for the function ~ilc[eql]~/

  The predicate ~c[eqlablep] tests whether its argument is suitable for
  ~ilc[eql], at least one of whose arguments must satisfy this predicate
  in Common Lisp.  ~c[(Eqlablep x)] is true if and only if its argument
  is a number, a symbol, or a character.

  To see the ACL2 definition of this function, ~pl[pf].~/~/"

  (declare (xargs :mode :logic :guard t))
  (or (acl2-numberp x)
      (symbolp x)
      (characterp x)))

; Note: Eqlablep is the guard on the function eql.  Eql is on *expandable-boot-
; strap-non-rec-fns* and is hence expanded by type-set and assume-true-false
; when its guard is established.  Thus, the system works best if eqlablep is
; known to be a compound recognizer so that type-set can work with it when it
; sees it in the guard of eql.

(defthm eqlablep-recog
  (equal (eqlablep x)
         (or (acl2-numberp x)
             (symbolp x)
             (characterp x)))
  :rule-classes :compound-recognizer)

(in-theory (disable eqlablep))

(defun eqlable-listp (l)

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for a true list of objects each suitable for ~ilc[eql]~/

  The predicate ~c[eqlable-listp] tests whether its argument is a
  ~ilc[true-listp] of objects satisfying ~ilc[eqlablep].

  To see the ACL2 definition of this function, ~pl[pf].~/~/"

  (declare (xargs :mode :logic :guard t))
  (if (consp l)
      (and (eqlablep (car l))
           (eqlable-listp (cdr l)))
    (equal l nil)))

#+acl2-loop-only
(defun eql (x y)
  (declare (xargs :mode :logic
                  :guard (or (eqlablep x)
                             (eqlablep y))))
  ":Doc-Section ACL2::ACL2-built-ins

  test equality (of two numbers, symbols, or ~il[characters])~/

  ~c[(eql x y)] is logically equivalent to ~c[(equal x y)].~/

  Unlike ~ilc[equal], ~c[eql] has a ~il[guard] requiring at least one of its
  arguments to be a number, a symbol, or a character.  Generally,
  ~c[eql] is executed more efficiently than ~ilc[equal].

  For a discussion of the various ways to test against 0,
  ~l[zero-test-idioms].

  ~c[Eql] is a Common Lisp function.  See any Common Lisp documentation
  for more information.~/"

  (equal x y))

#+acl2-loop-only
(defun atom (x)

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for atoms~/

  ~c[(atom x)] is true if and only if ~c[x] is an atom, i.e., not a
  ~ilc[cons] pair.~/

  ~c[Atom] has a ~il[guard] of ~c[t], and is a Common Lisp function.  See any
  Common Lisp documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

 (declare (xargs :mode :logic :guard t))
 (not (consp x)))

; We use this in the *1* code for coerce.

(defun make-character-list (x)

  ":Doc-Section ACL2::ACL2-built-ins

  ~il[coerce] to a list of characters~/

  Non-characters in the given list are ~il[coerce]d to the character with
  code 0.

  To see the ACL2 definition of this function, ~pl[pf].~/~/"

  (declare (xargs :guard t))
  (cond ((atom x) nil)
        ((characterp (car x))
         (cons (car x) (make-character-list (cdr x))))
        (t

; There's nothing special about (code-char 0), but at least it will look
; strange when people come across it.

         (cons (code-char 0) (make-character-list (cdr x))))))

(defun eqlable-alistp (x)

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for a true list of pairs whose ~ilc[car]s are suitable for ~ilc[eql]~/

  The predicate ~c[eqlable-alistp] tests whether its argument is a
  ~ilc[true-listp] of ~ilc[consp] objects whose ~ilc[car]s all satisfy
  ~ilc[eqlablep].

  To see the ACL2 definition of this function, ~pl[pf].~/~/"

  (declare (xargs :guard t))
  (cond ((atom x) (equal x nil))
        (t (and (consp (car x))
                (eqlablep (car (car x)))
                (eqlable-alistp (cdr x))))))

(defun alistp (l)

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for association lists~/

  ~c[(alistp x)] is true if and only if ~c[x] is a list of ~ilc[cons] pairs.~/

  ~c[(alistp x)] has a ~il[guard] of ~c[t].

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard t))
  (cond ((atom l) (eq l nil))
        (t (and (consp (car l)) (alistp (cdr l))))))

(defthm alistp-forward-to-true-listp
  (implies (alistp x)
           (true-listp x))
  :rule-classes :forward-chaining)

(defthm eqlable-alistp-forward-to-alistp
  (implies (eqlable-alistp x)
           (alistp x))
  :rule-classes :forward-chaining)

#+acl2-loop-only
(defun acons (key datum alist)

  ":Doc-Section ACL2::ACL2-built-ins

  constructor for association lists~/

  ~c[(Acons key datum alist)] equals the result of consing the pair
  ~c[(cons key datum)] to the front of the association list ~c[alist].~/

  ~c[(Acons key datum alist)] has a ~il[guard] of ~c[(alistp alist)].
  ~c[Acons] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (alistp alist)))
  (cons (cons key datum) alist))

#+acl2-loop-only
(defun endp (x)

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for empty lists~/

  In the ACL2 logic, ~c[(endp x)] is the same as ~c[(atom x)].
  ~l[atom].~/

  Unlike ~ilc[atom], the ~il[guard] for ~c[endp] requires that ~c[x] is a
  ~ilc[cons] pair or is ~c[nil].  Thus, ~c[endp] is typically used as a
  termination test for functions that recur on a ~ilc[true-listp]
  argument.  ~l[guard] for general information about ~il[guard]s.

  ~c[Endp] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :mode :logic
                  :guard (or (consp x) (eq x nil))))
  (atom x))

#+acl2-loop-only
(defmacro caar (x)
  ":Doc-Section ACL2::ACL2-built-ins

  ~ilc[car] of the ~ilc[car]~/

  See any Common Lisp documentation for details.~/~/"
  (list 'car (list 'car x)))

#+acl2-loop-only
(defmacro cadr (x)
  ":Doc-Section ACL2::ACL2-built-ins

  ~ilc[car] of the ~ilc[cdr]~/

  See any Common Lisp documentation for details.~/~/"
  (list 'car (list 'cdr x)))

#+acl2-loop-only
(defmacro cdar (x)
  ":Doc-Section ACL2::ACL2-built-ins

  ~ilc[cdr] of the ~ilc[car]~/

  See any Common Lisp documentation for details.~/~/"
  (list 'cdr (list 'car x)))

#+acl2-loop-only
(defmacro cddr (x)
  ":Doc-Section ACL2::ACL2-built-ins

  ~ilc[cdr] of the ~ilc[cdr]~/

  See any Common Lisp documentation for details.~/~/"
  (list 'cdr (list 'cdr x)))

#+acl2-loop-only
(defmacro caaar (x)
  ":Doc-Section ACL2::ACL2-built-ins

  ~ilc[car] of the ~ilc[caar]~/

  See any Common Lisp documentation for details.~/~/"
  (list 'car (list 'caar x)))

#+acl2-loop-only
(defmacro caadr (x)
  ":Doc-Section ACL2::ACL2-built-ins

  ~ilc[car] of the ~ilc[cadr]~/

  See any Common Lisp documentation for details.~/~/"
  (list 'car (list 'cadr x)))

#+acl2-loop-only
(defmacro cadar (x)
  ":Doc-Section ACL2::ACL2-built-ins

  ~ilc[car] of the ~ilc[cdar]~/

  See any Common Lisp documentation for details.~/~/"
  (list 'car (list 'cdar x)))

#+acl2-loop-only
(defmacro caddr (x)
  ":Doc-Section ACL2::ACL2-built-ins

  ~ilc[car] of the ~ilc[cddr]~/

  See any Common Lisp documentation for details.~/~/"
  (list 'car (list 'cddr x)))

#+acl2-loop-only
(defmacro cdaar (x)
  ":Doc-Section ACL2::ACL2-built-ins

  ~ilc[cdr] of the ~ilc[caar]~/

  See any Common Lisp documentation for details.~/~/"
  (list 'cdr (list 'caar x)))

#+acl2-loop-only
(defmacro cdadr (x)
  ":Doc-Section ACL2::ACL2-built-ins

  ~ilc[cdr] of the ~ilc[cadr]~/

  See any Common Lisp documentation for details.~/~/"
  (list 'cdr (list 'cadr x)))

#+acl2-loop-only
(defmacro cddar (x)
  ":Doc-Section ACL2::ACL2-built-ins

  ~ilc[cdr] of the ~ilc[cdar]~/

  See any Common Lisp documentation for details.~/~/"
  (list 'cdr (list 'cdar x)))

#+acl2-loop-only
(defmacro cdddr (x)
  ":Doc-Section ACL2::ACL2-built-ins

  ~ilc[cdr] of the ~ilc[cddr]~/

  See any Common Lisp documentation for details.~/~/"
  (list 'cdr (list 'cddr x)))

#+acl2-loop-only
(defmacro caaaar (x)
  ":Doc-Section ACL2::ACL2-built-ins

  ~ilc[car] of the ~ilc[caaar]~/

  See any Common Lisp documentation for details.~/~/"
  (list 'car (list 'caaar x)))

#+acl2-loop-only
(defmacro caaadr (x)
  ":Doc-Section ACL2::ACL2-built-ins

  ~ilc[car] of the ~ilc[caadr]~/

  See any Common Lisp documentation for details.~/~/"
  (list 'car (list 'caadr x)))

#+acl2-loop-only
(defmacro caadar (x)
  ":Doc-Section ACL2::ACL2-built-ins

  ~ilc[car] of the ~ilc[cadar]~/

  See any Common Lisp documentation for details.~/~/"
  (list 'car (list 'cadar x)))

#+acl2-loop-only
(defmacro caaddr (x)
  ":Doc-Section ACL2::ACL2-built-ins

  ~ilc[car] of the ~ilc[caddr]~/

  See any Common Lisp documentation for details.~/~/"
  (list 'car (list 'caddr x)))

#+acl2-loop-only
(defmacro cadaar (x)
  ":Doc-Section ACL2::ACL2-built-ins

  ~ilc[car] of the ~ilc[cdaar]~/

  See any Common Lisp documentation for details.~/~/"
  (list 'car (list 'cdaar x)))

#+acl2-loop-only
(defmacro cadadr (x)
  ":Doc-Section ACL2::ACL2-built-ins

  ~ilc[car] of the ~ilc[cdadr]~/

  See any Common Lisp documentation for details.~/~/"
  (list 'car (list 'cdadr x)))

#+acl2-loop-only
(defmacro caddar (x)
  ":Doc-Section ACL2::ACL2-built-ins

  ~ilc[car] of the ~ilc[cddar]~/

  See any Common Lisp documentation for details.~/~/"
  (list 'car (list 'cddar x)))

#+acl2-loop-only
(defmacro cadddr (x)
  ":Doc-Section ACL2::ACL2-built-ins

  ~ilc[car] of the ~ilc[cdddr]~/

  See any Common Lisp documentation for details.~/~/"
  (list 'car (list 'cdddr x)))

#+acl2-loop-only
(defmacro cdaaar (x)
  ":Doc-Section ACL2::ACL2-built-ins

  ~ilc[cdr] of the ~ilc[caaar]~/

  See any Common Lisp documentation for details.~/~/"
  (list 'cdr (list 'caaar x)))

#+acl2-loop-only
(defmacro cdaadr (x)
  ":Doc-Section ACL2::ACL2-built-ins

  ~ilc[cdr] of the ~ilc[caadr]~/

  See any Common Lisp documentation for details.~/~/"
  (list 'cdr (list 'caadr x)))

#+acl2-loop-only
(defmacro cdadar (x)
  ":Doc-Section ACL2::ACL2-built-ins

  ~ilc[cdr] of the ~ilc[cadar]~/

  See any Common Lisp documentation for details.~/~/"
  (list 'cdr (list 'cadar x)))

#+acl2-loop-only
(defmacro cdaddr (x)
  ":Doc-Section ACL2::ACL2-built-ins

  ~ilc[cdr] of the ~ilc[caddr]~/

  See any Common Lisp documentation for details.~/~/"
  (list 'cdr (list 'caddr x)))

#+acl2-loop-only
(defmacro cddaar (x)
  ":Doc-Section ACL2::ACL2-built-ins

  ~ilc[cdr] of the ~ilc[cdaar]~/

  See any Common Lisp documentation for details.~/~/"
  (list 'cdr (list 'cdaar x)))

#+acl2-loop-only
(defmacro cddadr (x)
  ":Doc-Section ACL2::ACL2-built-ins

  ~ilc[cdr] of the ~ilc[cdadr]~/

  See any Common Lisp documentation for details.~/~/"
  (list 'cdr (list 'cdadr x)))

#+acl2-loop-only
(defmacro cdddar (x)
  ":Doc-Section ACL2::ACL2-built-ins

  ~ilc[cdr] of the ~ilc[cddar]~/

  See any Common Lisp documentation for details.~/~/"
  (list 'cdr (list 'cddar x)))

#+acl2-loop-only
(defmacro cddddr (x)
  ":Doc-Section ACL2::ACL2-built-ins

  ~ilc[cdr] of the ~ilc[cdddr]~/

  See any Common Lisp documentation for details.~/~/"
  (list 'cdr (list 'cdddr x)))

#+acl2-loop-only
(defun null (x)

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for the empty list~/

  ~c[Null] is the function that checks whether its argument is ~c[nil].
  For recursive definitions it is often preferable to test for the end
  of a list using ~ilc[endp] instead of ~c[null]; ~pl[endp].~/

  ~c[Null] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :mode :logic :guard t))
  (eq x nil))

(defun symbol-listp (lst)

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for a true list of symbols~/

  The predicate ~c[symbol-listp] tests whether its argument is a
  true list of symbols.

  To see the ACL2 definition of this function, ~pl[pf].~/~/"

  (declare (xargs :guard t :mode :logic))
  (cond ((atom lst) (eq lst nil))
        (t (and (symbolp (car lst))
                (symbol-listp (cdr lst))))))

(defthm symbol-listp-forward-to-true-listp
  (implies (symbol-listp x)
           (true-listp x))
  :rule-classes :forward-chaining)

(defun symbol-doublet-listp (lst)

; This function returns t iff lst is a true-list and each element is
; a doublet of the form (symbolp anything).

  (declare (xargs :guard t))
  (cond ((atom lst) (eq lst nil))
        (t (and (consp (car lst))
                (symbolp (caar lst))
                (consp (cdar lst))
                (null (cddar lst))
                (symbol-doublet-listp (cdr lst))))))

; Essay on Strip-cars -- To Tail Recur or not to Tail Recur?

; We have seen instances where strip-cdrs causes a segmentation fault because
; it overflows the stack.  We therefore decided to recode strip-cdrs in a
; tail-recursive way.  We therefore decided to do the same thing to strip-cars.
; This essay is about strip-cars but the issues are the same for strip-cdrs, we
; believe.

; First, what is the longest list you can strip-cars without a segmentation
; fault.  The answer for

; GCL (GNU Common Lisp)  Version(2.2.1) Wed Mar 12 00:47:19 CST 1997

; is 74790, when the test form is (length (strip-cars test-lst)).  Because our
; test forms below are a little more elaborate, we will do our tests on a list
; of length 74000:

; (defvar test-lst
;   (loop for i from 1 to 74000 collect (cons i i)))

; Just for the record, how long does it take to do strip-cars 30 times on this
; test-lst?  Answer: 6.190 seconds.

; (proclaim-form
;  (defun test1 (n)
;    (loop for i from 1 to n do (strip-cars test-lst))))
;
; (compile 'test1)
;
; (time (test1 30))

; Now the obvious tail recursive version of strip-cars is:

; (proclaim-form
;  (defun strip-cars2 (x a)
;    (if (endp x)
;        (reverse a)
;      (strip-cars2 (cdr x) (cons (car (car x)) a)))))
;
; (compile 'strip-cars2)
;
; (proclaim-form
;  (defun test2 (n)
;    (loop for i from 1 to n do (strip-cars2 test-lst))))
;
; (compile 'test2)
;
; (time (test2 30))

; This function is actually faster than strip-cars: 5.530 seconds!  That is
; surprising because this function does TWICE as many conses, since it conses
; up the final answer from the accumulated partial one.  The reason this
; function beats strip-cars can only be that that the tail-recursive jump is
; quite a lot faster than a function call.

; But Common Lisp allows to avoid consing to do a reverse if we are willing to
; smash the existing spine.  And in this case we are, since we have just consed
; it up.  So here is a revised function that only does as many conses as
; strip-cars:

; (proclaim-form
;  (defun strip-cars3 (x a)
;    (if (endp x)
;        (nreverse a)   ;;; Note destructive reverse!
;      (strip-cars3 (cdr x) (cons (car (car x)) a)))))
;
; (compile 'strip-cars3)
;
; (proclaim-form
;  (defun test3 (n)
;    (loop for i from 1 to n do (strip-cars3 test-lst))))
;
; (compile 'test3)
;
; (time (test3 30))

; This function takes 2.490 seconds.

; Therefore, we decided to code strip-cars (and strip-cdrs) in the style of
; strip-cars3 above.

; However, we did not want to do define strip-cars tail-recursively because
; proofs about strip-cars -- both in our system build and in user theorems
; about strip-cars -- would have to use the accumulator-style generalization.
; So we decided to keep strip-cars defined, logically, just as it was and to
; make its #-acl2-loop-only executable code be tail recursive, as above.

; The next paragraph is bogus!  But it used to read as follows (where
; strip-cars1 was essentially what we now call reverse-strip-cars).

;  Furthermore, we decided that strip-cars1 is a perfectly nice
;  function the user might want, so we added it to the logic first --
;  changing the nreverse to a reverse for logical purposes but leaving
;  the nreverse in for execution.  This way, if the user wants an
;  accumulator-version of strip-cars, he can have it and it will be
;  very fast.  But if he wants a simple recursive version he can have
;  it too.

; That is unsound because we don't know that the accumulator is all new conses
; and so we can't smash it!  So the use of nreverse is hidden from the user.

; We could, of course, use mbe (which was not available when strip-cars and
; strip-cdrs were originally defined in ACL2).  However, we wish to cheat using
; nreverse, so it doesn't seem that nreverse buys us anything.  We do note that
; ACL2 can prove the following theorems.

; (defthm reverse-strip-cars-property
;   (equal (reverse-strip-cars x acc)
;          (revappend (strip-cars x) acc)))
;
; (defthm reverse-strip-cdrs-property
;   (equal (reverse-strip-cdrs x acc)
;          (revappend (strip-cdrs x) acc)))

(defun reverse-strip-cars (x a)
  (declare (xargs :guard (alistp x)))
  (cond ((endp x) a)
        (t (reverse-strip-cars (cdr x)
                               (cons (car (car x)) a)))))

(defun strip-cars (x)

  ":Doc-Section ACL2::ACL2-built-ins

  collect up all first components of pairs in a list~/

  ~c[(strip-cars x)] is the list obtained by walking through the list ~c[x] and
  collecting up all first components (~ilc[car]s).  This function is
  implemented in a tail-recursive way, despite its logical definition.~/

  ~c[(strip-cars x)] has a ~il[guard] of ~c[(alistp x)].

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (alistp x)))

; See the Essay on Strip-cars -- To Tail Recur or not to Tail Recur?  above.

  #-acl2-loop-only
  (nreverse (reverse-strip-cars x nil))
  #+acl2-loop-only
  (cond ((endp x) nil)
        (t (cons (car (car x))
                 (strip-cars (cdr x))))))

(defun reverse-strip-cdrs (x a)
  (declare (xargs :guard (alistp x)))
  (cond ((endp x) a)
        (t (reverse-strip-cdrs (cdr x)
                               (cons (cdr (car x)) a)))))

(defun strip-cdrs (x)

  ":Doc-Section ACL2::ACL2-built-ins

  collect up all second components of pairs in a list~/

  ~c[(strip-cdrs x)] has a ~il[guard] of ~c[(alistp x)], and returns the list
  obtained by walking through the list ~c[x] and collecting up all second
  components (~ilc[cdr]s).  This function is implemented in a tail-recursive
  way, despite its logical definition.

  To see the ACL2 definition of this function, ~pl[pf].~/~/"

  (declare (xargs :guard (alistp x)))

; See the Essay on Strip-cars -- To Tail Recur or not to Tail Recur?  above.

  #-acl2-loop-only
  (nreverse (reverse-strip-cdrs x nil))
  #+acl2-loop-only
  (cond ((endp x) nil)
        (t (cons (cdr (car x))
                 (strip-cdrs (cdr x))))))

(defmacro let-mbe (bindings &key logic exec)
  `(let ,bindings
     (mbe :logic ,logic
          :exec ,exec)))

#+acl2-loop-only
(defun return-last (fn eager-arg last-arg)

; Return-last is the one "function" in ACL2 that has no fixed output signature.
; Rather, (return-last expr1 expr2) inherits its stobjs-out from expr2.
; Because of this, we make it illegal to call stobjs-out on the symbol
; return-last.  We think of expr1 as being evaluated eagerly because even in
; the raw Lisp implementation of return-last, that argument is always evaluated
; first just as with a function call.  By contrast, if fn is a macro then it
; can manipulate last-arg arbitrarily before corresponding evaluation occurs.
; In many applications of return-last, eager-arg will be nil; for others, such
; as with-prover-time-limit, eager-arg will be used to control the evaluation
; of (some version of) last-arg.

; The following little example provides a small check on our handling of
; return-last, both via ev-rec (for evaluating top-level forms) and via more
; direct function evaluation (either *1* functions or their raw Lisp
; counterparts).

;  (defun foo (x)
;    (time$ (mbe :logic (prog2$ (cw "**LOGIC~%") x)
;                :exec (prog2$ (cw "**EXEC~%") x))))
;  (defun bar (x) (foo x))
;  (foo 3) ; logic
;  (bar 3) ; logic
;  (verify-guards foo)
;  (foo 3) ; exec
;  (bar 3) ; exec

  ":Doc-Section ACL2::ACL2-built-ins

  return the last argument, perhaps with side effects~/

  ~c[Return-last] is an ACL2 function that returns its last argument.  It is
  used to implement common utilities such as ~ilc[prog2$] and ~ilc[time$].  For
  most users, this may already be more than one needs to know about
  ~c[return-last]; for example, ACL2 tends to avoid printing calls of
  ~c[return-last] in its output, printing calls of ~ilc[prog2$] or
  ~ilc[time$] (or other such utilities) instead.

  If you encounter a call of ~c[return-last] during a proof, then you may find
  it most useful to consider ~c[return-last] simply as a function defined by
  the following equation.
  ~bv[]
  (equal (return-last x y z) z)
  ~ev[]
  It may also be useful to know that unlike other ACL2 functions,
  ~c[return-last] can take a multiple value as its last argument, in which case
  this multiple value is returned.  The following contrived definition
  illustrates this point.
  ~bv[]
  ACL2 !>(defun foo (fn x y z)
           (return-last fn x (mv y z)))

  Since FOO is non-recursive, its admission is trivial.  We observe that
  the type of FOO is described by the theorem
  (AND (CONSP (FOO FN X Y Z)) (TRUE-LISTP (FOO FN X Y Z))).  We used
  primitive type reasoning.

  (FOO * * * *) => (MV * *).

  Summary
  Form:  ( DEFUN FOO ...)
  Rules: ((:FAKE-RUNE-FOR-TYPE-SET NIL))
  Time:  0.01 seconds (prove: 0.00, print: 0.00, other: 0.01)
   FOO
  ACL2 !>(foo 'bar 3 4 5)
  (4 5)
  ACL2 !>(mv-let (a b)
                 (foo 'bar 3 4 5)
                 (cons b a))
  (5 . 4)
  ACL2 !>
  ~ev[]

  Most readers would be well served to avoid reading the rest of this
  documentation of ~c[return-last].  For reference, however, below we document
  it in some detail.  We include some discussion of its evaluation, in
  particular its behavior in raw Lisp, because we expect that most who read
  further are working with raw Lisp code (and trust tags).~/

  ~c[Return-last] is an ACL2 function that can arise from macroexpansion of
  certain utilities that return their last argument, which may be a multiple
  value.  Consider for example the simplest of these, ~ilc[prog2$]:
  ~bv[]
  ACL2 !>:trans1 (prog2$ (cw \"Some CW printing...~~%\") (+ 3 4))
   (RETURN-LAST 'PROGN
                (CW \"Some CW printing...~~%\")
                (+ 3 4))
  ACL2 !>
  ~ev[]
  Notice that a call of ~c[prog2$] macroexpands to a call of ~c[return-last] in
  which the first argument is ~c[(quote progn)].  Although ~c[return-last] is a
  function in the ACL2 world, it is implemented ``under the hood'' as a macro
  in raw Lisp, as the following log (continuing the example above) illustrates.
  ~bv[]
  ACL2 !>:q

  Exiting the ACL2 read-eval-print loop.  To re-enter, execute (LP).
  ? [RAW LISP] (macroexpand-1 '(RETURN-LAST 'PROGN
                                             (CW \"Some CW printing...~~%\")
                                             (+ 3 4)))
  (PROGN (LET ((*AOKP* T)) (CW \"SOME CW PRINTING...~~%\")) (+ 3 4))
  T
  ? [RAW LISP]
  ~ev[]
  Thus, the original ~c[prog2$] call generates a corresponding call of
  ~c[progn] in raw Lisp, which in turn causes evaluation of each argument and
  returns whatever is returned by evaluation of the last (second) argument.

  (Remark for those who use ~ilc[defattach].  The binding of ~c[*aokp*] to
  ~c[t] is always included for the second argument as shown except when the
  first argument is of the form ~c[(QUOTE M)] where ~c[M] is a macro, or (less
  important) when the first argument is a symbol or a cons whose car is
  ~c[QUOTE].  This binding allows ACL2 to use attachments in the second
  argument of ~c[return-last] (hence, in the first argument of ~ilc[prog2$]),
  even in contexts such as proofs in which attachments are normally not
  allowed.  Those who use the experimental HONS version of ACL2
  (~pl[hons-and-memoization]) will see an additional binding in the above
  single-step macroexpansion, which allows the storing of memoized results even
  when that would otherwise be prevented because of the use of attachments.)

  In general, a form ~c[(return-last (quote F) X Y)] macroexpands to
  ~c[(F X Y)], where ~c[F] is defined in raw Lisp to return its last argument.
  The case that ~c[F] is ~c[progn] is a bit misleading, because it is so
  simple.  More commonly, macroexpansion produces a call of a macro defined in
  raw Lisp that may produce side effects.  Consider for example the ACL2
  utility ~ilc[with-guard-checking], which is intended to change the
  ~il[guard]-checking mode to the indicated value (~pl[with-guard-checking]).
  ~bv[]
  ACL2 !>(with-guard-checking :none (car 3)) ; no guard violation
  NIL
  ACL2 !>:trans1 (with-guard-checking :none (car 3))
   (WITH-GUARD-CHECKING1 (CHK-WITH-GUARD-CHECKING-ARG :NONE)
                         (CAR 3))
  ACL2 !>:trans1 (WITH-GUARD-CHECKING1 (CHK-WITH-GUARD-CHECKING-ARG :NONE)
                                       (CAR 3))
   (RETURN-LAST 'WITH-GUARD-CHECKING1-RAW
                (CHK-WITH-GUARD-CHECKING-ARG :NONE)
                (CAR 3))
  ACL2 !>:q

  Exiting the ACL2 read-eval-print loop.  To re-enter, execute (LP).
  ? [RAW LISP] (macroexpand-1
                '(RETURN-LAST 'WITH-GUARD-CHECKING1-RAW
                               (CHK-WITH-GUARD-CHECKING-ARG :NONE)
                               (CAR 3)))
  (WITH-GUARD-CHECKING1-RAW (CHK-WITH-GUARD-CHECKING-ARG :NONE) (CAR 3))
  T
  ? [RAW LISP] (pprint
                (macroexpand-1
                 '(WITH-GUARD-CHECKING1-RAW
                   (CHK-WITH-GUARD-CHECKING-ARG :NONE)
                   (CAR 3))))

  (LET ((ACL2_GLOBAL_ACL2::GUARD-CHECKING-ON
         (CHK-WITH-GUARD-CHECKING-ARG :NONE)))
    (DECLARE (SPECIAL ACL2_GLOBAL_ACL2::GUARD-CHECKING-ON))
    (CAR 3))
  ? [RAW LISP]
  ~ev[]
  The above raw Lisp code binds the state global variable ~c[guard-checking-on]
  to ~c[:none], as ~c[chk-with-guard-checking-arg] is just the identity
  function except for causing a hard error for an illegal input.

  The intended use of ~c[return-last] is that the second argument is evaluated
  first in a normal manner, and then the third argument is evaluated in an
  environment that may depend on the value of the second argument.  (For
  example, the macro ~ilc[with-prover-time-limit] macroexpands to a call of
  ~c[return-last] with a first argument of ~c['WITH-PROVER-TIME-LIMIT1-RAW], a
  second argument that evaluates to a numeric time limit, and a third argument
  that is evaluated in an environment where the theorem prover is restricted to
  avoid running longer than that time limit.)  Although this intended usage
  model is not strictly enforced, it is useful to keep in mind in the following
  description of how calls of ~c[return-last] are handled by the ACL2
  evaluator.

  When a form is submitted in the top-level loop, it is handled by ACL2's
  custom evaluator.  That evaluator is specified to respect the semantics of
  the expression supplied to it: briefly put, if an expression ~c[E] evaluates
  to a value ~c[V], then the equality ~c[(equal E (quote V))] should be a
  theorem.  Notice that this specification does not discuss the side-effects
  that may occur when evaluating a call of ~c[return-last], so we discuss that
  now.  Suppose that the ACL2 evaluator encounters the call
  ~c[(return-last 'fn expr1 expr2)].  First it evaluates ~c[expr1].  If this
  evaluation succeeds without error, then it constructs an expression of the
  form ~c[(fn *x* ev-form)], where *x* is a Lisp variable bound to the result
  of evaluating ~c[expr1] and ~c[ev-form] is a call of the evaluator for
  ~c[expr2].  (Those who want implementation details are invited to look at
  function ~c[ev-rec-return-last] in ACL2 source file ~c[translate.lisp].)
  There are exceptions if ~c[fn] is ~c[progn], ~c[ec-call1-raw],
  ~c[with-guard-checking1-raw], or ~c[mbe1-raw], but the main idea is the same:
  do a reasonable job emulating the behavior of a raw-Lisp call of
  ~c[return-last].

  The following log shows how a ~ilc[time$] call can generate a call of the
  evaluator for the last argument of ~c[return-last] (arguent ~c[expr2],
  above).  We use ~c[:]~ilc[trans1] to show single-step macroexpansions, which
  indicate how a call of ~ilc[time$] expands to a call of ~c[return-last].  The
  implementation actually binds the Lisp variable ~c[*RETURN-LAST-ARG3*] to
  ~c[expr2] before calling the ACL2 evaluator, ~c[ev-rec].
  ~bv[]
  ACL2 !>:trans1 (time$ (+ 3 4))
   (TIME$1 (LIST 0 NIL NIL NIL NIL)
           (+ 3 4))
  ACL2 !>:trans1 (TIME$1 (LIST 0 NIL NIL NIL NIL)
                         (+ 3 4))
   (RETURN-LAST 'TIME$1-RAW
                (LIST 0 NIL NIL NIL NIL)
                (+ 3 4))
  ACL2 !>(time$ (+ 3 4))
  ; (EV-REC *RETURN-LAST-ARG3* ...) took
  ; 0.00 seconds realtime, 0.00 seconds runtime
  ; (1,120 bytes allocated).
  7
  ACL2 !>
  ~ev[]

  We now show how things can go wrong in other than the ``intended use'' case
  described above.  In the example below, the macro ~c[mac-raw] is operating
  directly on the syntactic representation of its first argument, which it
  obtains of course as the second argument of a ~c[return-last] call.  Again
  this ``intended use'' of ~c[return-last] requires that argument to be
  evaluated and then only its result is relevant; its syntax is not supposed to
  matter.  We emphasize that only top-level evaluation depends on this
  ``intended use''; once evaluation is passed to Lisp, the issue disappears.
  We illustrate below how to use the ~ilc[top-level] utility to avoid this
  issue; ~pl[top-level].  The example uses the utility ~c[defmacro-last] to
  ``install'' special handling of the raw-Lisp macro ~c[mac-raw] by
  ~c[return-last]; later below we discuss ~c[defmacro-last].
  ~bv[]
  ACL2 !>(defttag t)

  TTAG NOTE: Adding ttag :T from the top level loop.
   T
  ACL2 !>(progn!
           (set-raw-mode t)
           (defmacro mac-raw (x y)
             `(progn (print (quote ,(cadr x)))
                     (terpri) ; newline
                     ,y)))

  Summary
  Form:  ( PROGN! (SET-RAW-MODE T) ...)
  Rules: NIL
  Time:  0.01 seconds (prove: 0.00, print: 0.00, other: 0.01)
   NIL
  ACL2 !>(defmacro-last mac)
  [[ ... output omitted ... ]]
   RETURN-LAST-TABLE
  ACL2 !>(return-last 'mac-raw '3 nil)

  ***********************************************
  ************ ABORTING from raw Lisp ***********
  Error:  Fault during read of memory address #x120000300006
  ***********************************************

  If you didn't cause an explicit interrupt (Control-C),
  then the root cause may be call of a :program mode
  function that has the wrong guard specified, or even no
  guard specified (i.e., an implicit guard of t).
  See :DOC guards.

  To enable breaks into the debugger (also see :DOC acl2-customization):
  (SET-DEBUGGER-ENABLE T)
  ACL2 !>(top-level (return-last 'mac-raw '3 nil))

  3
  NIL
  ACL2 !>
  ~ev[]

  We next describe how to extend the behavior of ~c[return-last].  This
  requires an active trust tag (~pl[defttag]), and is accomplished by extending
  a ~il[table] provided by ACL2, ~pl[return-last-table].  Rather than using
  ~ilc[table] ~il[events] directly for this purpose, it is probably more
  convenient to use a macro, ~c[defmacro-last].  We describe the community book
  ~c[books/misc/profiling.lisp] in order to illustrate how this works.  The
  events in that book include the following, which are described below.
  ~bv[]
  (defttag :profiling)

  (progn!
   (set-raw-mode t)
   (load (concatenate 'string (cbd) \"profiling-raw.lsp\")))

  (defmacro-last with-profiling)
  ~ev[]
  The first event introduces a trust tag.  The second loads a file into raw
  Lisp that defines a macro, ~c[with-profiling-raw], which can do profiling for
  the form to be evaluated.  The third introduces an ACL2 macro
  ~c[with-profiling], whose calls expand into calls of the form
  ~c[(return-last (quote with-profiling-raw) & &)].  The third event also
  extends ~ilc[return-last-table] so that these calls will expand in raw Lisp
  to calls of ~c[with-profiling-raw].

  The example above illustrates the following methodology for introducing a
  macro that returns its last argument but produces useful side-effects with
  raw Lisp code.
  ~bq[]
  (1) Introduce a trust tag (~pl[defttag]).

  (2) Using ~ilc[progn!], load into raw Lisp a file defining a macro,
  ~c[RAW-NAME], that takes two arguments, returning its last (second) argument
  but using the first argument to produce desired side effects during
  evaluation of that last argument.

  (3) Evaluate the form ~c[(defmacro-last NAME :raw RAW-NAME)].  This will
  introduce ~c[NAME] as an ACL2 macro that expands to a corresponding call of
  ~c[RAW-NAME] (see (2) above) in raw Lisp.  The specification of keyword value
  of ~c[:raw] as ~c[RAW-NAME] may be omitted if ~c[RAW-NAME] is the result of
  modifying the symbol ~c[NAME] by suffixing the string ~c[\"-RAW\"] to the
  ~ilc[symbol-name] of ~c[NAME].~eq[]

  WARNING: Not every use of ~c[return-last] can be soundly evaluated outside a
  function body.  The reason is that ACL2's evaluator, ~c[ev-rec], recurs
  through terms that are presented in the top-level loop, and handles
  ~c[return-last] calls in a special manner: basically, the call of ~c[ev-rec]
  on the form ~c[(return-last 'mac-raw x y)] leads to evaluation of a macro
  call of the form ~c[(mac-raw *return-last-arg2* (ev-rec ...))], where
  *return-last-arg2* is a global variable bound to the result of evaluating
  ~c[x] with ~c[ev-rec].  Consider the following example.
  ~bv[]
  (defttag t)
  (set-raw-mode-on state)
  (defmacro mac-raw (str y) ; print message is an atom
   `(let ((result (consp ,y))
          (str ,str))
      (or result
          (prog2$ (fmx ,str ',y)
                  nil))))
  (set-raw-mode-off state)
  (defmacro-last mac)
  ; Horrible error:
  (mac \"Not a cons: ~~x0\~~%\" 17)
  ; Works, but probably many would consider it awkward to use top-level:
  (top-level (mac \"Not a cons: ~~x0\~~%\" 17))
  ~ev[]
  In such cases we suggest supplying keyword ~c[:top-level-ok nil] to the call
  of ~c[defmacro-last], for example:
  ~bv[]
  (defmacro-last mac :top-level-ok nil)
  ~ev[]
  Then any attempt to call ~c[mac] at the top level, as opposed to inside a
  function body, will cause a clean error before evaluation begins.

  It is useful to explore what is done by ~c[defmacro-last].
  ~bv[]
  ACL2 !>:trans1 (defmacro-last with-profiling)
   (PROGN (DEFMACRO WITH-PROFILING (X Y)
                    (LIST 'RETURN-LAST
                          (LIST 'QUOTE 'WITH-PROFILING-RAW)
                          X Y))
          (TABLE RETURN-LAST-TABLE 'WITH-PROFILING-RAW
                 'WITH-PROFILING))
  ACL2 !>:trans1 (with-profiling '(assoc-eq fgetprop rewrite) (mini-proveall))
   (RETURN-LAST 'WITH-PROFILING-RAW
                '(ASSOC-EQ FGETPROP REWRITE)
                (MINI-PROVEALL))
  ACL2 !>:q

  Exiting the ACL2 read-eval-print loop.  To re-enter, execute (LP).
  ? [RAW LISP] (macroexpand-1
                '(RETURN-LAST 'WITH-PROFILING-RAW
                               '(ASSOC-EQ FGETPROP REWRITE)
                               (MINI-PROVEALL)))
  (WITH-PROFILING-RAW '(ASSOC-EQ FGETPROP REWRITE) (MINI-PROVEALL))
  T
  ? [RAW LISP]
  ~ev[]
  To understand the macro ~c[with-profiling-raw] you could look at the
  community book loaded above: ~c[books/misc/profiling-raw.lsp].

  We mentioned above that ACL2 tends to print calls of ~ilc[prog2$] or
  ~ilc[time$] (or other such utilities) instead of calls of ~c[return-last].
  Here we elaborate that point.  ACL2's `~c[untranslate]' utility treats
  ~c[(return-last (quote F) X Y)] as ~c[(G X Y)] if ~c[F] corresponds to the
  symbol ~c[G] in ~c[return-last-table].  However, it is generally rare to
  encounter such a term during a proof, since calls of ~c[return-last] are
  generally expanded away early during a proof.

  Calls of ~c[return-last] that occur in code ~-[] forms submitted in the
  top-level ACL2 loop, and definition bodies other than those marked as
  ~ilc[non-executable] (~pl[defun-nx]) ~-[] have the following restriction: if
  the first argument is of the form ~c[(quote F)], then ~c[F] must be an entry
  in ~c[return-last-table].  There are however four exceptions: the following
  symbols are considered to be keys of ~c[return-last-table] even if they are
  no longer associated with non-~c[nil] values, say because of a ~ilc[table]
  event with keyword ~c[:clear].
  ~bq[]
  * ~c[progn], associated with ~ilc[prog2$]~nl[]
  * ~c[mbe1-raw], associated with ~c[mbe1], a version of ~c[mbe]~nl[]
  * ~c[ec-call1-raw], associated with ~c[ec-call1] (a variant of
  ~ilc[ec-call])~nl[]
  * ~c[with-guard-checking1-raw], associated with ~c[with-guard-checking1] (a
  variant of ~ilc[with-guard-checking])
  ~eq[]

  Note that because of its special status, it is illegal to trace
  ~c[return-last].

  We conclude by warning that as a user, you take responsibility for not
  compromising the soundness or error handling of ACL2 when you define a macro
  in raw Lisp and especially when you install it as a key of
  ~ilc[return-last-table], either directly or (more likely) using
  ~c[defmacro-last].  In particular, be sure that you are defining a macro of
  two arguments that always returns the value of its last argument, returning
  the complete multiple value if that last argument evaluates to a multiple
  value.

  The following is correct, and illustrates care taken to return multiple
  values.
  ~bv[]
  :q
  (defmacro my-time1-raw (val form)
    (declare (ignore val))
    `(let  ((start-time (get-internal-run-time))
            (result (multiple-value-list ,form))
            (end-time (get-internal-run-time)))
       (format t \"Total time: ~~s~~%\"
               (float (/ (- end-time start-time)
                         internal-time-units-per-second)))
       (values-list result)))
  (lp)
  (defttag t)
  (defmacro-last my-time1)
  (defmacro my-time (form)
    `(my-time1 nil ,form))
  ~ev[]
  Then for example:
  ~bv[]
  ACL2 !>(my-time (equal (make-list 1000000) (make-list 1000000)))
  Total time: 0.12
  T
  ACL2 !>
  ~ev[]
  But if instead we provide the following more naive implementation, of the
  above raw Lisp macro, the above evaluation can produce an error, for example
  if the host Lisp is CCL.
  ~bv[]
  (defmacro my-time1-raw (val form)
      (declare (ignore val))
      `(let  ((start-time (get-internal-run-time))
              (result ,form)
              (end-time (get-internal-run-time)))
         (format t \"Total time: ~~s~~%\"
                 (float (/ (- end-time start-time)
                           internal-time-units-per-second)))
         result)) ; WRONG -- need multiple values returned!
  ~ev[]

  Here is a second, similar example.  This time we'll start with the error; can
  you spot it?
  ~bv[]
  (defttag t)
  (progn!
   (set-raw-mode t)
   (defmacro foo-raw (x y)
     `(prog1
          ,y
        (cw \"Message showing argument 1: ~~x0~~%\" ,x))))
  (defmacro-last foo)
  ~ev[]
  We then can wind up with a hard Lisp error:
  ~bv[]
  ACL2 !>(foo 3 (mv 4 5))
  Message showing argument 1: 3

  ***********************************************
  ************ ABORTING from raw Lisp ***********
  Error:  value NIL is not of the expected type REAL.
  ***********************************************

  If you didn't cause an explicit interrupt (Control-C),
  then the root cause may be call of a :program mode
  function that has the wrong guard specified, or even no
  guard specified (i.e., an implicit guard of t).
  See :DOC guards.

  To enable breaks into the debugger (also see :DOC acl2-customization):
  (SET-DEBUGGER-ENABLE T)
  ACL2 !>
  ~ev[]
  Here is a corrected version of the above macro.  The point here is that
  ~c[prog1] returns a single value, while ~c[our-multiple-value-prog1] returns
  all the values that are returned by its first argument.
  ~bv[]
  (progn!
   (set-raw-mode t)
   (defmacro foo-raw (x y)
     `(our-multiple-value-prog1 ;; better
       ,y
       (cw \"Message showing argument 1: ~~x0~~%\" ,x))))
  ~ev[]

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (ignore fn eager-arg)
           (xargs :guard

; Warning: If you change this guard, also consider changing the handling of
; return-last in oneify, which assumes that the guard is t except for the
; 'mbe1-raw case.

; We produce a guard to handle the mbe1 case (from expansion of mbe forms).  In
; practice, fn is likely to be a constant, in which case we expect this guard
; to resolve to its true branch or its false branch.

                  (if (equal fn 'mbe1-raw)
                      (equal last-arg eager-arg)
                    t)
                  :mode :logic))
  last-arg)

#-acl2-loop-only
(defmacro return-last (qfn arg2 arg3)
  (let* ((fn (and (consp qfn)
                  (eq (car qfn) 'quote)
                  (consp (cdr qfn))
                  (symbolp (cadr qfn))
                  (null (cddr qfn))
                  (cadr qfn)))
         (arg2

; There is no logical problem with using attachments when evaluating the second
; argument of return-last, because logically the third argument provides the
; value(s) of a return-last call -- the exception being the evaluation of the
; :exec argument of an mbe call (or, equivalent evaluation by way of mbe1,
; etc.).  We not only bind *aokp* to t, but we also bind *attached-fn-called*
; so that no changes to this variable will prevent the storing of memoization
; results.

; See also the related treatment of aokp in ev-rec-return-last.

          (cond
           ((or (eq fn 'mbe1-raw) ; good test, though subsumed by the next line
                (and fn (macro-function fn))
                (symbolp arg2)      ; no point in doing extra bindings below
                (and (consp arg2)
                     (eq (car arg2) ; no point in doing extra bindings below
                         'quote)))
            arg2)
           (t `(let ((*aokp* t)
                     #+hons (*attached-fn-called* t))
                 ,arg2)))))
    (cond ((and fn (fboundp fn))

; Translation for evaluation requires that if the first argument is a quoted
; non-nil symbol, then that symbol (here, fn) must be a key in
; return-last-table.  The function chk-return-last-entry checks that when fn
; was added to the table, it was fboundp in raw Lisp.  Note that fboundp holds
; for functions, macros, and special operators.

; An alternative may seem to be to lay down code that checks to see if fn is in
; return-last-table, and if not then replace it by progn.  But during early
; load of compiled files we skip table events (which are always skipped in raw
; Lisp), yet the user may expect a call of return-last on a quoted symbol to
; have the desired side-effects in that case.

           (list fn arg2 arg3))
          (t (list 'progn arg2 arg3)))))

#-acl2-loop-only
(defmacro mbe1-raw (exec logic)

; We rely on this macroexpansion in raw Common Lisp.  See in particular the
; code and comment regarding mbe1-raw in guard-clauses.

  (declare (ignore logic))
  exec)

(defmacro mbe1 (exec logic)

; See also must-be-equal.

; Suppose that during a proof we encounter a term such as (return-last
; 'mbe1-raw exec logic), but we don't know that logic and exec are equal.
; Fortunately, ev-rec will only evaluate the logic code for this return-last
; form, as one might expect.

  ":Doc-Section ACL2::ACL2-built-ins

  attach code for execution~/

  The form ~c[(mbe1 exec logic)] is equivalent to the forms
  ~c[(mbe :logic logic :exec exec)] and ~c[(must-be-equal logic exec)].
  ~l[mbe].~/~/"

  `(return-last 'mbe1-raw ,exec ,logic))

(defmacro must-be-equal (logic exec)

; We handle must-be-equal using return-last, so that must-be-equal isn't a
; second function that needs special stobjs-out handling.  But then we need a
; version of must-be-equal with the logic input as the last argument, since
; that is what is returned in the logic.  We call that mbe1, but we leave
; must-be-equal as we move the the return-last implementation (after v4-1,
; released Sept., 2010), since must-be-equal has been around since v2-8 (March,
; 2004).

  ":Doc-Section ACL2::ACL2-built-ins

  attach code for execution~/~/

  The form ~c[(must-be-equal logic exec)] evaluates to ~c[logic] in the ACL2
  logic but evaluates to ~c[exec] in raw Lisp.  The point is to be able to
  write one definition to reason about logically but another for evaluation.
  Please ~pl[mbe] and ~pl[mbt] for appropriate macros to use, rather than
  calling ~c[must-be-equal] directly, since it is easy to commute the arguments
  of ~c[must-be-equal] by accident.

  In essence, the guard for ~c[(must-be-equal x y)] is ~c[(equal x y)].
  However, note that ~c[must-be-equal] is a macro:
  ~c[(must-be-equal logic exec)] expands to ~c[(mbe1 exec logic)], which
  expands to a call of ~ilc[return-last]."

  `(mbe1 ,exec ,logic))

(defmacro mbe (&key (exec 'nil exec-p) (logic 'nil logic-p))

  ":Doc-Section ACL2::ACL2-built-ins

  attach code for execution~/

  The macro ~c[mbe] (``must be equal'') can be used in function definitions in
  order to cause evaluation to use alternate code to that provided for the
  logic.  An example is given below.  However, the use of ~c[mbe] can lead to
  non-terminating computations.  ~l[defexec], perhaps after reading the present
  documentation, for a way to prove termination.

  In the ACL2 logic, ~c[(mbe :exec exec-code :logic logic-code)] equals
  ~c[logic-code]; the value of ~c[exec-code] is ignored.  However, in raw Lisp
  it is the other way around: this form macroexpands simply to ~c[exec-code].
  ACL2's ~il[guard] verification mechanism ensures that the raw Lisp code is
  only evaluated when appropriate, since the guard proof obligations generated
  for (the macroexpansion of) this call of ~c[mbe] include not only the guard
  proof obligations from ~c[exec-code], but also, under suitable contextual
  assumptions, the term ~c[(equal exec-code logic-code)].  ~l[verify-guards]
  (in particular, for discussion of the contextual assumptions from the
  ~c[:guard] and ~ilc[IF]-tests) and, for general discussion of guards,
  ~pl[guard].

  Normally, during evaluation of an ~c[mbe] call, only the ~c[:logic] code is
  evaluated unless the call is in the body of a ~il[guard]-verified function,
  in which case only the ~c[:exec] code is evaluated.  This implies that
  equality of ~c[:exec] and ~c[:logic] code is never checked at runtime.
  (Rather, such equality is proved when verifying guards.)  We started with
  ``normally'' above because there is an exception: during a ``safe mode'',
  which is used in macroexpansion and evaluation of ~ilc[defconst] forms, the
  ~c[:logic] and ~c[:exec] code are both evaluated and their equality is
  checked.

  Note that the ~c[:exec] and the ~c[:logic] code in an ~c[mbe] call must have
  the same return type.  For example, one cannot return ~c[(]~ilc[mv]~c[ * *)]
  while the other returns just a single value.

  Also ~pl[mbt], which stands for ``must be true.''  You may find it more
  natural to use ~ilc[mbt] for certain applications, as described in its
  ~il[documentation].~/

  Here is an example of the use of ~c[mbe].  Suppose that you want to define
  factorial in the usual recursive manner, as follows.
  ~bv[]
  (defun fact (n)
    (if (zp n)
        1
      (* n (fact (1- n)))))
  ~ev[]
  But perhaps you want to be able to execute calls of ~c[fact] on large
  arguments that cause stack overflows, perhaps during proofs.  (This isn't a
  particularly realistic example, but it should serve.)  So, instead you can
  define this tail-recursive version of factorial:
  ~bv[]
  (defun fact1 (n acc)
    (declare (xargs :guard (and (integerp n) (>= n 0) (integerp acc))))
    (if (zp n)
        acc
      (fact1 (1- n) (* n acc))))
  ~ev[]
  We are now ready to define ~c[fact] using ~c[mbe].  Our intention is that
  logically, ~c[fact] is as shown in the first definition above, but that
  ~c[fact] should be executed by calling ~c[fact1].  Notice that we defer
  ~il[guard] verification, since we are not ready to prove the correspondence
  between ~c[fact1] and ~c[fact].
  ~bv[]
  (defun fact (n)
    (declare (xargs :guard (and (integerp n) (>= n 0))
                    :verify-guards nil))
    (mbe :exec  (fact1 n 1)
         :logic (if (zp n)
                    1
                  (* n (fact (1- n))))))
  ~ev[]
  Next, we prove the necessary correspondence lemmas.  Notice the inclusion of
  a community book to help with the arithmetic reasoning.
  ~bv[]
  (include-book \"books/arithmetic/top-with-meta\")

  (defthm fact1-fact
    (implies (integerp acc)
             (equal (fact1 n acc)
                    (* acc (fact n)))))
  ~ev[]
  We may now do guard verification for ~c[fact], which will allow the execution
  of the raw Lisp ~c[fact] function, where the above ~c[mbe] call expands
  simply to ~c[(fact1 n 1)].
  ~bv[]
  (verify-guards fact)
  ~ev[]
  Now that guards have been verified, a trace of function calls illustrates
  that the evaluation of calls of ~c[fact] is passed to evaluation of calls of
  ~c[fact1].  The outermost call below is of the logical function stored for
  the definition of ~c[fact]; all the others are of actual raw Common Lisp
  functions.
  ~bv[]
  ACL2 !>(trace$ fact fact1)
  NIL
  ACL2 !>(fact 3)
  1> (ACL2_*1*_ACL2::FACT 3)
    2> (FACT 3)
      3> (FACT1 3 1)
        4> (FACT1 2 3)
          5> (FACT1 1 6)
            6> (FACT1 0 6)
            <6 (FACT1 6)
          <5 (FACT1 6)
        <4 (FACT1 6)
      <3 (FACT1 6)
    <2 (FACT 6)
  <1 (ACL2_*1*_ACL2::FACT 6)
  6
  ACL2 !>
  ~ev[]

  You may occasionally get warnings when you compile functions defined using
  ~c[mbe].  (For commands that invoke the compiler, ~pl[compilation].)  These
  can be inhibited by using an ~c[ignorable] ~ilc[declare] form.  Here is a
  simple but illustrative example.  Note that the declarations can optionally
  be separated into two ~ilc[declare] forms.
  ~bv[]
  (defun foo (x y)
    (declare (ignorable x)
             (xargs :guard (equal x y)))
    (mbe :logic x :exec y))
  ~ev[]

  Finally, we observe that when the body of a function contains a term of the
  form ~c[(mbe :exec exec-code :logic logic-code)], the user is very unlikely
  to see any logical difference than if this were replaced by ~c[logic-code].
  ACL2 takes various steps to ensure this.  For example, the proof obligations
  generated for admitting a function treat the above ~c[mbe] term simply as
  ~c[logic-code].  Function expansion, ~c[:use] ~il[hints],
  ~c[:]~ilc[definition] rules, generation of ~il[constraint]s for functional
  instantiation, and creation of rules of class ~c[:]~ilc[rewrite] and
  ~c[:]~ilc[forward-chaining] also treat ~c[mbe] calls as their ~c[:logic]
  code."

  (declare (xargs :guard (and exec-p logic-p))
           (ignorable exec-p logic-p))
  `(mbe1 ,exec ,logic))

(defmacro mbt (x)

  ":Doc-Section ACL2::ACL2-built-ins

  introduce a test not to be evaluated~/

  The macro ~c[mbt] (``must be true'') can be used in order to add code in
  order to admit function definitions in ~c[:]~ilc[logic] mode, without paying
  a cost in execution efficiency.  Examples below illustrate its intended use.

  Semantically, ~c[(mbt x)] equals ~c[x].  However, in raw Lisp ~c[(mbt x)]
  ignores ~c[x] entirely, and macroexpands to ~c[t].  ACL2's ~il[guard]
  verification mechanism ensures that the raw Lisp code is only evaluated when
  appropriate, since a guard proof obligation ~c[(equal x t)] is generated.
  ~l[verify-guards] and, for general discussion of guards, ~pl[guard].

  Also ~pl[mbe], which stands for ``must be equal.''  Although ~c[mbt] is more
  natural in many cases, ~c[mbe] has more general applicability.  In fact,
  ~c[(mbt x)] is essentially defined to be ~c[(mbe :logic x :exec t)].~/

  We can illustrate the use of ~c[mbt] on the following generic example, where
  ~c[<g>], ~c[<test>], ~c[<rec-x>], and ~c[<base>] are intended to be terms
  involving only the variable ~c[x].
  ~bv[]
  (defun foo (x)
    (declare (xargs :guard <g>))
    (if <test>
        (foo <rec-x>)
      <base>))
  ~ev[]
  In order to admit this function, ACL2 needs to discharge the proof obligation
  that ~c[<rec-x>] is smaller than ~c[x], namely:
  ~bv[]
  (implies <test>
           (o< (acl2-count ~c[<rec-x>])
                (acl2-count x)))
  ~ev[]
  But suppose we need to know that ~c[<g>] is true in order to prove this.
  Since ~c[<g>] is only the ~il[guard], it is not part of the logical
  definition of ~c[foo].  A solution is to add the guard to the definition of
  ~c[foo], as follows.
  ~bv[]
  (defun foo (x)
    (declare (xargs :guard <g>))
    (if (mbt <g>)
        (if <test>
            (foo <rec-x>)
          <base>)
      nil))
  ~ev[]
  If we do this using ~c[<g>] rather than ~c[(mbt <g>)], then evaluation of
  every recursive call of ~c[foo] will cause the evaluation of (the appropriate
  instance of) ~c[<g>].  But since ~c[(mbt <g>)] expands to ~c[t] in raw Lisp,
  then once we verify the guards of ~c[foo], the evaluations of ~c[<g>] will be
  avoided (except at the top level, when we check the guard before allowing
  evaluation to take place in Common Lisp).

  Other times, the guard isn't the issue, but rather, the problem is that a
  recursive call has an argument that itself is a recursive call.  For example,
  suppose that ~c[<rec-x>] is of the form ~c[(foo <expr>)].  There is no way we
  can hope to discharge the termination proof obligation shown above.  A
  standard solution is to add some version of this test:
  ~bv[]
  (mbt (o< (acl2-count ~c[<rec-x>]) (acl2-count x)))
  ~ev[]
  Here is a specific example based on one sent by Vernon Austel.
  ~bv[]
  (defun recurX2 (n)
    (declare (xargs :guard (and (integerp n) (<= 0 n))
                    :verify-guards nil))
    (cond ((zp n) 0)
          (t (let ((call (recurX2 (1- n))))
               (if (mbt (< (acl2-count call) n))
                   (recurX2 call)
                 1 ;; this branch is never actually taken
                 )))))

  (defthm recurX2-0
   (equal (recurX2 n) 0))

  (verify-guards recurX2)
  ~ev[]
  If you ~c[(]~ilc[trace$]~c[ acl2-count)], you will see that evaluation of
  ~c[(recurX2 2)] causes several calls of ~ilc[acl2-count] before the
  ~ilc[verify-guards].  But this evaluation does not call ~c[acl2-count] after
  the ~c[verify-guards], because the ACL2 evaluation mechanism uses raw Lisp to
  do the evaluation, and the form ~c[(mbt (< (acl2-count call) n))]
  macroexpands to ~c[t] in Common Lisp.

  You may occasionally get warnings when you compile functions defined using
  ~c[mbt].  (For commands that invoke the compiler, ~pl[compilation].)  These
  can be inhibited by using an ~c[ignorable] ~ilc[declare] form.  Here is a
  simple but illustrative example.  Note that the declarations can optionally
  be separated into two ~ilc[declare] forms.
  ~bv[]
  (defun foo (x y)
    (declare (ignorable x)
             (xargs :guard (equal x t)))
    (and (mbt x) y))
  ~ev[]"

  `(mbe1 t ,x))

(defdoc equality-variants

; Consider position, remove-duplicates, and remove.  In Common Lisp, all three
; of these primitives can take strings.  Through Version_4.2, position and
; remove-duplicates supported string arguments, while remove did not.  Note
; however that remove-duplicates-eql and remove-duplicates-equal did not
; support string arguments.  For backward compatibility with Version_4.2 and
; earlier, we leave remove-duplicates-equal unchanged.  When there is
; sufficient demand we can extend remove.

  ":Doc-Section ACL2::Programming

  versions of a function using different equality tests~/

  The ACL2 environment includes not only a logic but also a programming
  language, which is based on Common Lisp.  Execution efficiency may be
  increased by using fast equality tests: ~ilc[eq] for symbols and ~ilc[eql]
  for numbers, symbols, and characters (~pl[eqlablep]).  Several
  list-processing functions built into ACL2 thus have three variants, depending
  on whether the equality function used is ~ilc[eq], ~ilc[eql], or ~ilc[equal];
  a list is provided below.  ACL2 has taken measures to ensure that one can
  reason about a single logical function even when one uses these different
  variants.

  Consider for example the case of list membership.  Common Lisp provides a
  utility for this purposes, ~ilc[member], which can take a ~c[:TEST] keyword
  argument, default ~ilc[eql].  So for example, one might write
  ~bv[]
  (member a x :TEST 'eq)
  ~ev[]
  if either ~c[a] is a symbol or ~c[x] is a list of symbols, so that the
  fastest equality test (~ilc[eq]) may be used when comparing ~c[a] to
  successive elements of the list, ~c[x].  One might elsewhere write
  ~c[(member b (foo y))], which is equivalent to
  ~c[(member b (foo y) :TEST 'eql)], for example if ~c[b] is a number.  If one
  wants to reason about both ~c[(member a x :TEST 'eq)] and ~c[(member b y)],
  it might be helpful for both calls of ~c[member] to be the same logically,
  even though Common Lisp will execute them differently (using ~ilc[eq] or
  ~ilc[eql], respectively).  ACL2 arranges that in fact, both references to
  ~ilc[member] generate calls of ~ilc[member-equal] in the theorem prover.

  In fact, since ~ilc[member] can take the optional ~c[:TEST] keyword argument,
  then in ACl2 it must be defined as a macro, not a function (~pl[defun]).
  ACL2 arranges that a call of ~c[member] generates a corresponding call of the
  function ~ilc[member-equal], regardless of the value of ~c[TEST], in a manner
  that produces ~ilc[member-equal] in prover output.  More generally, you can
  expect ACL2 to treat your use of ~ilc[member] as though you had written
  ~ilc[member-equal], for example in the way it stores ~ilc[rewrite] rules and
  other kinds of rules as well (~pl[rule-classes]).  We say little here about
  how this is all arranged by ACL2, other than to mention that ~ilc[mbe] is
  utilized (so, you might see mention in proof logs) of the function
  ~ilc[return-last] that implements ~ilc[mbe].  Such details, which probably
  can be ignored by most users, may be found elsewhere;
  ~pl[equality-variants-details].

  As a convenience to the user, the macro ~c[member-eq] is provided that
  expands to a corresponding call of ~c[member] with ~c[:TEST 'eq], as
  follows.
  ~bv[]
  ACL2 !>:trans1 (member-eq (foo x) (bar y))
   (MEMBER (FOO X) (BAR Y) :TEST 'EQ)
  ACL2 !>
  ~ev[]

  For efficiency we recommend using the ~c[-equal] equality variant, for
  example ~ilc[member-equal] or ~ilc[member ... :TEST 'equal], in certain
  contexts: ~ilc[defmacro], ~ilc[defpkg], ~ilc[defconst], and
  ~ilc[value-triple] forms.  However, the implementation of equality variants
  has been designed so that when defining a function, one may choose freely in
  a definition an equality variant of primitive ~c[F], to get efficient
  execution but where subsequent reasoning is about ~c[F-equal].  For details
  about the above recommendation and for a discussion of the implementation,
  ~pl[equality-variants-details].

  The following alphabetical list includes all primitives that have equality
  variants.  Each macro ~c[F] listed below takes an optional ~c[:TEST] keyword
  argument of ~c['eq], ~c['eql], or ~c['equal], where ~c['eql] is the default.
  For each such ~c[F], a function ~c[F-equal] is defined such that for logical
  purposes (in particular theorem proving), each call of ~c[F] expands to a
  corresponding call of ~c[F-equal].  For convenience, a macro ~c[F-eq] is also
  defined, so that a call of ~c[F-eq] expands to a corresponding call of ~c[F]
  with ~c[:TEST 'eq].

  ~bf[]
  ~ilc[add-to-set]
  ~ilc[assoc]
  ~ilc[delete-assoc]
  ~ilc[intersection$] ; (see Note below)
  ~ilc[intersectp]
  ~ilc[member]
  ~ilc[no-duplicatesp]
  ~c[position-ac]
  ~ilc[position]
  ~ilc[put-assoc]
  ~ilc[rassoc]
  ~ilc[remove-duplicates]
  ~ilc[remove1]
  ~ilc[remove]
  ~ilc[set-difference$] ; (see Note below)
  ~ilc[subsetp]
  ~ilc[union$] ; (see Note below)
  ~ef[]

  Note: Three of the macros above have names ending with the character,
  `~c[$]': ~ilc[intersection$], ~ilc[set-difference$], and ~ilc[union$].  In
  each case there is a corresponding Common Lisp primitive without the trailing
  `~c[$]': ~c[intersection], ~c[set-difference], and ~c[union].  However,
  Common Lisp does not specify the order of elements in the list returned by
  those primitives, so ACL2 has its own.  Nevertheless, the only use of the
  trailing `~c[$]' is to distinguish the primitives; associated functions and
  macros, for example ~c[union-eq] and ~c[intersection-equal], do not include
  the `~c[$]' character in their names.~/~/")

(defdoc equality-variants-details
  ":Doc-Section equality-variants

  details about ~il[equality-variants]~/

  Here we present details about equality variants, none of which is likely
  to be important to the majority of ACL2 users.  Please ~pl[equality-variants]
  for relevant background.

  We begin by presenting ~il[events] that implement the equality variants for
  ~ilc[member], as these illustrate the events introduced for all macros having
  equality variants.  The definition of ~ilc[member], just below, calls the
  macro ~c[let-mbe], which in turn is just an abbreviation for a combination of
  ~ilc[let] and ~ilc[mbe].
  ~bv[]
  (defmacro let-mbe (bindings &key logic exec)
    `(let ,bindings
       (mbe :logic ,logic
            :exec ,exec)))
  ~ev[]
  This use of ~ilc[let] arranges that each argument of a call of ~c[member] is
  evaluated only once.
  ~bv[]
  (defmacro member (x l &key (test ''eql))
    (declare (xargs :guard (or (equal test ''eq)
                               (equal test ''eql)
                               (equal test ''equal))))
    (cond
     ((equal test ''eq)
      `(let-mbe ((x ,x) (l ,l))
                :logic (member-equal x l)
                :exec  (member-eq-exec x l)))
     ((equal test ''eql)
      `(let-mbe ((x ,x) (l ,l))
                :logic (member-equal x l)
                :exec  (member-eql-exec x l)))
     (t ; (equal test 'equal)
      `(member-equal ,x ,l))))
  ~ev[]
  Inspection of the definition above shows that every call of ~ilc[member]
  expands to one that is logically equivalent to the corresponding call of
  ~ilc[member-equal], which is defined as follows.
  ~bv[]
  (defun member-equal (x lst)
    (declare (xargs :guard (true-listp lst)))
    (cond ((endp lst) nil)
          ((equal x (car lst)) lst)
          (t (member-equal x (cdr lst)))))
  ~ev[]
  The following two definitions model equality variants of ~ilc[member] for
  tests ~ilc[eq] and ~ilc[eql], respectively.
  ~bv[]
  (defun member-eq-exec (x lst)
    (declare (xargs :guard (if (symbolp x)
                               (true-listp lst)
                             (symbol-listp lst))))
    (cond ((endp lst) nil)
          ((eq x (car lst)) lst)
          (t (member-eq-exec x (cdr lst)))))

  (defun member-eql-exec (x lst)
    (declare (xargs :guard (if (eqlablep x)
                               (true-listp lst)
                             (eqlable-listp lst))))
    (cond ((endp lst) nil)
          ((eql x (car lst)) lst)
          (t (member-eql-exec x (cdr lst)))))
  ~ev[]
  At this point the user can write ~c[(member x y)] or ~c[(member-equal x y)]
  to call equality variants of ~c[member] with test ~c[eql] or ~c[equal],
  respectively.  We thus provide the following macro for the ~c[eq] variant.
  ~bv[]
  (defmacro member-eq (x lst)
    `(member ,x ,lst :test 'eq))
  ~ev[]
  ~il[Guard] proof obligations generated by calls of ~c[member] will include
  those based on its use of ~c[mbe], and are supported by the following two
  lemmas.
  ~bv[]
  (defthm member-eq-exec-is-member-equal
    (equal (member-eq-exec x l)
           (member-equal x l)))

  (defthm member-eql-exec-is-member-equal
    (equal (member-eql-exec x l)
           (member-equal x l)))
  ~ev[]
  Finally, the following two events arrange that in certain contexts such as
  ~il[theories] (including the use of ~ilc[in-theory] in ~il[events] and
  ~il[hints]), ~ilc[member-eq] and ~ilc[member] are treated as references to
  ~ilc[member-equal].
  ~bv[]
  (add-macro-alias member-eq member-equal)
  (add-macro-alias member member-equal)
  ~ev[]

  We conclude this topic by exploring the following recommendation made in the
  ~il[documentation] for ~il[equality-variants].

  ~bq[]
  For efficiency we recommend using the ~c[-equal] equality variant, for
  example ~ilc[member-equal] or ~ilc[member ... :TEST 'equal], in certain
  contexts: ~ilc[defmacro], ~ilc[defpkg], ~ilc[defconst], and
  ~ilc[value-triple] forms.~eq[]

  ACL2 reliies on the underlying Common Lisp for evaluation.  It also processes
  events in the ACL2 logic.  In order to guarantee consistency of its logical
  and Common Lisp evaluations, ACL2 uses a ``safe mode'' to avoid ill-guarded
  calls.  In particular, consider the use of ~ilc[mbe] in execution of a call
  of an equality variant of a primitive, ~c[F], other than its ~c[F-equal]
  variant.  The ~ilc[mbe] call discussed above requires a connection to be
  established between the ~c[:logic] and ~c[:exec] forms.  For example, if
  ~c[F] is called with ~c[:TEST 'eql] (either explicitly or as the default),
  then ACL2 will call both ~c[F-eql-exec] and ~c[F-equal], and check that the
  two results are equal.

  The following partial log illustrates the point above.  We define a macro
  that calls ~ilc[member], and when a call of this macro is expanded during
  processing of a subsequent definition, we see that two membership functions
  are called on the same arguments.

  ~bv[]
  ACL2 !>(defmacro mac (lst)
           (list 'quote (and (true-listp lst)
                             (member 'c lst :test 'eq))))

  Summary
  Form:  ( DEFMACRO MAC ...)
  Rules: NIL
  Time:  0.01 seconds (prove: 0.00, print: 0.00, other: 0.01)
   MAC
  ACL2 !>(trace$ member-equal member-eq-exec)
   ((MEMBER-EQUAL) (MEMBER-EQ-EXEC))
  ACL2 !>(defun f () (mac (a b c d)))
  1> (ACL2_*1*_ACL2::MEMBER-EQ-EXEC C (A B C D))
    2> (MEMBER-EQ-EXEC C (A B C D))
    <2 (MEMBER-EQ-EXEC (C D))
  <1 (ACL2_*1*_ACL2::MEMBER-EQ-EXEC (C D))
  1> (ACL2_*1*_ACL2::MEMBER-EQUAL C (A B C D))
    2> (MEMBER-EQUAL C (A B C D))
    <2 (MEMBER-EQUAL (C D))
  <1 (ACL2_*1*_ACL2::MEMBER-EQUAL (C D))

  Since F is non-recursive, its admission is trivial.
  ~ev[]

  If performance is an issue then we can avoid such a problem, for example as
  follows.  In a fresh session, let us define a suitable wrapper for calling
  ~ilc[member] with ~c[:TEST 'eq].  This time, the trace in our partial log
  shows that we have avoided calling two membership functions.

  ~bv[]
  ACL2 !>(defun mem-eq (x lst)
           (declare (xargs :guard (if (symbolp x)
                                      (true-listp lst)
                                    (symbol-listp lst))))
           (member x lst :test 'eq))
  [[ ... output omitted here ... ]]
   MEM-EQ
  ACL2 !>(defmacro mac (lst)
           (list 'quote (and (true-listp lst)
                             (mem-eq 'c lst))))

  Summary
  Form:  ( DEFMACRO MAC ...)
  Rules: NIL
  Time:  0.00 seconds (prove: 0.00, print: 0.00, other: 0.00)
   MAC
  ACL2 !>(trace$ member-equal member-eq-exec mem-eq)
   ((MEMBER-EQUAL)
    (MEMBER-EQ-EXEC)
    (MEM-EQ))
  ACL2 !>(defun f () (mac (a b c d)))
  1> (ACL2_*1*_ACL2::MEM-EQ C (A B C D))
    2> (MEM-EQ C (A B C D))
    <2 (MEM-EQ (C D))
  <1 (ACL2_*1*_ACL2::MEM-EQ (C D))

  Since F is non-recursive, its admission is trivial.
  ~ev[]~/~/")

; Member

(defun member-eq-exec (x lst)
  (declare (xargs :guard (if (symbolp x)
                             (true-listp lst)
                           (symbol-listp lst))))
  (cond ((endp lst) nil)
        ((eq x (car lst)) lst)
        (t (member-eq-exec x (cdr lst)))))

(defun member-eql-exec (x lst)
  (declare (xargs :guard (if (eqlablep x)
                             (true-listp lst)
                           (eqlable-listp lst))))
  (cond ((endp lst) nil)
        ((eql x (car lst)) lst)
        (t (member-eql-exec x (cdr lst)))))

(defun member-equal (x lst)
  (declare (xargs :guard (true-listp lst)))
  #-acl2-loop-only ; for assoc-equal, Jared Davis found native assoc efficient
  (member x lst :test #'equal)
  #+acl2-loop-only
  (cond ((endp lst) nil)
        ((equal x (car lst)) lst)
        (t (member-equal x (cdr lst)))))

(defmacro member-eq (x lst)
  `(member ,x ,lst :test 'eq))

(defthm member-eq-exec-is-member-equal
  (equal (member-eq-exec x l)
         (member-equal x l)))

(defthm member-eql-exec-is-member-equal
  (equal (member-eql-exec x l)
         (member-equal x l)))

#+acl2-loop-only
(defmacro member (x l &key (test ''eql))

  ":Doc-Section ACL2::ACL2-built-ins

  membership predicate~/
  ~bv[]
  General Forms:
  (member x lst)
  (member x lst :test 'eql)   ; same as above (eql as equality test)
  (member x lst :test 'eq)    ; same, but eq is equality test
  (member x lst :test 'equal) ; same, but equal is equality test
  ~ev[]

  ~c[(Member x lst)] equals the longest tail of the list ~c[lst] that begins
  with ~c[x], or else ~c[nil] if no such tail exists.  The optional keyword,
  ~c[:TEST], has no effect logically, but provides the test (default ~ilc[eql])
  used for comparing ~c[x] with successive elements of ~c[lst].~/

  The ~il[guard] for a call of ~c[member] depends on the test.  In all cases,
  the second argument must satisfy ~ilc[true-listp].  If the test is ~ilc[eql],
  then either the first argument must be suitable for ~ilc[eql] (~pl[eqlablep])
  or the second argument must satisfy ~ilc[eqlable-listp].  If the test is
  ~ilc[eq], then either the first argument must be a symbol or the second
  argument must satisfy ~ilc[symbol-listp].

  ~l[equality-variants] for a discussion of the relation between ~c[member] and
  its variants:
  ~bq[]
  ~c[(member-eq x lst)] is equivalent to ~c[(member x lst :test 'eq)];

  ~c[(member-equal x lst)] is equivalent to ~c[(member x lst :test 'equal)].
  ~eq[]
  In particular, reasoning about any of these primitives reduces to reasoning
  about the function ~c[member-equal].

  ~c[Member] is defined by Common Lisp.  See any Common Lisp documentation for
  more information.~/"

  (declare (xargs :guard (or (equal test ''eq)
                             (equal test ''eql)
                             (equal test ''equal))))
  (cond
   ((equal test ''eq)
    `(let-mbe ((x ,x) (l ,l))
              :logic (member-equal x l)
              :exec  (member-eq-exec x l)))
   ((equal test ''eql)
    `(let-mbe ((x ,x) (l ,l))
              :logic (member-equal x l)
              :exec  (member-eql-exec x l)))
   (t ; (equal test 'equal)
    `(member-equal ,x ,l))))

; Subsetp

(defun subsetp-eq-exec (x y)
  (declare (xargs :guard (if (symbol-listp y)
                             (true-listp x)
                           (if (symbol-listp x)
                               (true-listp y)
                             nil))))
  (cond ((endp x) t)
        ((member-eq (car x) y)
         (subsetp-eq-exec (cdr x) y))
        (t nil)))

(defun subsetp-eql-exec (x y)
  (declare (xargs :guard
                  (if (eqlable-listp y)
                      (true-listp x)
                    (if (eqlable-listp x)
                        (true-listp y)
                      nil))))
  (cond ((endp x) t)
        ((member (car x) y)
         (subsetp-eql-exec (cdr x) y))
        (t nil)))

(defun subsetp-equal (x y)
  (declare (xargs :guard (and (true-listp y)
                              (true-listp x))))
  #-acl2-loop-only ; for assoc-eq, Jared Davis found native assoc efficient
  (subsetp x y :test #'equal)
  #+acl2-loop-only
  (cond ((endp x) t)
        ((member-equal (car x) y)
         (subsetp-equal (cdr x) y))
        (t nil)))

(defmacro subsetp-eq (x y)
  `(subsetp ,x ,y :test 'eq))

(defthm subsetp-eq-exec-is-subsetp-equal
  (equal (subsetp-eq-exec x y)
         (subsetp-equal x y)))

(defthm subsetp-eql-exec-is-subsetp-equal
  (equal (subsetp-eql-exec x y)
         (subsetp-equal x y)))

#+acl2-loop-only
(defmacro subsetp (x y &key (test ''eql))

  ":Doc-Section ACL2::ACL2-built-ins

  test if every ~ilc[member] of one list is a ~ilc[member] of the other~/
  ~bv[]
  General Forms:
  (subsetp x y)
  (subsetp x y :test 'eql)   ; same as above (eql as equality test)
  (subsetp x y :test 'eq)    ; same, but eq is equality test
  (subsetp x y :test 'equal) ; same, but equal is equality test
  ~ev[]

  ~c[(Subsetp x y)] is true if and only if every ~ilc[member] of the list ~c[x]
  is a ~c[member] of the list ~c[y].  The optional keyword, ~c[:TEST],
  has no effect logically, but provides the test (default ~ilc[eql]) used for
  comparing members of the two lists.~/

  The ~il[guard] for a call of ~c[subsetp] depends on the test.  In all cases,
  both arguments must satisfy ~ilc[true-listp].  If the test is ~ilc[eql], then
  one of the arguments must satisfy ~ilc[eqlable-listp].  If the test is
  ~ilc[eq], then one of the arguments must satisfy ~ilc[symbol-listp].

  ~l[equality-variants] for a discussion of the relation between ~c[subsetp] and
  its variants:
  ~bq[]
  ~c[(subsetp-eq x lst)] is equivalent to ~c[(subsetp x lst :test 'eq)];

  ~c[(subsetp-equal x lst)] is equivalent to ~c[(subsetp x lst :test 'equal)].
  ~eq[]
  In particular, reasoning about any of these primitives reduces to reasoning
  about the function ~c[subsetp-equal].

  ~c[Subsetp] is defined by Common Lisp.  See any Common Lisp documentation for
  more information.~/"

  (declare (xargs :guard (or (equal test ''eq)
                             (equal test ''eql)
                             (equal test ''equal))))
  (cond
   ((equal test ''eq)
    `(let-mbe ((x ,x) (y ,y))
              :logic (subsetp-equal x y)
              :exec  (subsetp-eq-exec x y)))
   ((equal test ''eql)
    `(let-mbe ((x ,x) (y ,y))
              :logic (subsetp-equal x y)
              :exec  (subsetp-eql-exec x y)))
   (t ; (equal test 'equal)
    `(subsetp-equal ,x ,y))))

(defun symbol-alistp (x)

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for association lists with symbols as keys~/

  ~c[(Symbol-alistp x)] is true if and only if ~c[x] is a list of pairs of the
  form ~c[(cons key val)] where ~c[key] is a ~ilc[symbolp].

  To see the ACL2 definition of this function, ~pl[pf].~/~/"

  (declare (xargs :guard t))
  (cond ((atom x) (eq x nil))
        (t (and (consp (car x))
                (symbolp (car (car x)))
                (symbol-alistp (cdr x))))))

(defthm symbol-alistp-forward-to-eqlable-alistp
  (implies (symbol-alistp x)
           (eqlable-alistp x))
  :rule-classes :forward-chaining)

; Assoc

(defun assoc-eq-exec (x alist)
  (declare (xargs :guard (if (symbolp x)
                             (alistp alist)
                           (symbol-alistp alist))))
  (cond ((endp alist) nil)
        ((eq x (car (car alist))) (car alist))
        (t (assoc-eq-exec x (cdr alist)))))

(defun assoc-eql-exec (x alist)
  (declare (xargs :guard (if (eqlablep x)
                             (alistp alist)
                           (eqlable-alistp alist))))
  (cond ((endp alist) nil)
        ((eql x (car (car alist))) (car alist))
        (t (assoc-eql-exec x (cdr alist)))))

(defun assoc-equal (x alist)
  (declare (xargs :guard (alistp alist)))
  #-acl2-loop-only ; Jared Davis found efficiencies in using native assoc
  (assoc x alist :test #'equal)
  #+acl2-loop-only
  (cond ((endp alist) nil)
        ((equal x (car (car alist))) (car alist))
        (t (assoc-equal x (cdr alist)))))

(defmacro assoc-eq (x lst)
  `(assoc ,x ,lst :test 'eq))

(defthm assoc-eq-exec-is-assoc-equal
  (equal (assoc-eq-exec x l)
         (assoc-equal x l)))

(defthm assoc-eql-exec-is-assoc-equal
  (equal (assoc-eql-exec x l)
         (assoc-equal x l)))

#+acl2-loop-only
(defmacro assoc (x alist &key (test ''eql))

  ":Doc-Section ACL2::ACL2-built-ins

  look up key in association list~/
  ~bv[]
  General Forms:
  (assoc x alist)
  (assoc x alist :test 'eql)   ; same as above (eql as equality test)
  (assoc x alist :test 'eq)    ; same, but eq is equality test
  (assoc x alist :test 'equal) ; same, but equal is equality test
  ~ev[]

  ~c[(Assoc x alist)] is the first member of ~c[alist] whose ~ilc[car] is
  ~c[x], or ~c[nil] if no such member exists.  The optional keyword, ~c[:TEST],
  has no effect logically, but provides the test (default ~ilc[eql]) used for
  comparing ~c[x] with the ~ilc[car]s of successive elements of ~c[alist].~/

  The ~il[guard] for a call of ~c[assoc] depends on the test.  In all cases,
  the second argument must satisfy ~ilc[alistp].  If the test is ~ilc[eql],
  then either the first argument must be suitable for ~ilc[eql] (~pl[eqlablep])
  or the second argument must satisfy ~ilc[eqlable-alistp].  If the test is
  ~ilc[eq], then either the first argument must be a symbol or the second
  argument must satisfy ~ilc[symbol-alistp].

  ~l[equality-variants] for a discussion of the relation between ~c[assoc] and
  its variants:
  ~bq[]
  ~c[(assoc-eq x alist)] is equivalent to ~c[(assoc x alist :test 'eq)];

  ~c[(assoc-equal x alist)] is equivalent to ~c[(assoc x alist :test 'equal)].
  ~eq[]
  In particular, reasoning about any of these primitives reduces to reasoning
  about the function ~c[assoc-equal].

  ~c[Assoc] is defined by Common Lisp.  See any Common Lisp documentation for
  more information.~/"

  (declare (xargs :guard (or (equal test ''eq)
                             (equal test ''eql)
                             (equal test ''equal))))
  (cond
   ((equal test ''eq)
    `(let-mbe ((x ,x) (alist ,alist))
              :logic (assoc-equal x alist)
              :exec  (assoc-eq-exec x alist)))
   ((equal test ''eql)
    `(let-mbe ((x ,x) (alist ,alist))
              :logic (assoc-equal x alist)
              :exec  (assoc-eql-exec x alist)))
   (t ; (equal test 'equal)
    `(assoc-equal ,x ,alist))))

(defun assoc-eq-equal-alistp (x)
  (declare (xargs :guard t))
  (cond ((atom x) (eq x nil))
        (t (and (consp (car x))
                (symbolp (car (car x)))
                (consp (cdr (car x)))
                (assoc-eq-equal-alistp (cdr x))))))

(defun assoc-eq-equal (x y alist)

; We look for a pair on alist of the form (x y . val) where we compare the
; first key using eq and the second using equal.  We return the pair or nil.
; The guard could be weakened so that if x is a symbol, then alist need only be
; a true-listp whose elements are of the form (x y . val).  But there seems to
; be little advantage in having such a guard, considering the case splits that
; it could induce.

  (declare (xargs :guard (assoc-eq-equal-alistp alist)))
  (cond ((endp alist) nil)
        ((and (eq (car (car alist)) x)
              (equal (car (cdr (car alist))) y))
         (car alist))
        (t (assoc-eq-equal x y (cdr alist)))))


;                             DATA TYPES

#+acl2-loop-only
(defmacro <= (x y)

  ":Doc-Section ACL2::ACL2-built-ins

  less-than-or-equal test~/

  ~c[<=] is a macro, and ~c[(<= x y)] expands to the same thing as
  ~c[(not (< y x))].  ~l[<].~/

  ~c[<=] is a Common Lisp function.  See any Common Lisp documentation
  for more information.~/"

  (List 'not (list '< y x)))

#+acl2-loop-only
(defun = (x y)

  ":Doc-Section ACL2::ACL2-built-ins

  test equality of two numbers~/

  ~c[(= x y)] is logically equivalent to ~c[(equal x y)].~/

  Unlike ~ilc[equal], ~c[=] has a ~il[guard] requiring both of its arguments
  to be numbers.  Generally, ~c[=] is executed more efficiently than
  ~ilc[equal].

  For a discussion of the various ways to test against 0,
  ~l[zero-test-idioms].

  ~c[=] is a Common Lisp function.  See any Common Lisp documentation
  for more information.~/"

  (declare (xargs :mode :logic
                  :guard (and (acl2-numberp x)
                              (acl2-numberp y))))

  (equal x y))

#+acl2-loop-only
(defun /= (x y)

  ":Doc-Section ACL2::ACL2-built-ins

  test inequality of two numbers~/

  ~c[(/= x y)] is logically equivalent to ~c[(not (equal x y))].~/

  Unlike ~ilc[equal], ~c[/=] has a ~il[guard] requiring both of its arguments
  to be numbers.  Generally, ~c[/=] is executed more efficiently than
  a combination of ~ilc[not] and ~ilc[equal].

  For a discussion of the various ways to test against 0,
  ~l[zero-test-idioms].

  ~c[/=] is a Common Lisp function.  See any Common Lisp documentation
  for more information.~/"

  (Declare (xargs :mode :logic
                  :guard (and (acl2-numberp x)
                              (acl2-numberp y))))
  (not (equal x y)))

#+acl2-loop-only
(defmacro > (x y)

  ":Doc-Section ACL2::ACL2-built-ins

  greater-than test~/

  ~c[>] is a macro, and ~c[(> x y)] expands to the same thing as
  ~c[(< y x)].  ~l[<].~/

  ~c[>] is a Common Lisp function.  See any Common Lisp documentation
  for more information.~/"

  (list '< y x))

#+acl2-loop-only
(defmacro >= (x y)

  ":Doc-Section ACL2::ACL2-built-ins

  greater-than-or-equal test~/

  ~c[>=] is a macro, and ~c[(>= x y)] expands to the same thing as
  ~c[(not (< x y))].  ~l[<].~/

  ~c[>=] is a Common Lisp function.  See any Common Lisp documentation
  for more information.~/"

  (list 'not (list '< x y)))

(deflabel zero-test-idioms
  :doc
  ":Doc-Section ACL2::Programming

  how to test for 0~/

  Below are six commonly used idioms for testing whether ~c[x] is ~c[0].
  ~ilc[Zip] and ~ilc[zp] are the preferred termination tests for recursions
  down the integers and naturals, respectively.
  ~bv[]
  idiom       logical              guard                 primary
              meaning                                 compiled code*

  (equal x 0) (equal x 0)          t                   (equal x 0)

  (eql x 0)   (equal x 0)          t                   (eql x 0)

  (zerop x)   (equal x 0)          x is a number       (= x 0)

  (= x 0)     (equal x 0)          x is a number       (= x 0)

  (zip x)     (equal (ifix x) 0)   x is an integer     (= x 0)

  (zp x)      (equal (nfix x) 0)   x is a natural      (int= x 0)

  (zpf x)     (equal (nfix x) 0)   x is a fixnum >= 0  (eql (the-fixnum x) 0)
  ~ev[]
  *~l[guards-and-evaluation], especially the subsection titled
  ``Guards and evaluation V: efficiency issues''.  Primary code is
  relevant only if ~il[guard]s are verified.  The ``compiled code'' shown
  is only suggestive.~/

  The first four idioms all have the same logical meaning and differ
  only with respect to their executability and efficiency.  In the
  absence of compiler optimizing, ~c[(= x 0)] is probably the most
  efficient, ~c[(equal x 0)] is probably the least efficient, and
  ~c[(eql x 0)] is in between.  However, an optimizing compiler could
  always choose to compile ~c[(equal x 0)] as ~c[(eql x 0)] and, in
  situations where ~c[x] is known at compile-time to be numeric,
  ~c[(eql x 0)] as ~c[(= x 0)].  So efficiency considerations must, of
  course, be made in the context of the host compiler.

  Note also that ~c[(zerop x)] and ~c[(= x 0)] are indistinguishable.
  They have the same meaning and the same ~il[guard], and can reasonably be
  expected to generate equally efficient code.

  Note that ~c[(zip x)] and ~c[(zp x)] do not have the same logical
  meanings as the others or each other.  They are not simple tests for
  equality to ~c[0].  They each coerce ~c[x] into a restricted domain,
  ~ilc[zip] to the integers and ~ilc[zp] to the natural numbers, choosing
  ~c[0] for ~c[x] when ~c[x] is outside the domain.  Thus, ~c[1/2], ~c[#c(1 3)],
  and ~c['abc], for example, are all ``recognized'' as zero by both
  ~ilc[zip] and ~ilc[zp].  But ~ilc[zip] reports that ~c[-1] is different from
  ~c[0] while ~ilc[zp] reports that ~c[-1] ``is'' ~c[0].  More precisely,
  ~c[(zip -1)] is ~c[nil] while ~c[(zp -1)] is ~c[t].

  Note that the last five idioms all have ~il[guard]s that restrict their
  Common Lisp executability.  If these last five are used in
  situations in which ~il[guard]s are to be verified, then proof
  obligations are incurred as the price of using them.  If guard
  verification is not involved in your project, then the first five
  can be thought of as synonymous.

  ~ilc[Zip] and ~ilc[zp] are not provided by Common Lisp but are
  ACL2-specific functions.  Why does ACL2 provide these functions?
  The answer has to do with the admission of recursively defined
  functions and efficiency.  ~ilc[Zp] is provided as the zero-test in
  situations where the controlling formal parameter is understood to
  be a natural number.  ~ilc[Zip] is analogously provided for the integer
  case.  We illustrate below.

  Here is an admissible definition of factorial
  ~bv[]
  (defun fact (n) (if (zp n) 1 (* n (fact (1- n)))))
  ~ev[]
  Observe the classic recursion scheme: a test against ~c[0] and recursion
  by ~ilc[1-].  Note however that the test against ~c[0] is expressed with the
  ~ilc[zp] idiom.  Note also the absence of a ~il[guard] making explicit our
  intention that ~c[n] is a natural number.

  This definition of factorial is readily admitted because when ~c[(zp n)]

  is false (i.e., ~c[nil]) then ~c[n] is a natural number other than
  ~c[0] and so ~c[(1- n)] is less than ~c[n].  The base case, where ~c[(zp n)]
  is true, handles all the ``unexpected'' inputs, such as arise with
  ~c[(fact -1)] and ~c[(fact 'abc)].  When calls of ~c[fact] are
  evaluated, ~c[(zp n)] checks ~c[(integerp n)] and ~c[(> n 0)].  ~il[Guard]
  verification is unsuccessful for this definition of ~c[fact] because
  ~ilc[zp] requires its argument to be a natural number and there is no
  ~il[guard] on ~c[fact], above.  Thus the primary raw lisp for ~c[fact] is
  inaccessible and only the ~c[:]~ilc[logic] definition (which does runtime
  ``type'' checking) is used in computation.  In summary, this
  definition of factorial is easily admitted and easily manipulated by
  the prover but is not executed as efficiently as it could be.

  Runtime efficiency can be improved by adding a ~il[guard] to the definition.
  ~bv[]
  (defun fact (n)
    (declare (xargs :guard (and (integerp n) (>= n 0))))
    (if (zp n) 1 (* n (fact (1- n)))))
  ~ev[]
  This ~il[guard]ed definition has the same termination conditions as
  before -- termination is not sensitive to the ~il[guard].  But the ~il[guard]s
  can be verified.  This makes the primary raw lisp definition
  accessible during execution.  In that definition, the ~c[(zp n)] above
  is compiled as ~c[(= n 0)], because ~c[n] will always be a natural number
  when the primary code is executed.  Thus, by adding a ~il[guard] and
  verifying it, the elegant and easily used definition of factorial is
  also efficiently executed on natural numbers.

  Now let us consider an alternative definition of factorial in which
  ~c[(= n 0)] is used in place of ~c[(zp n)].
  ~bv[]
  (defun fact (n) (if (= n 0) 1 (* n (fact (1- n)))))
  ~ev[]
  This definition does not terminate.  For example ~c[(fact -1)] gives
  rise to a call of ~c[(fact -2)], etc.  Hence, this alternative is
  inadmissible.  A plausible response is the addition of a ~il[guard]
  restricting ~c[n] to the naturals:
  ~bv[]
  (defun fact (n)
   (declare (xargs :guard (and (integerp n) (>= n 0))))
   (if (= n 0) 1 (* n (fact (1- n)))))
  ~ev[]
  But because the termination argument is not sensitive to the ~il[guard],
  it is still impossible to admit this definition.  To influence the
  termination argument one must change the conditions tested.  Adding
  a runtime test that ~c[n] is a natural number would suffice and allow
  both admission and ~il[guard] verification.  But such a test would slow
  down the execution of the compiled function.

  The use of ~c[(zp n)] as the test avoids this dilemma.  ~ilc[Zp]
  provides the logical equivalent of a runtime test that ~c[n] is a
  natural number but the execution efficiency of a direct ~ilc[=]
  comparison with ~c[0], at the expense of a ~il[guard] conjecture to prove.
  In addition, if ~il[guard] verification and most-efficient execution are
  not needed, then the use of ~c[(zp n)] allows the admission of the
  function without a ~il[guard] or other extraneous verbiage.

  While general rules are made to be broken, it is probably a good
  idea to get into the habit of using ~c[(zp n)] as your terminating
  ``~c[0] test'' idiom when recursing down the natural numbers.  It
  provides the logical power of testing that ~c[n] is a non-~c[0]
  natural number and allows efficient execution.

  We now turn to the analogous function, ~ilc[zip].  ~ilc[Zip] is the
  preferred ~c[0]-test idiom when recursing through the integers toward
  ~c[0].  ~ilc[Zip] considers any non-integer to be ~c[0] and otherwise
  just recognizes ~c[0].  A typical use of ~ilc[zip] is in the definition
  of ~ilc[integer-length], shown below.  (ACL2 can actually accept this
  definition, but only after appropriate lemmas have been proved.)
  ~bv[]
  (defun integer-length (i)
    (declare (xargs :guard (integerp i)))
    (if (zip i)
        0
      (if (= i -1)
        0
        (+ 1 (integer-length (floor i 2))))))
  ~ev[]
  Observe that the function recurses by ~c[(floor i 2)].  Hence,
  calling the function on ~c[25] causes calls on ~c[12], ~c[6], ~c[3],
  ~c[1], and ~c[0], while calling it on ~c[-25] generates calls on
  ~c[-13], ~c[-7], ~c[-4], ~c[-2], and ~c[-1].  By making ~c[(zip i)] the
  first test, we terminate the recursion immediately on non-integers.
  The ~il[guard], if present, can be verified and allows the primary raw
  lisp definition to check ~c[(= i 0)] as the first terminating
  condition (because the primary code is executed only on integers).")

(defmacro int= (i j)

  ":Doc-Section ACL2::ACL2-built-ins

  test equality of two integers~/

  ~c[(int= x y)] is logically equivalent to ~c[(equal x y)].~/

  Unlike ~ilc[equal], ~c[int=] requires its arguments to be numbers (or
  else causes a ~il[guard] violation; ~pl[guard]).  Generally, ~c[int=]
  is executed more efficiently than ~ilc[equal] or ~ilc[=] on integers."

  (list 'eql

; The extra care taken below not to wrap (the integer ...) around integers is
; there to overcome an inefficiency in Allegro 5.0.1 (and probably other
; Allegro releases).  Rob Sumners has reported this problem (6/25/00) to Franz.

        (if (integerp i) i (list 'the 'integer i))
        (if (integerp j) j (list 'the 'integer j))))

#+acl2-loop-only
(defun zp (x)
  (declare (xargs :mode :logic
                  :guard (and (integerp x) (<= 0 x))))

  ":Doc-Section ACL2::ACL2-built-ins

  testing a ``natural'' against 0~/

  ~c[(Zp n)] is logically equivalent to ~c[(equal (nfix n) 0)] and is
  the preferred termination test for recursion down the natural
  numbers. ~c[(Zp n)] returns ~c[t] if ~c[n] is ~c[0] or not a natural
  number; it returns ~c[nil] otherwise.  Thus, in the ACL2 logic
  (ignoring the issue of ~il[guard]s):
  ~bv[]
      n       (zp n)
     3         nil
     0         t
     -1        t
     5/2       t
     #c(1 3)   t
     'abc      t
  ~ev[]~/

  ~c[(Zp n)] has a ~il[guard] requiring ~c[n] to be a natural number.

  For a discussion of the various idioms for testing against ~c[0],
  ~pl[zero-test-idioms].

  ~c[Zp] is typically used as the termination test in recursions down
  the natural numbers.  It has the advantage of ``coercing'' its
  argument to a natural and hence allows the definition to be admitted
  without an explicit type check in the body.  ~il[Guard] verification
  allows ~c[zp] to be compiled as a direct ~ilc[=]-comparision with ~c[0]."

  (if (integerp x)
      (<= x 0)
    t))

#-acl2-loop-only
; Consider using mbe to avoid this cheat.
(defun-one-output zp (x)
  (declare (type integer x))
  (int= x 0))

(defthm zp-compound-recognizer

; This rule improves the ability of ACL2 to compute useful type prescriptions
; for functions.  For example, the following function is typed using
; acl2-numberp instead of integerp unless we have this rule:
; (defun foo (index lst)
;   (if (zp index)
;       nil
;     (let ((i (1- index))) (or (foo i lst) (and (not (bar i lst)) i)))))

  (equal (zp x)
         (or (not (integerp x))
             (<= x 0)))
  :rule-classes :compound-recognizer)

(defthm zp-open

; The preceding event avoids some case-splitting when the
; zp-compound-recognizer (above) provides all the information needed about an
; argument of zp.  However, the following example illustrates the need to open
; up zp on some non-variable terms:

; (thm (implies (and (zp (+ (- k) n))
;                   (integerp k)
;                   (integerp n)
;                   (<= k j))
;               (<= n j)))

; The present rule allows the theorem above to go through.  This example
; theorem was distilled from the failure (without this rule) of event
; compress11-assoc-property-1 in community book
; books/data-structures/array1.lisp.

  (implies (syntaxp (not (variablep x)))
           (equal (zp x)
                  (if (integerp x)
                      (<= x 0)
                    t))))

(in-theory (disable zp))

#+acl2-loop-only
(defun zip (x)
  (declare (xargs :mode :logic
                  :guard (integerp x)))

  ":Doc-Section ACL2::ACL2-built-ins

  testing an ``integer'' against 0~/

  ~c[(Zip i)] is logically equivalent to ~c[(equal (ifix i) 0)] and is
  the preferred termination test for recursion through the integers.
  ~c[(Zip i)] returns ~c[t] if ~c[i] is ~c[0] or not an integer; it
  returns ~c[nil] otherwise.  Thus,
  ~bv[]
     i         (zip i)
     3         nil
     0         t
     -2        nil
     5/2       t
     #c(1 3)   t
     'abc      t
  ~ev[]~/

  ~c[(Zip i)] has a ~il[guard] requiring ~c[i] to be an integer.

  For a discussion of the various idioms for testing against ~c[0],
  ~pl[zero-test-idioms].

  ~c[Zip] is typically used as the termination test in recursions
  through the integers.  It has the advantage of ``coercing'' its
  argument to an integer and hence allows the definition to be
  admitted without an explicit type check in the body.  ~il[Guard]
  verification allows ~c[zip] to be compiled as a direct
  ~ilc[=]-comparision with ~c[0]."

  (if (integerp x)
      (= x 0)
    t))

#-acl2-loop-only
; If we had :body we wouldn't need this cheat.
(defun-one-output zip (x) (= x 0))

(defthm zip-compound-recognizer

; See the comment for zp-compound-recognizer.

  (equal (zip x)
         (or (not (integerp x))
             (equal x 0)))
  :rule-classes :compound-recognizer)

(defthm zip-open
  (implies (syntaxp (not (variablep x)))
           (equal (zip x)
                  (or (not (integerp x))
                      (equal x 0)))))

(in-theory (disable zip))

#+acl2-loop-only
(defun nth (n l)

  ":Doc-Section ACL2::ACL2-built-ins

  the nth element (zero-based) of a list~/

  ~c[(Nth n l)] is the ~c[n]th element of ~c[l], zero-based.  If ~c[n] is
  greater than or equal to the length of ~c[l], then ~c[nth] returns ~c[nil].~/

  ~c[(Nth n l)] has a ~il[guard] that ~c[n] is a non-negative integer and
  ~c[l] is a ~ilc[true-listp].

  ~c[Nth] is a Common Lisp function.  See any Common Lisp documentation
  for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (integerp n)
                              (>= n 0)
                              (true-listp l))))
  (if (endp l)
      nil
    (if (zp n)
        (car l)
      (nth (- n 1) (cdr l)))))

#+acl2-loop-only
(defun char (s n)

  ":Doc-Section ACL2::ACL2-built-ins

  the ~il[nth] element (zero-based) of a string~/

  ~c[(Char s n)] is the ~c[n]th element of ~c[s], zero-based.  If ~c[n] is
  greater than or equal to the length of ~c[s], then ~c[char] returns
  ~c[nil].~/

  ~c[(Char s n)] has a ~il[guard] that ~c[n] is a non-negative integer and
  ~c[s] is a ~ilc[stringp].

  ~c[Char] is a Common Lisp function.  See any Common Lisp documentation
  for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (stringp s)
                              (integerp n)
                              (>= n 0)
                              (< n (length s)))))
  (nth n (coerce s 'list)))

(defun proper-consp (x)

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for proper (null-terminated) non-empty lists~/

  ~c[Proper-consp] is the function that checks whether its argument is
  a non-empty list that ends in ~c[nil].  Also ~pl[true-listp].

  To see the ACL2 definition of this function, ~pl[pf].~/~/"

  (declare (xargs :guard t))
  (and (consp x)
       (true-listp x)))

(defun improper-consp (x)

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for improper (non-null-terminated) non-empty lists~/

  ~c[Improper-consp] is the function that checks whether its argument
  is a non-empty list that ends in other than ~c[nil].
  ~l[proper-consp] and also ~pl[true-listp].

  To see the ACL2 definition of this function, ~pl[pf].~/~/"

  (declare (xargs :guard t))
  (and (consp x)
       (not (true-listp x))))

#+acl2-loop-only
(defmacro * (&rest rst)

  ":Doc-Section ACL2::ACL2-built-ins

  multiplication macro~/

  ~c[*] is really a macro that expands to calls of the function
  ~ilc[binary-*].  So for example
  ~bv[]
  (* x y 4 z)
  ~ev[]
  represents the same term as
  ~bv[]
  (binary-* x (binary-* y (binary-* 4 z))).
  ~ev[]~/

  ~l[binary-*].

  ~c[*] is a Common Lisp function.  See any Common Lisp documentation
  for more information.~/"

  (cond ((null rst) 1)
        ((null (cdr rst)) (list 'binary-* 1 (car rst)))
        (t (xxxjoin 'binary-* rst))))

;; RAG - This function was modified to accept all complex arguments,
;; not just the complex-rationalps

#+acl2-loop-only
(defun conjugate (x)

  ":Doc-Section ACL2::ACL2-built-ins

  complex number conjugate~/

  ~c[Conjugate] takes an ACL2 number as an argument, and returns its
  complex conjugate (i.e., the result of negating its imaginary
  part.).~/

  ~c[Conjugate] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (acl2-numberp x)))
  (if (complex/complex-rationalp x)
      (complex (realpart x)
               (- (imagpart x)))
      x))

(defmacro prog2$ (x y)

; This odd little duck is not as useless as it may seem.  Its original purpose
; was to serve as a messenger for translate to use to send a message to the
; guard checker.  Guards that are created by declarations in lets and other
; places are put into the first arg of a prog2$.  Once the guards required by x
; have been noted, x's value may be ignored.  If this definition is changed,
; consider the places prog2$ is mentioned, including the mention of 'prog2$ in
; distribute-first-if.

; We have since found other uses for prog2$, which are documented in the doc
; string below.

  ":Doc-Section ACL2::ACL2-built-ins

  execute two forms and return the value of the second one~/

  ~l[hard-error], ~pl[illegal], and ~pl[cw] for examples of functions to call
  in the first argument of ~c[prog2$].  Also ~pl[progn$] for an extension of
  ~c[prog2$] that handles than two arguments.~/

  Semantically, ~c[(Prog2$ x y)] equals ~c[y]; the value of ~c[x] is ignored.
  However, ~c[x] is first evaluated for side effect.  Since the ACL2
  ~il[programming] language is applicative, there can be no logical impact of
  evaluating ~c[x].  However, ~c[x] may involve a call of a function such as
  ~ilc[hard-error] or ~ilc[illegal], which can cause so-called ``hard errors'',
  or a call of ~ilc[cw] to perform output.

  Here is a simple, contrived example using ~ilc[hard-error].  The intention
  is to check at run-time that the input is appropriate before calling
  function ~c[bar].
  ~bv[]
  (defun foo-a (x)
    (declare (xargs :guard (consp x)))
    (prog2$
     (or (good-car-p (car x))
         (hard-error 'foo-a
                     \"Bad value for x: ~~p0\"
                     (list (cons #\\0 x))))
     (bar x)))
  ~ev[]
  The following similar function uses ~ilc[illegal] instead of ~c[hard-error].
  Since ~c[illegal] has a guard of ~c[nil], ~il[guard] verification would
  guarantee that the call of ~c[illegal] below will never be made (at
  least when guard checking is on; ~pl[set-guard-checking]).
  ~bv[]
  (defun foo-b (x)
    (declare (xargs :guard (and (consp x) (good-car-p (car x)))))
    (prog2$
     (or (good-car-p (car x))
         (illegal 'foo-b
                  \"Bad value for x: ~~p0\"
                  (list (cons #\\0 x))))
     (bar x)))
  ~ev[]

  We conclude with a simple example using ~ilc[cw] from the ACL2 sources.

  ~bv[]
  (defun print-terms (terms iff-flg wrld)

  ; Print untranslations of the given terms with respect to iff-flg, following
  ; each with a newline.

  ; We use cw instead of the fmt functions because we want to be able to use this
  ; function in print-type-alist-segments (used in brkpt1), which does not return
  ; state.

    (if (endp terms)
        terms
      (prog2$
       (cw \"~~q0\" (untranslate (car terms) iff-flg wrld))
       (print-terms (cdr terms) iff-flg wrld))))
  ~ev[]~/"

  `(return-last 'progn ,x ,y))

(deflabel Other
  :doc
  ":Doc-Section Other

  other commonly used top-level functions~/~/

  This section contains an assortment of top-level functions that fit into none
  of the other categories and yet are suffiently useful as to merit
  ``~c[advertisement]'' in the ~c[:]~ilc[help] command.~/")

(deflabel acl2-help
  :doc
  ":Doc-Section Other

  the acl2-help mailing list~/

  You can email questions about ACL2 usage to the acl2-help mailing list:
  ~c[acl2-help@utlists.utexas.edu].  If you have more general questions about
  ACL2, for example, about projects completed using ACL2, you may prefer the
  acl2 mailing list, ~c[acl2@utlists.utexas.edu], which tends to have wider
  distribution.~/~/")

#-acl2-loop-only
(defmacro ec-call1-raw (ign x)
  (declare (ignore ign))
  (assert (and (consp x) (symbolp (car x)))) ; checked by translate11
  (let ((*1*fn (*1*-symbol (car x))))
    `(funcall
      (cond
       (*safe-mode-verified-p* ; see below for discussion of this case
        ',(car x))
       ((fboundp ',*1*fn) ',*1*fn)
       (t

; We should never hit this case, unless the user is employing trust tags or raw
; Lisp.  For ACL2 events that might hit this case, such as a defconst using
; ec-call in a book (see below), we should ensure that *safe-mode-verified-p*
; is bound to t.  For example, we do so in the raw Lisp definition of defconst,
; which is justified because when ACL2 processes the defconst it will evaluate
; in safe-mode to ensure that no raw Lisp error could occur.

; Why is the use above of *safe-mode-verified-p* necessary?  If an event in a
; book calls ec-call in raw Lisp, then we believe that the event is a defpkg or
; defconst event.  In such cases, ec-call may be expected to invoke a *1*
; function.  Unfortunately, the *1* function definitions are laid down (by
; write-expansion-file) at the end of the expansion file.  However, we cannot
; simply move the *1* definitions to the front of the expansion file, because
; some may refer to constants or packages defined in the book.  We might wish
; to consider interleaving *1* definitions with events from the book but that
; seems difficult to do.  Instead, we arrange with *safe-mode-verified-p* to
; avoid the *1* function calls entirely when loading the expansion file (or its
; compilation).

        (error "Undefined function, ~s.  Please contact the ACL2 implementors."
               ',*1*fn)))
      ,@(cdr x))))

(defmacro ec-call1 (ign x)

; We introduce ec-call1 inbetween the utlimate macroexpansion of an ec-call
; form to a return-last form, simply because untranslate will produce (ec-call1
; nil x) from (return-last 'ec-call1-raw nil x).

  `(return-last 'ec-call1-raw ,ign ,x))

(defmacro ec-call (x)

  ":Doc-Section ACL2::ACL2-built-ins

  execute a call in the ACL2 logic instead of raw Lisp~/

  The name ``~c[ec-call]'' represents ``executable-counterpart call.''  This
  utility is intended for users who are familiar with guards.  ~l[guard] for a
  general discussion of guards.

  Logically, ~c[ec-call] behaves like the identity macro; during proofs,
  ~c[(ec-call TERM)] is typically replaced quickly by ~c[TERM] during a proof
  attempt.  However, ~c[ec-call] causes function calls to be evaluated in the
  ACL2 logic rather than raw Lisp, as explained below.~/

  ~bv[]
  General Form:
  (ec-call (fn term1 ... termk))
  ~ev[]
  where ~c[fn] is a known function symbol other than those in the list that is
  the value of the constant ~c[*ec-call-bad-ops*].  In particular, ~c[fn] is
  not a macro.  Semantically, ~c[(ec-call (fn term1 ... termk))] equals
  ~c[(fn term1 ... termk)].  However, this use of ~c[ec-call] has two effects.
  ~bq[]

  (1) ~il[Guard] verification generates no proof obligations from the guard of
  ~c[fn] for this call.  Indeed, guards need not have been verified for
  ~c[fn].

  (2) During evaluation, after the arguments of ~c[fn] are evaluated as usual,
  the executable counterpart of ~c[fn] is called, rather than ~c[fn] as defined
  in raw Lisp.  That is, the call of ~c[fn] is made on its evaluated arguments
  as though this call is being made in the ACL2 top-level loop, rather than in
  raw Lisp.  In particular, the ~il[guard] of ~c[fn] is checked, at least by
  default (~pl[set-guard-checking]).~eq[]

  Note that in the term (ec-call (fn term1 ... termk))~c[], only the indicated
  call of ~c[fn] is made in the logic; each ~c[termi] is evaluated in the
  normal manner.  If you want an entire term evaluated in the logic, wrap
  ~c[ec-call] around each function call in the term (other than calls of ~c[if]
  and ~c[ec-call]).

  ~st[Technical Remark] (probably best ignored).  During evaluation of a call
  of ~ilc[defconst] or ~ilc[defpkg] in raw Lisp, a form
  ~c[(ec-call (fn term1 ... termk))] is treated as ~c[(fn term1 ... termk)],
  that is, without calling the executable counterpart of ~c[fn].  This
  situation occurs when loading a compiled file (or expansion file) on behalf
  of an ~ilc[include-book] event.  The reason is technical: executable
  counterparts are defined below a book's events in the book's compiled file.
  End of Technical Remark.

  Here is a small example.  We define ~c[foo] recursively but with guard
  verification inhibited on the recursive call, which is to be evaluated in the
  ACL2 logic.
  ~bv[]
  ACL2 !>(defun foo (x y)
          (declare (xargs :guard (consp y)))
          (if (consp x)
              (cons (car x) (ec-call (foo (cdr x) (cdr y))))
            (car y)))

  The admission of FOO is trivial, using the relation O< (which is known
  to be well-founded on the domain recognized by O-P) and the measure
  (ACL2-COUNT X).  We could deduce no constraints on the type of FOO.

  Computing the guard conjecture for FOO....

  The guard conjecture for FOO is trivial to prove.  FOO is compliant
  with Common Lisp.

  Summary
  Form:  ( DEFUN FOO ...)
  Rules: NIL
  Warnings:  None
  Time:  0.00 seconds (prove: 0.00, print: 0.00, other: 0.00)
   FOO
  ACL2 !>(foo '(2 3 4 5) '(6 7))


  ACL2 Error in TOP-LEVEL:  The guard for the function call (FOO X Y),
  which is (CONSP Y), is violated by the arguments in the call
  (FOO '(4 5) NIL).  To debug see :DOC print-gv, see :DOC trace, and
  see :DOC wet.  See :DOC set-guard-checking for information about suppressing
  this check with (set-guard-checking :none), as recommended for new
  users.

  ACL2 !>
  ~ev[]
  The error above arises because eventually, ~c[foo] recurs down to a value of
  parameter ~c[y] that violates the guard.  This is clear from tracing
  (~pl[trace$] and ~pl[trace]).  Each call of the executable counterpart of
  ~c[foo] (the so-called ``*1*'' function for ~c[foo]) checks the guard and
  then invokes the raw Lisp version of ~c[foo].  The raw Lisp version calls
  the executable counterpart on the recursive call.  When the guard check fails
  we get a violation.
  ~bv[]
  ACL2 !>(trace$ foo)
   ((FOO))
  ACL2 !>(foo '(2 3 4 5) '(6 7))
  1> (ACL2_*1*_ACL2::FOO (2 3 4 5) (6 7))
    2> (FOO (2 3 4 5) (6 7))
      3> (ACL2_*1*_ACL2::FOO (3 4 5) (7))
        4> (FOO (3 4 5) (7))
          5> (ACL2_*1*_ACL2::FOO (4 5) NIL)


  ACL2 Error in TOP-LEVEL:  The guard for the function call (FOO X Y),
  which is (CONSP Y), is violated by the arguments in the call
  (FOO '(4 5) NIL).  To debug see :DOC print-gv, see :DOC trace, and
  see :DOC wet.  See :DOC set-guard-checking for information about suppressing
  this check with (set-guard-checking :none), as recommended for new
  users.

  ACL2 !>
  ~ev[]
  If we turn off guard errors then we can see the trace as above, but where we
  avoid calling the raw Lisp function when the guard fails to hold.
  ~bv[]
  ACL2 !>:set-guard-checking nil

  Masking guard violations but still checking guards except for self-
  recursive calls.  To avoid guard checking entirely, :SET-GUARD-CHECKING
  :NONE.  See :DOC set-guard-checking.

  ACL2 >(foo '(2 3 4 5) '(6 7))
  1> (ACL2_*1*_ACL2::FOO (2 3 4 5) (6 7))
    2> (FOO (2 3 4 5) (6 7))
      3> (ACL2_*1*_ACL2::FOO (3 4 5) (7))
        4> (FOO (3 4 5) (7))
          5> (ACL2_*1*_ACL2::FOO (4 5) NIL)
            6> (ACL2_*1*_ACL2::FOO (5) NIL)
              7> (ACL2_*1*_ACL2::FOO NIL NIL)
              <7 (ACL2_*1*_ACL2::FOO NIL)
            <6 (ACL2_*1*_ACL2::FOO (5))
          <5 (ACL2_*1*_ACL2::FOO (4 5))
        <4 (FOO (3 4 5))
      <3 (ACL2_*1*_ACL2::FOO (3 4 5))
    <2 (FOO (2 3 4 5))
  <1 (ACL2_*1*_ACL2::FOO (2 3 4 5))
  (2 3 4 5)
  ACL2 >
  ~ev[]
  ~/"

  (declare (xargs :guard t))
  `(ec-call1 nil ,x))

(defmacro non-exec (x)

  ":Doc-Section ACL2::ACL2-built-ins

  mark code as non-executable~/

  ~c[Non-exec] is a macro such that logically, ~c[(non-exec x)] is equal to
  ~c[x].  However, the argument to a call of ~c[non-exec] need not obey the
  usual syntactic restrictions for executable code, and indeed, evaluation of a
  call of ~c[non-exec] will result in an error.  Moreover, for any form
  occurring in the body of a function (~pl[defun]) that is a call of
  ~c[non-exec], no guard proof obligations are generated for that form.

  The following example, although rather contrived, illustrates the use of
  ~c[non-exec].  One can imagine a less contrived example that efficiently
  computes return values for a small number of fixed inputs and, for other
  inputs, returns something logically ``consistent'' with those return values.
  ~bv[]
  (defun double (x)
    (case x
      (1 2)
      (2 4)
      (3 6)
      (otherwise (non-exec (* 2 x)))))
  ~ev[]
  We can prove that ~c[double] is compliant with Common Lisp (~pl[guard]) and
  that it always computes ~c[(* 2 x)].
  ~bv[]
  (verify-guards double)
  (thm (equal (double x) (* 2 x)))
  ~ev[]
  We can evaluate double on the specified arguments.  But a call of
  ~c[non-exec] results in an error message that reports the form that was
  supplied to ~c[non-exec].
  ~bv[]
  ACL2 !>(double 3)
  6
  ACL2 !>(double 10)


  ACL2 Error in TOP-LEVEL:  ACL2 has been instructed to cause an error
  because of an attempt to evaluate the following form (see :DOC non-
  exec):

    (* 2 X).

  To debug see :DOC print-gv, see :DOC trace, and see :DOC wet.

  ACL2 !>
  ~ev[]~/

  During proofs, the error is silent; it is ``caught'' by the proof mechanism
  and generally results in the introduction of a call of ~ilc[hide] during a
  proof.

  Also ~pl[defun-nx] for a utility that makes every call of a function
  non-executable, rather than a specified form.  The following examples
  contrast ~c[non-exec] with ~ilc[defun-nx], in particular illustratating the
  role of ~ilc[non-exec] in avoiding guard proof obligations.
  ~bv[]
  ; Guard verification fails:
  (defun-nx f1 (x)
    (declare (xargs :guard t))
    (car x))

  ; Guard verification succeeds after changing the guard above:
  (defun-nx f1 (x)
    (declare (xargs :guard (consp x)))
    (car x))

  ; Guard verification succeeds:
  (defun f2 (x)
    (declare (xargs :guard t))
    (non-exec (car x)))

  ; Evaluating (g1) prints \"Hello\" before signaling an error.
  (defun g1 ()
    (f1 (cw \"Hello\")))

  ; Evaluating (g2) does not print before signaling an error.
  (defun g2 ()
    (non-exec (cw \"Hello\")))

  ; Evaluating (h1) gives a guard violation for taking reciprocal of 0.
  (defun h1 ()
    (f1 (/ 1 0)))

  ; Evaluating (h2) does not take a reciprocal, hence there is no guard
  ; violation for that; we just get the error expected from using non-exec.
  (defun h2 ()
    (non-exec (/ 0)))
  ~ev[]"

  (declare (xargs :guard t))
  `(prog2$ (throw-nonexec-error :non-exec ',x)
           ,x))

#+acl2-loop-only
(defmacro / (x &optional (y 'nil binary-casep))

  ":Doc-Section ACL2::ACL2-built-ins

  macro for division and reciprocal~/

  ~l[binary-*] for multiplication and ~pl[unary-/] for reciprocal.~/

  Note that ~c[/] represents division as follows:
  ~bv[]
  (/ x y)
  ~ev[]
  represents the same term as
  ~bv[]
  (* x (/ y))
  ~ev[]
  which is really
  ~bv[]
  (binary-* x (unary-/ y)).
  ~ev[]
  Also note that ~c[/] represents reciprocal as follows:
  ~bv[]
  (/ x)
  ~ev[]
  expands to
  ~bv[]
  (unary-/ x).
  ~ev[]
  ~c[/] is a Common Lisp macro.  See any Common Lisp documentation
  for more information.~/"

  (cond (binary-casep (list 'binary-* x (list 'unary-/ y)))
        (t (list 'unary-/ x))))

; This, and many of the axioms that follow, could be defthms.  However, we want
; to make explicit what our axioms are, rather than relying on (e.g.) linear
; arithmetic.  This is a start.

(defaxiom closure
  (and (acl2-numberp (+ x y))
       (acl2-numberp (* x y))
       (acl2-numberp (- x))
       (acl2-numberp (/ x)))
  :rule-classes nil)

(defaxiom Associativity-of-+
  (equal (+ (+ x y) z) (+ x (+ y z))))

(defaxiom Commutativity-of-+
  (equal (+ x y) (+ y x)))

(defun fix (x)

  ":Doc-Section ACL2::ACL2-built-ins

  coerce to a number~/

  ~c[Fix] simply returns any numeric argument unchanged, returning ~c[0]
  on a non-numeric argument.  Also ~pl[nfix], ~pl[ifix], and
  ~pl[rfix] for analogous functions that coerce to a natural
  number, an integer, and a rational number, respectively.~/

  ~c[Fix] has a ~il[guard] of ~c[t].

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard t))
  (if (acl2-numberp x)
      x
    0))

(defaxiom Unicity-of-0
  (equal (+ 0 x)
         (fix x)))

(defaxiom Inverse-of-+
  (equal (+ x (- x)) 0))

(defaxiom Associativity-of-*
  (equal (* (* x y) z) (* x (* y z))))

(defaxiom Commutativity-of-*
  (equal (* x y) (* y x)))

(defaxiom Unicity-of-1
  (equal (* 1 x)
         (fix x)))

(defaxiom Inverse-of-*
  (implies (and (acl2-numberp x)
                (not (equal x 0)))
           (equal (* x (/ x)) 1)))

(defaxiom Distributivity
  (equal (* x (+ y z))
         (+ (* x y) (* x z))))

(defaxiom <-on-others
  (equal (< x y)
         (< (+ x (- y)) 0))
  :rule-classes nil)

(defaxiom Zero
  (not (< 0 0))
  :rule-classes nil)

(defaxiom Trichotomy
  (and
   (implies (acl2-numberp x)
            (or (< 0 x)
                (equal x 0)
                (< 0 (- x))))
   (or (not (< 0 x))
       (not (< 0 (- x)))))
  :rule-classes nil)

;; RAG - This axiom was weakened to accomodate real x and y

(defaxiom Positive
  (and (implies (and (< 0 x) (< 0 y))
                (< 0 (+ x y)))
       (implies (and (real/rationalp x)
                     (real/rationalp y)
                     (< 0 x)
                     (< 0 y))
                (< 0 (* x y))))
  :rule-classes nil)

(defaxiom Rational-implies1
  (implies (rationalp x)
           (and (integerp (denominator x))
                (integerp (numerator x))
                (< 0 (denominator x))))
  :rule-classes nil)

(defaxiom Rational-implies2
  (implies (rationalp x)

; We use the left-hand side below out of respect for the fact that
; unary-/ is invisible with respect to binary-*.

           (equal (* (/ (denominator x)) (numerator x)) x)))

(defaxiom integer-implies-rational
  (implies (integerp x) (rationalp x))
  :rule-classes nil)

#+:non-standard-analysis
(defaxiom rational-implies-real
  (implies (rationalp x) (realp x))
  :rule-classes nil)

;; RAG - This axiom was weakened to accomodate the reals.

(defaxiom complex-implies1
  (and (real/rationalp (realpart x))
       (real/rationalp (imagpart x)))
  :rule-classes nil)

;; RAG - This axiom was strengthened to include the reals.

(defaxiom complex-definition
  (implies (and (real/rationalp x)
                (real/rationalp y))
           (equal (complex x y)
                  (+ x (* #c(0 1) y))))
  :rule-classes nil)

;; RAG - This axiom was weakened to accomodate the reals.

; This rule was called complex-rationalp-has-nonzero-imagpart before
; Version_2.5.
(defaxiom nonzero-imagpart
  (implies (complex/complex-rationalp x)
           (not (equal 0 (imagpart x))))
  :rule-classes nil)

(defaxiom realpart-imagpart-elim
  (implies (acl2-numberp x)
           (equal (complex (realpart x) (imagpart x)) x))
  :rule-classes (:REWRITE :ELIM))

; We think that the following two axioms can be proved from the others.

;; RAG - This axiom was strengthened to include the reals.

(defaxiom realpart-complex
  (implies (and (real/rationalp x)
                (real/rationalp y))
           (equal (realpart (complex x y))
                  x)))

;; RAG - This axiom was also strengthened to include the reals.

(defaxiom imagpart-complex
  (implies (and (real/rationalp x)
                (real/rationalp y))
           (equal (imagpart (complex x y))
                  y)))

;; RAG - Another axiom strengthened to include the reals.

(defthm complex-equal
  (implies (and (real/rationalp x1)
                (real/rationalp y1)
                (real/rationalp x2)
                (real/rationalp y2))
           (equal (equal (complex x1 y1) (complex x2 y2))
                  (and (equal x1 x2)
                       (equal y1 y2))))
  :hints (("Goal" :use
           ((:instance imagpart-complex
                       (x x1) (y y1))
            (:instance imagpart-complex
                       (x x2) (y y2))
            (:instance realpart-complex
                       (x x1) (y y1))
            (:instance realpart-complex
                       (x x2) (y y2)))
           :in-theory (disable imagpart-complex realpart-complex))))

(defun force (x)

  ":Doc-Section Miscellaneous

  identity function used to force a hypothesis~/

  ~c[Force] is the identity function: ~c[(force x)] is equal to ~c[x].
  However, for rules of many classes (~pl[rule-classes]), a hypothesis of the
  form ~c[(force term)] is given special treatment, as described below.  This
  treatment takes place for rule classes ~c[:]~ilc[rewrite], ~c[:]~ilc[linear],
  ~c[:]~ilc[type-prescription], ~c[:]~ilc[definition], ~c[:]~ilc[meta] (actually
  in that case, the result of evaluating the hypothesis metafunction call), and
  ~c[:]~ilc[forward-chaining].

  When a hypothesis of a conditional rule (of one of the classes listed above)
  has the form ~c[(force hyp)], it is logically equivalent to ~c[hyp] but has a
  pragmatic effect.  In particular, when the rule is considered, the needed
  instance of the hypothesis, ~c[hyp'], may be assumed if the usual process
  fails to prove it or its negation.  In that situation, if the rule is
  eventually applied, then a special case is generated, requiring the system to
  prove that ~c[hyp'] is true in the current context.  The proofs of all such
  ``forced assumptions'' are, by default, delayed until the successful
  completion of the main goal.  ~l[forcing-round] and
  ~pl[immediate-force-modep].

  Forcing is generally used on hypotheses that are always expected to be true,
  as is commonly the case for ~il[guard]s of functions.  All the power of the
  theorem prover is brought to bear on a forced hypothesis and no backtracking
  is possible.  Forced goals can be attacked immediately
  (~pl[immediate-force-modep]) or in a subsequent forcing round
  (~pl[forcing-round]).  Also ~pl[case-split] for a related utility.  If the
  ~c[:]~ilc[executable-counterpart] of the function ~c[force] is ~il[disable]d,
  then no hypothesis is forced.  For more on enabling and disabling forcing,
  ~pl[enable-forcing] and ~pl[disable-forcing].~/

  It sometimes happens that a conditional rule is not applied because
  some hypothesis, ~c[hyp], could not be relieved, even though the
  required instance of ~c[hyp], ~c[hyp'], can be shown true in the context.
  This happens when insufficient resources are brought to bear on ~c[hyp']
  at the time we try to relieve it.  A sometimes desirable alternative
  behavior is for the system to assume ~c[hyp'], apply the rule, and to
  generate explicitly a special case to show that ~c[hyp'] is true in the
  context.  This is called ``forcing'' ~c[hyp].  It can be arranged by
  restating the rule so that the offending hypothesis, ~c[hyp], is
  embedded in a call of ~c[force], as in ~c[(force hyp)].  By using the
  ~c[:]~ilc[corollary] field of the ~ilc[rule-classes] entry, a hypothesis
  can be forced without changing the statement of the theorem from
  which the rule is derived.

  Technically, ~c[force] is just a function of one argument that returns
  that argument.  It is generally ~il[enable]d and hence evaporates during
  simplification.  But its presence among the hypotheses of a
  conditional rule causes case splitting to occur if the hypothesis
  cannot be conventionally relieved.

  Since a forced hypothesis must be provable whenever the rule is
  otherwise applicable, forcing should be used only on hypotheses that
  are expected always to be true.

  A particularly common situation in which some hypotheses should be
  forced is in ``most general'' ~il[type-prescription] lemmas.  If a single
  lemma describes the ``expected'' type of a function, for all
  ``expected'' arguments, then it is probably a good idea to force the
  hypotheses of the lemma.  Thus, every time a term involving the
  function arises, the term will be given the expected type and its
  arguments will be required to be of the expected type.  In applying
  this advice it might be wise to avoid forcing those hypotheses that
  are in fact just type predicates on the arguments, since the routine
  that applies ~il[type-prescription] lemmas has fairly thorough knowledge
  of the types of all terms.

  ~c[Force] can have the additional benefit of causing the ACL2 typing
  mechanism to interact with the ACL2 rewriter to establish the
  hypotheses of ~il[type-prescription] rules.  To understand this remark,
  think of the ACL2 type reasoning system as a rather primitive
  rule-based theorem prover for questions about Common Lisp types,
  e.g., ``does this expression produce a ~ilc[consp]?''  ``does this
  expression produce some kind of ACL2 number, e.g., an ~ilc[integerp], a
  ~ilc[rationalp], or a ~ilc[complex-rationalp]?'' etc.  It is driven by
  ~il[type-prescription] rules.  To relieve the hypotheses of such rules,
  the type system recursively invokes itself.  This can be done for
  any hypothesis, whether it is ``type-like'' or not, since any
  proposition, ~c[p], can be phrased as the type-like question ``does ~c[p]
  produce an object of type ~c[nil]?''  However, as you might expect, the
  type system is not very good at establishing hypotheses that are not
  type-like, unless they happen to be assumed explicitly in the
  context in which the question is posed, e.g., ``If ~c[p] produces a
  ~ilc[consp] then does ~c[p] produce ~c[nil]?''  If type reasoning alone is
  insufficient to prove some instance of a hypothesis, then the
  instance will not be proved by the type system and a
  ~il[type-prescription] rule with that hypothesis will be inapplicable in
  that case.  But by embedding such hypotheses in ~c[force] expressions
  you can effectively cause the type system to ``punt'' them to the
  rest of the theorem prover.  Of course, as already noted, this
  should only be done on hypotheses that are ``always true.''  In
  particular, if rewriting is required to establish some hypothesis of
  a ~il[type-prescription] rule, then the rule will be found inapplicable
  because the hypothesis will not be established by type reasoning
  alone.

  The ACL2 rewriter uses the type reasoning system as a subsystem.  It
  is therefore possible that the type system will force a hypothesis
  that the rewriter could establish.  Before a forced hypothesis is
  reported out of the rewriter, we try to establish it by rewriting.

  This makes the following surprising behavior possible: A
  ~il[type-prescription] rule fails to apply because some true hypothesis
  is not being relieved.  The user changes the rule so as to ~st[force] the
  hypothesis.  The system then applies the rule but reports no
  forcing.  How can this happen?  The type system ``punted'' the
  forced hypothesis to the rewriter, which established it.

  Finally, we should mention that the rewriter is never willing to force when
  there is an ~ilc[if] term present in the goal being simplified.  Since
  ~ilc[and] terms and ~ilc[or] terms are merely abbreviations for ~ilc[if]
  terms, they also prevent forcing.  Note that ~ilc[if] terms are ultimately
  eliminated using the ordinary flow of the proof (but
  ~pl[set-case-split-limitations]), allowing ~c[force] ultimately to function
  as intended.  Moreover, forcing can be disabled, as described above; also
  ~pl[disable-forcing].~/"

; We define this function in :logic mode on the first pass so that it gets a
; nume.  See the comment in check-built-in-constants.

  (declare (xargs :mode :logic :guard t))

  x)

; See the comment in check-built-in-constants.

;; RAG - As promised by the comment above, this number had to be
;; changed to get ACL2 to compile.  The number "104" is magical.  I
;; figured it out by compiling ACL2, getting the error message that
;; said *force-xnume* should be "104" but wasn't, and then changed the
;; definition here.  The comment in check-built-in-constants explains
;; why we need to play this (apparently silly) game.

;; RAG - After adding the non-standard predicates, this number grew to 110.

(defconst *force-xnume*
  (let ((x 129))
    #+:non-standard-analysis
    (+ x 12)
    #-:non-standard-analysis
    x))

(defun immediate-force-modep ()

  ":Doc-Section Miscellaneous

  when executable counterpart is ~il[enable]d,
   ~il[force]d hypotheses are attacked immediately~/

  Also ~pl[disable-immediate-force-modep] and
  ~pl[enable-immediate-force-modep].

  This function symbol is defined simply to provide a ~il[rune] which can
  be ~il[enable]d and ~il[disable]d.  Enabling
  ~bv[]
  (:executable-counterpart immediate-force-modep)
  ~ev[]
  causes ACL2 to attack ~il[force]d hypotheses immediately instead of
  delaying them to the next forcing round.
  ~bv[]
  Example Hints
  :in-theory (disable (:executable-counterpart immediate-force-modep))
             ; delay forced hyps to forcing round
  :in-theory (enable (:executable-counterpart immediate-force-modep))
             ; split on forced hyps immediately~/
  ~ev[]
  ~l[force] for background information.  When a ~ilc[force]d
  hypothesis cannot be established a record is made of that fact and
  the proof continues.  When the proof succeeds a ``forcing round'' is
  undertaken in which the system attempts to prove each of the ~il[force]d
  hypotheses explicitly.  However, if the ~il[rune]
  ~c[(:executable-counterpart immediate-force-modep)] is ~il[enable]d at the
  time the hypothesis is ~il[force]d, then ACL2 does not delay the attempt
  to prove that hypothesis but undertakes the attempt more or less
  immediately."

; We make this function :common-lisp-compliant so that it gets a nume on pass 1
; of initialization.  See the comment in check-built-in-constants.

  (declare (xargs :mode :logic :guard t))

  "See :DOC immediate-force-modep.")

; See the comment in check-built-in-constants.

;; RAG - The value of "107" was modified as suggested during the
;; compilation of ACL2.  It's magic.  See the comment in
;; check-built-in-constants to find out more.

;; RAG - After adding the non-standard predicates, this changed to 113.

(defconst *immediate-force-modep-xnume*
  (+ *force-xnume* 3))

(defun case-split (x)

  ":Doc-Section Miscellaneous

  like force but immediately splits the top-level goal on the hypothesis~/

  ~c[Case-split] is an variant of ~ilc[force], which has similar special
  treatment in hypotheses of rules for the same ~il[rule-classes] as for
  ~c[force] (~pl[force]).  This treatment takes place for rule classes
  ~c[:]~ilc[rewrite], ~c[:]~ilc[linear], ~c[:]~ilc[type-prescription],
  ~c[:]~ilc[definition], ~c[:]~ilc[meta] (actually in that case, the result of
  evaluating the hypothesis metafunction call), and
  ~c[:]~ilc[forward-chaining].

  When a hypothesis of a conditional rule (of one of the classes listed above)
  has the form ~c[(case-split hyp)] it is logically equivalent to ~c[hyp].
  However it affects the application of the rule generated as follows: if ACL2
  attempts to apply the rule but cannot establish that the required instance of
  ~c[hyp] holds in the current context, it considers the hypothesis true
  anyhow, but (assuming all hypotheses are seen to be true and the rule is
  applied) creates a subgoal in which that instance of ~c[hyp] is assumed
  false.  (There are exceptions, noted below.)~/

  For example, given the rule
  ~bv[]
  (defthm p1->p2
    (implies (case-split (p1 x))
             (p2 x)))
  ~ev[]
  then an attempt to prove
  ~bv[]
  (implies (p3 x) (p2 (car x)))
  ~ev[]
  can give rise to a single subgoal:
  ~bv[]
  (IMPLIES (AND (NOT (P1 (CAR X))) (P3 X))
           (P2 (CAR X))).
  ~ev[]
  Unlike ~ilc[force], ~c[case-split] does not delay the ``false case'' to a
  forcing round but tackles it more or less immediately.

  The special ``split'' treatment of ~c[case-split] can be disabled by
  disabling forcing: ~pl[force] for a discussion of disabling forcing, and also
  ~pl[disable-forcing].  Finally, we should mention that the rewriter is never
  willing to split when there is an ~ilc[if] term present in the goal being
  simplified.  Since ~ilc[and] terms and ~ilc[or] terms are merely
  abbreviations for ~ilc[if] terms, they also prevent splitting.  Note that
  ~ilc[if] terms are ultimately eliminated using the ordinary flow of the proof
  (but ~pl[set-case-split-limitations]), so ~c[case-split] will ultimately
  function as intended.

  When in the proof checker, ~c[case-split] behaves like ~c[force].~/"

; We define this function in :logic mode on the first pass so that it gets a
; nume.  See the comment in check-built-in-constants.

  (declare (xargs :mode :logic :guard t))

  x)

(in-theory (disable (:executable-counterpart immediate-force-modep)))

(defmacro disable-forcing nil

  ":Doc-Section Miscellaneous

  to disallow ~ilc[force]d ~ilc[case-split]s~/
  ~bv[]
  General Form:
  ACL2 !>:disable-forcing   ; disallow forced case splits
  ~ev[]
  ~l[force] and ~pl[case-split] for a discussion of forced case splits,
  which are inhibited by this command.~/

  ~c[Disable-forcing] is actually a macro that ~il[disable]s the executable
  counterpart of the function symbol ~c[force]; ~pl[force].  When you want to
  use ~il[hints] to turn off forced case splits, use a form such as one of the
  following (these are equivalent).
  ~bv[]
  :in-theory (disable (:executable-counterpart force))
  :in-theory (disable (force))
  ~ev[]
  "
  '(in-theory (disable (:executable-counterpart force))))

(defmacro enable-forcing nil

  ":Doc-Section Miscellaneous

  to allow ~ilc[force]d ~ilc[case split]s~/
  ~bv[]
  General Form:
  ACL2 !>:enable-forcing    ; allowed forced case splits
  ~ev[]
  ~l[force] and ~pl[case-split] for a discussion of ~il[force]d case splits,
  which are turned back on by this command.  (~l[disable-forcing] for how to
  turn them off.)~/

  ~c[Enable-forcing] is actually a macro that ~il[enable]s the executable
  counterpart of the function symbol ~c[force]; ~pl[force].  When you want to
  use ~il[hints] to turn on forced case splits, use a form such as one of the
  following (these are equivalent).
  ~bv[]
  :in-theory (enable (:executable-counterpart force))
  :in-theory (enable (force))
  ~ev[]
  "

  '(in-theory (enable (:executable-counterpart force))))

(defmacro disable-immediate-force-modep ()

  ":Doc-Section Miscellaneous

  ~il[force]d hypotheses are not attacked immediately~/
  ~bv[]
  General Form:
  ACL2 !>:disable-immediate-force-modep
  ~ev[]
  This event causes ACL2 to delay ~il[force]d hypotheses to the next forcing
  round, rather than attacking them immediately.  ~l[immediate-force-modep].
  Or for more basic information, first ~pl[force] for a discussion of
  ~il[force]d case splits.~/

  Disable-immediate-force-modep is a macro that ~il[disable]s the executable
  counterpart of the function symbol ~ilc[immediate-force-modep].  When you
  want to ~il[disable] this mode in ~il[hints], use a form such as one of the
  following (these are equivalent).
  ~bv[]
  :in-theory (disable (:executable-counterpart immediate-force-modep))
  :in-theory (disable (immediate-force-modep))
  ~ev[]
  "

  '(in-theory (disable (:executable-counterpart immediate-force-modep))))

(defmacro enable-immediate-force-modep ()

  ":Doc-Section Miscellaneous

  ~il[force]d hypotheses are attacked immediately~/
  ~bv[]
  General Form:
  ACL2 !>:enable-immediate-force-modep
  ~ev[]
  This event causes ACL2 to attack ~il[force]d hypotheses immediately
  instead of delaying them to the next forcing round.
  ~l[immediate-force-modep].  Or for more basic information, first
  ~pl[force] for a discussion of ~il[force]d case splits.~/

  Enable-immediate-force-modep is a macro that ~il[enable]s the executable
  counterpart of the function symbol ~ilc[immediate-force-modep].  When you
  want to ~il[enable] this mode in ~il[hints], use a form such as one of the
  following (these are equivalent).
  ~bv[]
  :in-theory (enable (:executable-counterpart immediate-force-modep))
  :in-theory (enable (immediate-force-modep))
  ~ev[]
  "

  '(in-theory (enable (:executable-counterpart immediate-force-modep))))

(defun synp (vars form term)

; Top-level calls of this function in the hypothesis of a linear or
; rewrite rule are given special treatment when relieving the rule's
; hypotheses.  (When the rule class gives such special treatment, it
; is an error to use synp in other than at the top-level.)  The
; special treatment is as follows.  Term is evaluated, binding state
; to the live state and mfc to the current metafunction context, as
; with meta rules.  The result of this evaluation should be either t,
; nil, or an alist binding variables to terms, else we get a hard
; error.  Moreover, if we get an alist then either (1) vars should be
; t, representing the set of all possible vars, and none of the keys
; in the alist should already be bound; or else (2) vars should be of
; the form (var1 ... vark), the keys of alist should all be among the
; vari, and none of vari should already be bound (actually this is
; checked when the rule is submitted) -- otherwise we get a hard
; error.

; As of Version_2.7 there are two macros that expand into calls to synp:

; (syntaxp form) ==>
; `(synp (quote nil) (quote (syntaxp ,form)) (quote (and ,form t)))

; (bind-free form &optional (vars 't)) ==>
;  (if vars
;      `(synp (quote ,vars) (quote (bind-free ,form ,vars)) (quote ,form))
;    `(synp (quote t) (quote (bind-free ,form)) (quote ,form))))

; Warning: This function must be defined to always return t in order
; for our treatment of it (in particular, in translate) to be sound.
; The special treatment referred to above happens within relieve-hyp.

  (declare (xargs :mode :logic :guard t)
           (ignore vars form term))
  t)

(defmacro syntaxp (form)
  (declare (xargs :guard t))
  ":Doc-Section Miscellaneous

  attach a heuristic filter on a rule~/

  A calls of ~c[syntaxp] in the hypothesis of a ~c[:]~ilc[rewrite],
  ~c[:]~ilc[definition], or ~c[:]~ilc[linear] rule is treated specially, as
  described below.  Similar treatment is given to the evaluation of a
  ~c[:]~ilc[meta] rule's hypothesis function call.

  For example, consider the ~c[:]~ilc[rewrite] rule created from the following
  formula.
  ~bv[]
  Example:
  (IMPLIES (SYNTAXP (NOT (AND (CONSP X)
                              (EQ (CAR X) 'NORM))))
           (EQUAL (LXD X)
                  (LXD (NORM X)))).
  ~ev[]
  The ~c[syntaxp] hypothesis in this rule will allow the rule to be applied to
  ~c[(lxd (trn a b))] but will not allow it to be applied to
  ~c[(lxd (norm a))].~/
  ~bv[]
  General Form:
  (SYNTAXP test)
  ~ev[]
  ~c[Syntaxp] always returns ~c[t] and so may be added as a vacuous hypothesis.
  However, when relieving the hypothesis, the test ``inside'' the ~c[syntaxp]
  form is actually treated as a meta-level proposition about the proposed
  instantiation of the rule's variables and that proposition must evaluate to
  true (non-~c[nil]) to ``establish'' the ~c[syntaxp] hypothesis.

  Note that the test of a ~c[syntaxp] hypothesis does not, in general, deal
  with the meaning or semantics or values of the terms, but rather with their
  syntactic forms.  In the example above, the ~c[syntaxp] hypothesis allows the
  rule to be applied to every target of the form ~c[(lxd u)], provided ~c[u] is
  not of the form ~c[(norm v)].  Observe that without this syntactic
  restriction the rule above could loop, producing a sequence of increasingly
  complex targets ~c[(lxd a)], ~c[(lxd (norm a))], ~c[(lxd (norm (norm a)))],
  etc.  An intuitive reading of the rule might be ``~c[norm] the argument of
  ~c[lxd] unless it has already been ~c[norm]ed.''

  Note also that a ~c[syntaxp] hypothesis deals with the syntactic form used
  internally by ACL2, rather than that seen by the user.  In some cases these
  are the same, but there can be subtle differences with which the writer of a
  ~c[syntaxp] hypothesis must be aware.  You can use ~c[:]~ilc[trans] to
  display this internal representation.

  There are two types of ~c[syntaxp] hypotheses.  The simpler type may be a
  hypothesis of a ~c[:]~ilc[rewrite], ~c[:]~ilc[definition], or
  ~c[:]~ilc[linear] rule provided ~c[test] contains at least one variable but
  no free variables (~pl[free-variables]).  In particular, ~c[test] may not use
  ~il[stobj]s; any stobj name will be treated as an ordinary variable.  The
  case of ~c[:]~ilc[meta] rules is similar to the above, except that it applies
  to the result of applying the hypothesis metafunction.  (Later below we will
  describe the second type, an ~em[extended] ~c[syntaxp] hypothesis, which may
  use ~ilc[state].)

  We illustrate the use of simple ~c[syntaxp] hypotheses by slightly
  elaborating the example given above.  Consider a ~c[:]~ilc[rewrite] rule:
  ~bv[]
  (IMPLIES (AND (RATIONALP X)
                (SYNTAXP (NOT (AND (CONSP X)
                                   (EQ (CAR X) 'NORM)))))
           (EQUAL (LXD X)
                  (LXD (NORM X))))
  ~ev[]
  How is this rule applied to ~c[(lxd (trn a b))]?  First, we form a
  substitution that instantiates the left-hand side of the conclusion of the
  rule so that it is identical to the target term.  In the present case, the
  substitution replaces ~c[x] with ~c[(trn a b)].
  ~bv[]
  (LXD X) ==> (LXD (trn a b)).
  ~ev[]
  Then we backchain to establish the hypotheses, in order.  Ordinarily this
  means that we instantiate each hypothesis with our substitution and then
  attempt to rewrite the resulting instance to true.  Thus, in order to relieve
  the first hypothesis above, we rewrite
  ~bv[]
  (RATIONALP (trn a b)).
  ~ev[]
  If this rewrites to true, we continue.

  Of course, many users are aware of some exceptions to this general
  description of the way we relieve hypotheses.  For example, if a hypothesis
  contains a ``free-variable'' ~-[] one not bound by the current substitution
  ~-[] we attempt to extend the substitution by searching for an instance of
  the hypothesis among known truths.  ~l[free-variables].  ~ilc[Force]d
  hypotheses are another exception to the general rule of how hypotheses are
  relieved.

  Hypotheses marked with ~c[syntaxp], as in ~c[(syntaxp test)], are also
  exceptions.  We instantiate such a hypothesis; but instead of rewriting the
  instantiated instance, we evaluate the instantiated ~c[test].  More
  precisely, we evaluate ~c[test] in an environment in which its variable
  symbols are bound to the quotations of the terms to which those variables are
  bound in the instantiating substitution.  So in the case in point, we (in
  essence) evaluate
  ~bv[]
  (NOT (AND (CONSP '(trn a b)) (EQ (CAR '(trn a b)) 'NORM))).
  ~ev[]
  This clearly evaluates to ~c[t].  When a ~c[syntaxp] test evaluates to true,
  we consider the ~c[syntaxp] hypothesis to have been established; this is
  sound because logically ~c[(syntaxp test)] is ~c[t] regardless of ~c[test].
  If the test evaluates to ~c[nil] (or fails to evaluate because of ~il[guard]
  violations) we act as though we cannot establish the hypothesis and abandon
  the attempt to apply the rule; it is always sound to give up.

  The acute reader will have noticed something odd about the form
  ~bv[]
  (NOT (AND (CONSP '(trn a b)) (EQ (CAR '(trn a b)) 'NORM))).
  ~ev[]
  When relieving the first hypothesis, ~c[(RATIONALP X)], we substituted
  ~c[(trn a b)] for ~c[X]; but when relieving the second hypothesis,
  ~c[(SYNTAXP (NOT (AND (CONSP X) (EQ (CAR X) 'NORM))))], we substituted the
  quotation of ~c[(trn a b)] for ~c[X].  Why the difference?  Remember that in
  the first hypothesis we are talking about the value of ~c[(trn a b)] ~-[] is
  it rational ~-[] while in the second one we are talking about its syntactic
  form.  Remember also that Lisp, and hence ACL2, evaluates the arguments to a
  function before applying the function to the resulting values. Thus, we are
  asking ``Is the list ~c[(trn a b)] a ~ilc[consp] and if so, is its ~ilc[car]
  the symbol ~c[NORM]?''  The ~c[quote]s on both ~c[(trn a b)] and ~c[NORM] are
  therefore necessary.  One can verify this by defining ~c[trn] to be, say
  ~ilc[cons], and then evaluating forms such as
  ~bv[]
  (AND (CONSP '(trn a b)) (EQ (CAR '(trn a b)) 'NORM))
  (AND (CONSP (trn a b)) (EQ (CAR (trn a b)) NORM))
  (AND (CONSP (trn 'a 'b)) (EQ (CAR (trn 'a 'b)) NORM))
  (AND (CONSP '(trn a b)) (EQ '(CAR (trn a b)) ''NORM))
  ~ev[]
  at the top-level ACL2 prompt.

  ~l[syntaxp-examples] for more examples of the use of ~c[syntaxp].

  An extended ~c[syntaxp] hypothesis is similar to the simple type described
  above, but it uses two additional variables, ~c[mfc] and ~c[state], which
  must not be bound by the left hand side or an earlier hypothesis of the rule.
  They must be the last two variables mentioned by ~c[form]; first ~c[mfc],
  then ~c[state].  These two variables give access to the functions
  ~c[mfc-]xxx; ~pl[extended-metafunctions].  As described there, ~c[mfc] is
  bound to the so-called metafunction-context and ~c[state] to ACL2's
  ~ilc[state].  ~l[syntaxp-examples] for an example of the use of these
  extended ~c[syntaxp] hypotheses.

  We conclude with an example illustrating an error that may occur if you
  forget that a ~c[syntaxp] hypothesis will be evaluated in an environment
  where variables are bound to syntactic terms, not to values.  Consider the
  following ~il[stobj] introduction (~pl[defstobj]).
  ~bv[]
    (defstobj st
      (fld1 :type (signed-byte 3) :initially 0)
      fld2)
  ~ev[]
  The following ~c[syntaxp] hypothesis is ill-formed for evaluation.  Indeed,
  ACL2 causes an error because it anticipates that when trying to relieve the
  ~c[syntaxp] hypothesis of this rule, ACL2 would be evaluating ~c[(fld1 st)]
  where ~c[st] is bound to a term, not to an actual ~c[stobj] as required by
  the function ~c[fld1].  The error message is intended to explain this
  problem.
  ~bv[]
    ACL2 !>(defthm bad
             (implies (syntaxp (quotep (fld1 st)))
                      (equal (stp st)
                             (and (true-listp st)
                                  (equal (len st) 2)
                                  (fld1p (car st))))))


    ACL2 Error in ( DEFTHM BAD ...):  The form (QUOTEP (FLD1 ST)), from
    a SYNTAXP hypothesis, is not suitable for evaluation in an environment
    where its variables are bound to terms.  See :DOC SYNTAXP.  Here is
    further explanation:
         The form ST is being used, as an argument to a call of FLD1, where
    the single-threaded object of that name is required.  But in the current
    context, the only declared stobj name is STATE.  Note:  this error
    occurred in the context (FLD1 ST).


    Summary
    Form:  ( DEFTHM BAD ...)
    Rules: NIL
    Time:  0.00 seconds (prove: 0.00, print: 0.00, other: 0.00)

    ACL2 Error in ( DEFTHM BAD ...):  See :DOC failure.

    ******** FAILED ********
    ACL2 !>
  ~ev[]
  Presumably the intention was to rewrite the term ~c[(stp st)] when the
  ~c[fld1] component of ~c[st] is seen to be an explicit constant.  As
  explained elsewhere (~pl[free-variables]), we can obtain the result of
  rewriting ~c[(fld1 st)] by binding a fresh variable to that term using
  ~c[EQUAL], as follows.
  ~bv[]
    (defthm good
      (implies (and (equal f (fld1 st))
                    (syntaxp (quotep f)))
               (equal (stp st)
                      (and (true-listp st)
                           (equal (len st) 2)
                           (fld1p (car st))))))
  ~ev[]
  The event above is admitted by ACL2.  We can see it in action by disabling
  the definition of ~c[stp] so that only the rule above, ~c[good], is available
  for reasoning about ~c[stp].
  ~bv[]
    (in-theory (disable stp))
  ~ev[]
  Then the proof fails for the following, because the ~c[syntaxp] hypothesis of
  the rule, ~c[good], fails: ~c[(quotep f)] evaluates to ~c[nil] when ~c[f] is
  bound to the term ~c[(fld1 st)].
  ~bv[]
    (thm (stp st))
  ~ev[]
  However, the proof succeeds for the next form, as we explain below.
  ~bv[]
    (thm (stp (list 3 rest)))
  ~ev[]
  Consider what happens in that case when rule ~c[good] is applied to the term
  ~c[(stp (list 3 rest))].  (~l[free-variables] for relevant background.)  The
  first hypothesis of ~c[good] binds the variable ~c[f] to the result of
  rewriting ~c[(fld1 st)], where ~c[st] is bound to the (internal form of) the
  term ~c[(list 3 rest)] ~-[] and that result is clearly the term, ~c['3].
  Then the ~c[syntaxp] hypothesis is successfully relieved, because the
  evaluation of ~c[(quotep f)] returns ~c[t] in the environment that binds
  ~c[f] to ~c['3]."

  `(synp (quote nil) (quote (syntaxp ,form)) (quote (and ,form t))))

(deflabel syntaxp-examples

  :doc
  ":Doc-Section Syntaxp

  examples pertaining to syntaxp hypotheses~/

  ~l[syntaxp] for a basic discussion of the use of ~c[syntaxp] to control
  rewriting.~/

  A common syntactic restriction is
  ~bv[]
  (SYNTAXP (AND (CONSP X) (EQ (CAR X) 'QUOTE)))
  ~ev[]
  or, equivalently,
  ~bv[]
  (SYNTAXP (QUOTEP X)).
  ~ev[]
  A rule with such a hypothesis can be applied only if ~c[x] is bound to
  a specific constant.  Thus, if ~c[x] is ~c[23] (which is actually
  represented internally as ~c[(quote 23)]), the test evaluates to ~c[t]; but
  if ~c[x] prints as ~c[(+ 11 12)] then the test evaluates to ~c[nil]
  (because ~c[(car x)] is the symbol ~ilc[binary-+]).  We see the use
  of this restriction in the rule
  ~bv[]
  (implies (and (syntaxp (quotep c))
                (syntaxp (quotep d)))
           (equal (+ c d x)
                  (+ (+ c d) x))).
  ~ev[]
  If ~c[c] and ~c[d] are constants, then the
  ~ilc[executable-counterpart] of ~ilc[binary-+] will evaluate the sum
  of ~c[c] and ~c[d].  For instance, under the influence of this rule
  ~bv[]
  (+ 11 12 foo)
  ~ev[]
  rewrites to
  ~bv[]
  (+ (+ 11 12) foo)
  ~ev[]
  which in turn rewrites to ~c[(+ 23 foo)].  Without the syntactic
  restriction, this rule would loop with the built-in rules
  ~c[ASSOCIATIVITY-OF-+] or ~c[COMMUTATIVITY-OF-+].

  We here recommend that the reader try the affects of entering expressions
  such as the following at the top level ACL2 prompt.
  ~bv[]
  (+ 11 23)
  (+ '11 23)
  (+ '11 '23)
  (+ ''11 ''23)
  :trans (+ 11 23)
  :trans (+ '11 23)
  :trans (+ ''11 23)
  :trans (+ c d x)
  :trans (+ (+ c d) x)
  ~ev[]
  We also recommend that the reader verify our claim above about looping
  by trying the affect of each of the following rules individually.
  ~bv[]
  (defthm good
     (implies (and (syntaxp (quotep c))
                   (syntaxp (quotep d)))
              (equal (+ c d x)
                     (+ (+ c d) x))))

  (defthm bad
     (implies (and (acl2-numberp c)
                   (acl2-numberp d))
              (equal (+ c d x)
                     (+ (+ c d) x))))
  ~ev[]
  on (the false) theorems:
  ~bv[]
  (thm
    (equal (+ 11 12 x) y))

  (thm
    (implies (and (acl2-numberp c)
                  (acl2-numberp d)
                  (acl2-numberp x))
             (equal (+ c d x) y))).
  ~ev[]
  One can use ~c[:]~ilc[brr], perhaps in conjunction with
  ~ilc[cw-gstack], to investigate any looping.

  Here is a simple example showing the value of rule ~c[good] above.  Without
  ~c[good], the ~c[thm] form below fails.
  ~bv[]
  (defstub foo (x) t)

  (thm (equal (foo (+ 3 4 x)) (foo (+ 7 x))))
  ~ev[]

  The next three examples further explore the use of ~c[quote] in
  ~ilc[syntaxp] hypotheses.

  We continue the examples of ~ilc[syntaxp] hypotheses with a rule from
  community book ~c[books/finite-set-theory/set-theory.lisp].  We will not
  discuss here the meaning of this rule, but it is necessary to point out that
  ~c[(ur-elementp nil)] is true in this book.
  ~bv[]
  (defthm scons-nil
    (implies (and (syntaxp (not (equal a ''nil)))
                  (ur-elementp a))
             (= (scons e a)
                (scons e nil)))).
  ~ev[]
  Here also, ~ilc[syntaxp] is used to prevent looping.  Without the
  restriction, ~c[(scons e nil)] would be rewritten to itself since
  ~c[(ur-elementp nil)] is true.~nl[]
  Question: Why the use of two quotes in ~c[''nil]?~nl[]
  Hints: ~c[Nil] is a constant just as 23 is.  Try ~c[:trans (cons a nil)],
  ~c[:trans (cons 'a 'nil)], and ~c[:trans (cons ''a ''nil)].
  Also, don't forget that the arguments to a function are evaluated before
  the function is applied.

  The next two rules move negative constants to the other side of an
  inequality.
  ~bv[]
  (defthm |(< (+ (- c) x) y)|
    (implies (and (syntaxp (quotep c))
                  (syntaxp (< (cadr c) 0))
                  (acl2-numberp y))
             (equal (< (+ c x) y)
                    (< (fix x) (+ (- c) y)))))

  (defthm |(< y (+ (- c) x))|
    (implies (and (syntaxp (quotep c))
                  (syntaxp (< (cadr c) 0))
                  (acl2-numberp y))
             (equal (< y (+ c x))
                    (< (+ (- c) y) (fix x)))))
  ~ev[]
  Questions: What would happen if ~c[(< (cadr c) '0)] were used?
  What about ~c[(< (cadr c) ''0)]?

  One can also use ~c[syntaxp] to restrict the application of a rule
  to a particular set of variable bindings as in the following taken from
  community book ~c[books/ihs/quotient-remainder-lemmas.lisp].
  ~bv[]
  (encapsulate ()

    (local
     (defthm floor-+-crock
       (implies
        (and (real/rationalp x)
             (real/rationalp y)
             (real/rationalp z)
             (syntaxp (and (eq x 'x) (eq y 'y) (eq z 'z))))
        (equal (floor (+ x y) z)
               (floor (+ (+ (mod x z) (mod y z))
                         (* (+ (floor x z) (floor y z)) z)) z)))))

    (defthm floor-+
      (implies
       (and (force (real/rationalp x))
            (force (real/rationalp y))
            (force (real/rationalp z))
            (force (not (equal z 0))))
       (equal (floor (+ x y) z)
              (+ (floor (+ (mod x z) (mod y z)) z)
                 (+ (floor x z) (floor y z))))))

    )
  ~ev[]
  We recommend the use of ~c[:]~c[brr] to investigate the use of
  ~c[floor-+-crock].

  Another useful restriction is defined by
  ~bv[]
  (defun rewriting-goal-literal (x mfc state)

    ;; Are we rewriting a top-level goal literal, rather than rewriting
    ;; to establish a hypothesis from a rewrite (or other) rule?

    (declare (ignore x state))
    (null (access metafunction-context mfc :ancestors))).
  ~ev[]
  We use this restriction in the rule
  ~bv[]
  (defthm |(< (* x y) 0)|
      (implies (and (syntaxp (rewriting-goal-literal x mfc state))
                    (rationalp x)
                    (rationalp y))
               (equal (< (* x y) 0)
                      (cond ((equal x 0)
                             nil)
                            ((equal y 0)
                             nil)
                            ((< x 0)
                             (< 0 y))
                            ((< 0 x)
                             (< y 0))))))
  ~ev[]
  which has been found to be useful, but which also leads to excessive
  thrashing in the linear arithmetic package if used indiscriminately.

  ~l[extended-metafunctions] for information on the use of ~c[mfc]
  and ~c[metafunction-context].

  ~/")

(defmacro bind-free (form &optional (vars))
  (declare (xargs :guard (or (eq vars nil)
                             (eq vars t)
                             (and (symbol-listp vars)
                                  (not (member-eq t vars))
                                  (not (member-eq nil vars))))))
  ":Doc-Section Miscellaneous

  to bind free variables of a rewrite, definition, or linear rule~/
  ~bv[]
  Examples:
  (IMPLIES (AND (RATIONALP LHS)
                (RATIONALP RHS)
                (BIND-FREE (FIND-MATCH-IN-PLUS-NESTS LHS RHS) (X)))
           (EQUAL (EQUAL LHS RHS)
                  (EQUAL (+ (- X) LHS) (+ (- X) RHS))))

  (IMPLIES (AND (BIND-FREE
                  (FIND-RATIONAL-MATCH-IN-TIMES-NESTS LHS RHS MFC STATE)
                  (X))
                (RATIONALP X)
                (CASE-SPLIT (NOT (EQUAL X 0))))
           (EQUAL (< LHS RHS)
                  (IF (< 0 X)
                      (< (* (/ X) LHS) (* (/ X) RHS))
                     (< (* (/ X) RHS) (* (/ X) LHS)))))
  ~ev[]~/
  General Forms:
  ~bv[]
  (BIND-FREE term var-list)
  (BIND-FREE term t)
  (BIND-FREE term)
  ~ev[]
  A rule which uses a ~c[bind-free] hypothesis has similarities to both a rule
  which uses a ~ilc[syntaxp] hypothesis and to a ~c[:]~ilc[meta] rule.
  ~c[Bind-free] is like ~ilc[syntaxp], in that it logically always returns
  ~c[t] but may affect the application of a ~c[:]~ilc[rewrite],
  ~c[:]~ilc[definition], or ~c[:]~ilc[linear] rule when it is called at the
  top-level of a hypothesis.  It is like a ~c[:]~ilc[meta] rule, in that it
  allows the user to perform transformations of terms under progammatic
  control.

  Note that a ~c[bind-free] hypothesis does not, in general, deal with the
  meaning or semantics or values of the terms, but rather with their syntactic
  forms.  Before attempting to write a rule which uses ~c[bind-free], the user
  should be familiar with ~ilc[syntaxp] and the internal form that ACL2 uses
  for terms.  This internal form is similar to what the user sees, but there
  are subtle and important differences.  ~ilc[Trans] can be used to view this
  internal form.

  Just as for a ~ilc[syntaxp] hypothesis, there are two basic types of
  ~c[bind-free] hypotheses.  The simpler type of ~c[bind-free] hypothesis may
  be used as the nth hypothesis in a ~c[:]~ilc[rewrite], ~c[:]~ilc[definition],
  or ~c[:]~ilc[linear] rule whose ~c[:]~ilc[corollary] is
  ~c[(implies (and hyp1 ... hypn ... hypk) (equiv lhs rhs))] provided ~c[term]
  is a term, ~c[term] contains at least one variable, and every variable
  occuring freely in ~c[term] occurs freely in ~c[lhs] or in some ~c[hypi],
  ~c[i<n].  In addition, ~c[term] must not use any stobjs.  Later below we will
  describe the second type, an ~em[extended] ~c[bind-free] hypothesis, which
  may use ~ilc[state].  Whether simple or extended, a ~c[bind-free] hypothesis
  may return an alist that binds free variables, as explained below, or it may
  return a list of such alists.  We focus on the first of these cases: return
  of a single binding alist.  We conclude our discussion with a section that
  covers the other case: return of a list of alists.

  We begin our description of ~c[bind-free] by examining the first example
  above in some detail.

  We wish to write a rule which will cancel ``like'' addends from both sides of
  an equality.  Clearly, one could write a series of rules such as
  ~bv[]
  (DEFTHM THE-HARD-WAY-2-1
     (EQUAL (EQUAL (+ A X B)
                   (+ X C))
            (EQUAL (+ A B)
                   (FIX C))))
  ~ev[]

  with one rule for each combination of positions the matching addends might be
  found in (if one knew before-hand the maximum number of addends that would
  appear in a sum).  But there is a better way.  (In what follows, we assume
  the presence of an appropriate set of rules for simplifying sums.)

  Consider the following definitions and theorem:
  ~bv[]
  (DEFUN INTERSECTION-EQUAL (X Y)
    (COND ((ENDP X)
           NIL)
          ((MEMBER-EQUAL (CAR X) Y)
           (CONS (CAR X) (INTERSECTION-EQUAL (CDR X) Y)))
          (T
           (INTERSECTION-EQUAL (CDR X) Y))))

  (DEFUN PLUS-LEAVES (TERM)
    (IF (EQ (FN-SYMB TERM) 'BINARY-+)
        (CONS (FARGN TERM 1)
              (PLUS-LEAVES (FARGN TERM 2)))
      (LIST TERM)))

  (DEFUN FIND-MATCH-IN-PLUS-NESTS (LHS RHS)
    (IF (AND (EQ (FN-SYMB LHS) 'BINARY-+)
             (EQ (FN-SYMB RHS) 'BINARY-+))
        (LET ((COMMON-ADDENDS (INTERSECTION-EQUAL (PLUS-LEAVES LHS)
                                                  (PLUS-LEAVES RHS))))
          (IF COMMON-ADDENDS
              (LIST (CONS 'X (CAR COMMON-ADDENDS)))
            NIL))
      NIL))

  (DEFTHM CANCEL-MATCHING-ADDENDS-EQUAL
    (IMPLIES (AND (RATIONALP LHS)
                  (RATIONALP RHS)
                  (BIND-FREE (FIND-MATCH-IN-PLUS-NESTS LHS RHS) (X)))
             (EQUAL (EQUAL LHS RHS)
                    (EQUAL (+ (- X) LHS) (+ (- X) RHS)))))
  ~ev[]

  How is this rule applied to the following term?
  ~bv[]
  (equal (+ 3 (expt a n) (foo a c))
         (+ (bar b) (expt a n)))
  ~ev[]
  As mentioned above, the internal form of an ACL2 term is not always what one
  sees printed out by ACL2.  In this case, by using ~c[:]~ilc[trans] one can
  see that the term is stored internally as
  ~bv[]
  (equal (binary-+ '3
                   (binary-+ (expt a n) (foo a c)))
         (binary-+ (bar b) (expt a n))).
  ~ev[]

  When ACL2 attempts to apply ~c[cancel-matching-addends-equal] to the term
  under discussion, it first forms a substitution that instantiates the
  left-hand side of the conclusion so that it is identical to the target term.
  This substitution is kept track of by the substitution alist:
  ~bv[]
  ((LHS . (binary-+ '3
                     (binary-+ (expt a n) (foo a c))))
   (RHS . (binary-+ (bar b) (expt a n)))).
  ~ev[]
  ACL2 then attempts to relieve the hypotheses in the order they were
  given.  Ordinarily this means that we instantiate each hypothesis with our
  substitution and then attempt to rewrite the resulting instance to true.
  Thus, in order to relieve the first hypothesis, we rewrite:
  ~bv[]
  (RATIONALP (binary-+ '3
                        (binary-+ (expt a n) (foo a c)))).
  ~ev[]
  Let us assume that the first two hypotheses rewrite to ~c[t].  How do we
  relieve the ~c[bind-free] hypothesis?  Just as for a ~ilc[syntaxp]
  hypothesis, ACL2 evaluates ~c[(find-match-in-plus-nests lhs rhs)] in an
  environment where ~c[lhs] and ~c[rhs] are instantiated as determined by the
  substitution.  In this case we evaluate
  ~bv[]
  (FIND-MATCH-IN-PLUS-NESTS '(binary-+ '3
                                        (binary-+ (expt a n) (foo a c)))
                            '(binary-+ (bar b) (expt a n))).
  ~ev[]
  Observe that, just as in the case of a ~ilc[syntaxp] hypothesis, we
  substitute the quotation of the variables bindings into the term to be
  evaluated.  ~l[syntaxp] for the reasons for this.  The result of this
  evaluation, ~c[((X . (EXPT A N)))], is then used to extend the substitution
  alist:
  ~bv[]
  ((X . (EXPT A N))
   (LHS . (binary-+ '3
                     (binary-+ (expt a n) (foo a c))))
   (RHS . (binary-+ (bar b) (expt a n)))),
  ~ev[]
  and this extended substitution determines ~c[cancel-matching-addends-equal]'s
  result:
  ~bv[]
  (EQUAL (+ (- X) LHS) (+ (- X) RHS))
  ==>
  (EQUAL (+ (- (EXPT A N)) 3 (EXPT A N) (FOO A C))
         (+ (- (EXPT A N)) (BAR B) (EXPT A N))).
  ~ev[]
  Question: What is the internal form of this result?~nl[]
  Hint: Use ~c[:]~ilc[trans].

  When this rule fires, it adds the negation of a common term to both sides of
  the equality by selecting a binding for the otherwise-free variable ~c[x],
  under programmatic control.  Note that other mechanisms such as the binding
  of ~il[free-variables] may also extend the substitution alist.

  Just as for a ~ilc[syntaxp] test, a ~c[bind-free] form signals failure by
  returning ~c[nil].  However, while a ~ilc[syntaxp] test signals success by
  returning true, a ~c[bind-free] form signals success by returning an alist
  which is used to extend the current substitution alist.  Because of this use
  of the alist, there are several restrictions on it ~-[] in particular the
  alist must only bind variables, these variables must not be already bound by
  the substitution alist, and the variables must be bound to ACL2 terms.  If
  ~c[term] returns an alist and the alist meets these restrictions, we append
  the alist to the substitution alist and use the result as the new current
  substitution alist.  This new current substitution alist is then used when we
  attempt to relieve the next hypothesis or, if there are no more, instantiate
  the right hand side of the rule.

  There is also a second, optional, ~c[var-list] argument to a ~c[bind-free]
  hypothesis.  If provided, it must be either ~c[t] or a list of variables.  If
  it is not provided, it defaults to ~c[t].  If it is a list of variables, this
  second argument is used to place a further restriction on the possible values
  of the alist to be returned by ~c[term]: any variables bound in the alist
  must be present in the list of variables.  We strongly recommend the use of
  this list of variables, as it allows some consistency checks to be performed
  at the time of the rule's admittance which are not possible otherwise.

  An extended ~c[bind-free] hypothesis is similar to the simple type described
  above, but it uses two additional variables, ~c[mfc] and ~c[state], which
  must not be bound by the left hand side or an earlier hypothesis of the rule.
  They must be the last two variables mentioned by ~c[term]: first ~c[mfc],
  then ~c[state].  These two variables give access to the functions
  ~c[mfc-]xxx; ~pl[extended-metafunctions].  As described there, ~c[mfc] is
  bound to the so-called metafunction-context and ~c[state] to ACL2's
  ~ilc[state].  ~l[bind-free-examples] for examples of the use of these
  extended ~c[bind-free] hypotheses.

  ~st[SECTION]: Returning a list of alists.

  As promised above, we conclude with a discussion of the case that evaluation
  of the ~c[bind-free] term produces a list of alists, ~c[x], rather than a
  single alist.  In this case each member ~c[b] of ~c[x] is considered in turn,
  starting with the first and proceeding through the list.  Each such ~c[b] is
  handled exactly as discussed above, as though it were the result of
  evaluating the ~c[bind-free] term.  Thus, each ~c[b] extends the current
  variable binding alist, and all remaining hypotheses are then relieved, as
  though ~c[b] had been the value obtained by evaluating the ~c[bind-free]
  term.  As soon as one such ~c[b] leads to successful relieving of all
  remaining hypotheses, the process of relieving hypotheses concludes, so no
  further members of ~c[x] are considered.

  We illustrate with a simple pedagogical example.  First introduce functions
  ~c[p1] and ~c[p2] such that a rewrite rule specifies that ~c[p2] implies
  ~c[p1], but with a free variable.
  ~bv[]

  (defstub p1 (x) t)
  (defstub p2 (x y) t)

  (defaxiom p2-implies-p1
    (implies (p2 x y)
             (p1 x)))

  ~ev[]
  If we add the following axiom, then ~c[(p1 x)] follows logically for all
  ~c[x].
  ~bv[]

  (defaxiom p2-instance
    (p2 v (cons v 4)))

  ~ev[]
  Unfortunately, evaluation of ~c[(thm (p1 a))] fails, because ACL2 fails to
  bind the free variable ~c[y] in order to apply the rule ~c[p2-instance].

  Let's define a function that produces a list of alists, each binding the
  variable ~c[y].  Of course, we know that only the middle one below is
  necessary in this simple example.  In more complex examples, one might use
  heuristics to construct such a list of alists.
  ~bv[]

  (defun my-alists (x)
    (list (list (cons 'y (fcons-term* 'cons x ''3)))
          (list (cons 'y (fcons-term* 'cons x ''4)))
          (list (cons 'y (fcons-term* 'cons x ''5)))))

  ~ev[]
  The following rewrite rule uses ~c[bind-free] to return a list of candidate
  alists binding ~c[y].
  ~bv[]

  (defthm p2-implies-p1-better
    (implies (and (bind-free (my-alists x)
                             (y)) ; the second argument, (y), is optional
                  (p2 x y))
             (p1 x)))

  ~ev[]
  Now the proof succeeds for ~c[(thm (p1 a))].  Why?  When ACL2 applies the
  ~c[rewrite] rule ~c[p2-implies-p1-better], it evaluates ~c[my-alists], as we
  can see from the following ~il[trace], to bind ~c[y] in three different
  alists.
  ~bv[]

  ACL2 !>(thm (p1 a))
  1> (ACL2_*1*_ACL2::MY-ALISTS A)
  <1 (ACL2_*1*_ACL2::MY-ALISTS (((Y CONS A '3))
                                ((Y CONS A '4))
                                ((Y CONS A '5))))

  Q.E.D.

  ~ev[]
  The first alist, binding ~c[y] to ~c[(cons a '3)], fails to allow the
  hypothesis ~c[(p2 x y)] to be proved.  But the next binding of ~c[y], to
  ~c[(cons a '4)], succeeds: then the current binding alist is
  ~c[((x . a) (y . (cons a '4)))], for which the hypothesis ~c[(p2 x y)]
  rewrites to true using the rewrite rule ~c[p2-instance].~/"

  (if vars
      `(synp (quote ,vars) (quote (bind-free ,form ,vars)) (quote ,form))
    `(synp (quote t) (quote (bind-free ,form)) (quote ,form))))

(deflabel bind-free-examples

  :doc
  ":Doc-Section Bind-free

  examples pertaining to ~ilc[bind-free] hypotheses~/

  ~l[bind-free] for a basic discussion of the use of ~c[bind-free] to control
  rewriting.

  Note that the examples below all illustrate the common case in which a
  ~c[bind-free] hypothesis generates a binding alist.  ~l[bind-free], in
  particular the final section, for a discussion of the case that instead a
  list of binding alists is generated.~/

  We give examples of the use of ~ilc[bind-free] hypotheses from the
  perspective of a user interested in reasoning about arithmetic, but
  it should be clear that ~ilc[bind-free] can be used for many other
  purposes also.

  EXAMPLE 1:  Cancel a common factor.

  ~bv[]
  (defun bind-divisor (a b)

  ; If a and b are polynomials with a common factor c, we return a
  ; binding for x.  We could imagine writing get-factor to compute the
  ; gcd, or simply to return a single non-invertible factor.

    (let ((c (get-factor a b)))
      (and c (list (cons 'x c)))))

  (defthm cancel-factor
    ;; We use case-split here to ensure that, once we have selected
    ;; a binding for x, the rest of the hypotheses will be relieved.
    (implies (and (acl2-numberp a)
                  (acl2-numberp b)
                  (bind-free (bind-divisor a b) (x))
                  (case-split (not (equal x 0)))
                  (case-split (acl2-numberp x)))
             (iff (equal a b)
                  (equal (/ a x) (/ b x)))))
  ~ev[]

  EXAMPLE 2:  Pull integer summand out of floor.  Note:  This example
  has an ~em[extended] ~ilc[bind-free] hypothesis, which uses the term
  ~c[(find-int-in-sum sum mfc state)].

  ~bv[]
  (defun fl (x)
    ;; This function is defined, and used, in the IHS books.
    (floor x 1))

  (defun int-binding (term mfc state)
    ;; The call to mfc-ts returns the encoded type of term. ;
    ;; Thus, we are asking if term is known by type reasoning to ;
    ;; be an integer. ;
    (declare (xargs :stobjs (state) :mode :program))
    (if (ts-subsetp (mfc-ts term mfc state)
                    *ts-integer*)
        (list (cons 'int term))
      nil))

  (defun find-int-in-sum (sum mfc state)
    (declare (xargs :stobjs (state) :mode :program))
    (if (and (nvariablep sum)
             (not (fquotep sum))
             (eq (ffn-symb sum) 'binary-+))
        (or (int-binding (fargn sum 1) mfc state)
            (find-int-in-sum (fargn sum 2) mfc state))
      (int-binding sum mfc state)))

  ; Some additional work is required to prove the following.  So for
  ; purposes of illustration, we wrap skip-proofs around the defthm.

  (skip-proofs
   (defthm cancel-fl-int
    ;; The use of case-split is probably not needed, since we should
    ;; know that int is an integer by the way we selected it.  But this
    ;; is safer.
     (implies (and (acl2-numberp sum)
                   (bind-free (find-int-in-sum sum mfc state) (int))
                   (case-split (integerp int)))
              (equal (fl sum)
                     (+ int (fl (- sum int)))))
     :rule-classes ((:rewrite :match-free :all)))
  )

  ; Arithmetic libraries will have this sort of lemma.
  (defthm hack (equal (+ (- x) x y) (fix y)))

  (in-theory (disable fl))

  (thm (implies (and (integerp x) (acl2-numberp y))
                (equal (fl (+ x y)) (+ x (fl y)))))

  ~ev[]

  EXAMPLE 3:  Simplify terms such as (equal (+ a (* a b)) 0)

  ~bv[]
  (defun factors (product)
    ;; We return a list of all the factors of product.  We do not
    ;; require that product actually be a product.
    (if (eq (fn-symb product) 'BINARY-*)
        (cons (fargn product 1)
              (factors (fargn product 2)))
      (list product)))

  (defun make-product (factors)
    ;; Factors is assumed to be a list of ACL2 terms.  We return an
    ;; ACL2 term which is the product of all the ellements of the
    ;; list factors.
    (cond ((atom factors)
           ''1)
          ((null (cdr factors))
           (car factors))
          ((null (cddr factors))
           (list 'BINARY-* (car factors) (cadr factors)))
          (t
           (list 'BINARY-* (car factors) (make-product (cdr factors))))))

  (defun quotient (common-factors sum)
    ;; Common-factors is a list of ACL2 terms.   Sum is an ACL2 term each
    ;; of whose addends have common-factors as factors.  We return
    ;; (/ sum (make-product common-factors)).
    (if (eq (fn-symb sum) 'BINARY-+)
        (let ((first (make-product (set-difference-equal (factors (fargn sum 1))
                                                         common-factors))))
          (list 'BINARY-+ first (quotient common-factors (fargn sum 2))))
      (make-product (set-difference-equal (factors sum)
                                          common-factors))))

  (defun intersection-equal (x y)
    (cond ((endp x)
           nil)
          ((member-equal (car x) y)
           (cons (car x) (intersection-equal (cdr x) y)))
          (t
           (intersection-equal (cdr x) y))))

  (defun common-factors (factors sum)
    ;; Factors is a list of the factors common to all of the addends
    ;; examined so far.  On entry, factors is a list of the factors in
    ;; the first addend of the original sum, and sum is the rest of the
    ;; addends.  We sweep through sum, trying to find a set of factors
    ;; common to all the addends of sum.
    (declare (xargs :measure (acl2-count sum)))
    (cond ((null factors)
           nil)
          ((eq (fn-symb sum) 'BINARY-+)
           (common-factors (intersection-equal factors (factors (fargn sum 1)))
                           (fargn sum 2)))
          (t
           (intersection-equal factors (factors sum)))))

  (defun simplify-terms-such-as-a+ab-rel-0-fn (sum)
    ;; If we can find a set of factors common to all the addends of sum,
    ;; we return an alist binding common to the product of these common
    ;; factors and binding quotient to (/ sum common).
    (if (eq (fn-symb sum) 'BINARY-+)
        (let ((common-factors (common-factors (factors (fargn sum 1))
                                              (fargn sum 2))))
          (if common-factors
              (let ((common (make-product common-factors))
                    (quotient (quotient common-factors sum)))
                (list (cons 'common common)
                      (cons 'quotient quotient)))
            nil))
      nil))

  (defthm simplify-terms-such-as-a+ab-=-0
    (implies (and (bind-free
                   (simplify-terms-such-as-a+ab-rel-0-fn sum)
                   (common quotient))
                  (case-split (acl2-numberp common))
                  (case-split (acl2-numberp quotient))
                  (case-split (equal sum
                                     (* common quotient))))
             (equal (equal sum 0)
                    (or (equal common 0)
                        (equal quotient 0)))))

  (thm (equal (equal (+ u (* u v)) 0)
        (or (equal u 0) (equal v -1))))
  ~ev[]")

(defun extra-info (x y)
  (declare (ignore x y)
           (xargs :guard t))
  t)

(in-theory (disable extra-info (extra-info) (:type-prescription extra-info)))

(defconst *extra-info-fn*

; If this symbol changes, then change *acl2-exports* and the documentation for
; xargs and verify-guards accordingly.

  'extra-info)

; We deflabel Rule-Classes here, so we can refer to it in the doc string for
; tau-system.  We define tau-system (the noop fn whose rune controls the
; whether the tau database is used during proofs) in axioms.lisp because we
; build in the nume of its executable counterpart as a constant (e.g., as we do
; with FORCE) and do not want constants additions to the sources to require
; changing that nume (as would happen if tau-system were defined in
; rewrite.lisp where rule-classes was originally defined).

(deflabel rule-classes
  :doc
  ":Doc-Section Rule-Classes

  adding rules to the database~/
  ~bv[]
  Example Form (from community book finite-set-theory/total-ordering.lisp):
  (defthm <<-trichotomy
    (implies (and (ordinaryp x)
                  (ordinaryp y))
             (or (<< x y)
                 (equal x y)
                 (<< y x)))
    :rule-classes
    ((:rewrite :corollary
               (implies (and (ordinaryp x)
                             (ordinaryp y)
                             (not (<< x y))
                             (not (equal x y)))
                        (<< y x)))))

  General Form:
  a true list of rule class objects as defined below

  Special Cases:
  a symbol abbreviating a single rule class object
  ~ev[]

  When ~ilc[defthm] is used to prove a named theorem, rules may be derived from
  the proved formula and stored in the database.  The user specifies which
  kinds of rules are to be built, by providing a list of rule class ~i[names]
  or, more generally, rule class ~i[objects], which name the kind of rule to
  build and optionally specify varioius attributes of the desired rule.
  The rule class names are ~c[:]~ilc[REWRITE], ~c[:]~ilc[BUILT-IN-CLAUSE],
  ~c[:]~ilc[CLAUSE-PROCESSOR], ~c[:]~ilc[COMPOUND-RECOGNIZER],
  ~c[:]~ilc[CONGRUENCE], ~c[:]~ilc[DEFINITION], ~c[:]~ilc[ELIM],
  ~c[:]~ilc[EQUIVALENCE], ~c[:]~ilc[FORWARD-CHAINING], ~c[:]~ilc[GENERALIZE],
  ~c[:]~ilc[INDUCTION], ~c[:]~ilc[LINEAR], ~c[:]~ilc[META],
  ~c[:]~ilc[REFINEMENT], ~c[:]~ilc[TAU-SYSTEM], ~c[:]~ilc[TYPE-PRESCRIPTION],
  ~c[:]~ilc[TYPE-SET-INVERTER], and ~c[:]~ilc[WELL-FOUNDED-RELATION].  Some
  classes ~i[require] the user-specification of certain class-specific
  attributes.  Each class of rule affects the theorem prover's behavior in a
  different way, as discussed in the corresponding documentation topic.  In
  this topic we discuss the various attributes that may be attached to rule
  classes.

  A rule class object is either one of the ~c[:class] keywords or else is a
  list of the form shown below.  Those fields marked with ``(!)''  are required
  when the ~c[:class] is as indicated.
  ~bv[]
  (:class
    :COROLLARY term
    :TRIGGER-FNS (fn1 ... fnk) ; provided :class = :META (!)
    :TRIGGER-TERMS (t1 ... tk) ; provided :class = :FORWARD-CHAINING
                               ;       or :class = :LINEAR
    :TYPE-SET n                ; provided :class = :TYPE-SET-INVERTER
    :TYPED-TERM term           ; provided :class = :TYPE-PRESCRIPTION
    :CLIQUE (fn1 ... fnk)      ; provided :class = :DEFINITION
    :CONTROLLER-ALIST alist    ; provided :class = :DEFINITION
    :INSTALL-BODY directive    ; provided :class = :DEFINITION
    :LOOP-STOPPER alist        ; provided :class = :REWRITE
    :PATTERN term              ; provided :class = :INDUCTION (!)
    :CONDITION term            ; provided :class = :INDUCTION
    :SCHEME term               ; provided :class = :INDUCTION (!)
    :MATCH-FREE all-or-once    ; provided :class = :REWRITE
                                       or :class = :LINEAR
                                       or :class = :FORWARD-CHAINING
    :BACKCHAIN-LIMIT-LST limit ; provided :class = :REWRITE
                                       or :class = :META
                                       or :class = :LINEAR
                                       or :class = :TYPE-PRESCRIPTION
    :HINTS hints               ; provided instrs = nil
    :INSTRUCTIONS instrs       ; provided  hints = nil
    :OTF-FLG flg)
  ~ev[]
  When rule class objects are provided by the user, most of the fields are
  optional and their values are computed in a context sensitive way.  When a
  ~c[:class] keyword is used as a rule class object, all relevant fields are
  determined contextually.  Each rule class object in ~c[:rule-classes] causes
  one or more rules to be added to the database.  The ~c[:class] keywords are
  documented individually under the following names.  Note that when one of
  these names is used as a ~c[:class], it is expected to be in the keyword
  package (i.e., the names below should be preceded by a colon but the ACL2
  ~il[documentation] facilities do not permit us to use keywords below).

  ~/
  See also ~ilc[force], ~il[case-split], ~ilc[syntaxp], and ~ilc[bind-free] for
  ``pragmas'' one can wrap around individual hypotheses of certain classes of
  rules to affect how the hypothesis is relieved.

  Before we get into the discussion of rule classes, let us return to an
  important point.  In spite of the large variety of rule classes available, at
  present we recommend that new ACL2 users rely almost exclusively on
  (conditional) rewrite rules.  A reasonable but slightly bolder approach is to
  use ~c[:]~ilc[type-prescription] and ~c[:]~ilc[forward-chaining] rules for
  ``type-theoretic'' rules, especially ones whose top-level function symbol is
  a common one like ~ilc[true-listp] or ~ilc[consp]; ~pl[type-prescription] and
  ~pl[forward-chaining].  However, the rest of the rule classes are really not
  intended for widespread use, but rather are mainly for experts.

  We expect that we will write more about the question of which kind of rule to
  use.  For now: when in doubt, use a ~c[:]~ilc[rewrite] rule.

  ~c[:Rule-classes] is an optional keyword argument of the ~ilc[defthm] (and
  ~ilc[defaxiom]) event.  In the following, let ~c[name] be the name of the
  event and let ~c[thm] be the formula to be proved or added as an axiom.

  If ~c[:rule-classes] is not specified in a ~ilc[defthm] (or ~ilc[defaxiom])
  event, it is as though what was specified was to make one or more
  ~c[:]~ilc[rewrite] rules, i.e., as though ~c[:rule-classes] ~c[((:rewrite))]
  had been used.  Use ~c[:rule-classes] ~c[nil] to specify that no rules are to
  be generated.

  If ~c[:rule-classes] class is specified, where class is a non-~c[nil] symbol,
  it is as though ~c[:rule-classes] ~c[((class))] had been used.  Thus,
  ~c[:rule-classes] ~c[:]~ilc[forward-chaining] is equivalent to
  ~c[:rule-classes] ~c[((:forward-chaining))].

  We therefore now consider ~c[:rule-classes] as a true list.  If any element
  of that list is a keyword, replace it by the singleton list containing that
  keyword.  Thus, ~c[:rule-classes] ~c[(:rewrite :elim)] is the same as
  ~c[:rule-classes] ~c[((:rewrite) (:elim))].

  Each element of the expanded value of ~c[:rule-classes] must be a true list
  whose ~ilc[car] is one of the rule class keyword tokens listed above, e.g.,
  ~c[:]~ilc[rewrite], ~c[:]~ilc[elim], etc., and whose ~ilc[cdr] is a ``keyword
  alist'' alternately listing keywords and values.  The keywords in this alist
  must be taken from those shown below.  They may be listed in any order and
  most may be omitted, as specified below.~bq[]

  ~c[:]~ilc[Corollary] ~-[] its value, ~c[term], must be a term.  If omitted,
  this field defaults to ~c[thm].  The ~c[:]~ilc[corollary] of a rule class
  object is the formula actually used to justify the rule created and thus
  determines the form of the rule.  Nqthm provided no similar capability: each
  rule was determined by ~c[thm], the theorem or axiom added.  ACL2 permits
  ~c[thm] to be stated ``elegantly'' and then allows the ~c[:]~ilc[corollary]
  of a rule class object to specify how that elegant statement is to be
  interpreted as a rule.  For the rule class object to be well-formed, its
  (defaulted) ~c[:]~ilc[corollary], ~c[term], must follow from ~c[thm].  Unless
  ~c[term] follows trivially from ~c[thm] using little more than propositional
  logic, the formula ~c[(implies thm term)] is submitted to the theorem prover
  and the proof attempt must be successful.  During that proof attempt the
  values of ~c[:]~ilc[hints], ~c[:]~ilc[instructions], and ~c[:]~ilc[otf-flg],
  as provided in the rule class object, are provided as arguments to the
  prover.  Such auxiliary proofs give the sort of output that one expects from
  the prover.  However, as noted above, corollaries that follow trivially are
  not submitted to the prover; thus, such corollaries cause no prover output.

  Note that before ~c[term] is stored, all calls of macros in it are expanded
  away.  ~l[trans].

  ~c[:]~ilc[Hints], ~c[:]~ilc[instructions], ~c[:]~ilc[otf-flg] ~-[] the values
  of these fields must satisfy the same restrictions placed on the fields of
  the same names in ~ilc[defthm].  These values are passed to the recursive
  call of the prover used to establish that the ~c[:]~ilc[corollary] of the
  rule class object follows from the theorem or axiom ~c[thm].

  ~c[:]~ilc[Type-set] ~-[] this field may be supplied only if the ~c[:class] is
  ~c[:]~ilc[type-set-inverter].  When provided, the value must be a type-set,
  an integer in a certain range.  If not provided, an attempt is made to
  compute it from the corollary.  ~l[type-set-inverter].

  ~c[:Typed-term] ~-[] this field may be supplied only if the ~c[:class] is
  ~c[:]~ilc[type-prescription].  When provided, the value is the term for which
  the ~c[:]~ilc[corollary] is a type-prescription lemma.  If no ~c[:typed-term]
  is provided in a ~c[:]~ilc[type-prescription] rule class object, we try to
  compute heuristically an acceptable term.  ~l[type-prescription].

  ~c[:Trigger-terms] ~-[] this field may be supplied only if the ~c[:class] is
  ~c[:]~ilc[forward-chaining] or ~c[:]~ilc[linear].  When provided, the value
  is a list of terms, each of which is to trigger the attempted application of
  the rule.  If no ~c[:trigger-terms] is provided, we attempt to compute
  heuristically an appropriate set of triggers.  ~l[forward-chaining] or
  ~pl[linear].

  ~c[:Trigger-fns] ~-[] this field must (and may only) be supplied if the
  ~c[:class] is ~c[:]~ilc[meta].  Its value must be a list of function symbols
  (except that a macro alias can stand in for a function symbol;
  ~pl[add-macro-alias]).  Terms with these symbols trigger the application of
  the rule.  ~l[meta].

  ~c[:Clique] and ~c[:controller-alist] ~-[] these two fields may only be
  supplied if the ~c[:class] is ~c[:]~ilc[definition].  If they are omitted,
  then ACL2 will attempt to guess them.  Suppose the ~c[:]~ilc[corollary] of
  the rule is ~c[(implies hyp (equiv (fn a1 ... an) body))].  The value of the
  ~c[:clique] field should be a true list of function symbols, and if
  non-~c[nil] must include ~c[fn].  These symbols are all the members of the
  mutually recursive clique containing this definition of ~c[fn].  That is, a
  call of any function in ~c[:clique] is considered a ``recursive call'' for
  purposes of the expansion heuristics.  The value of the ~c[:controller-alist]
  field should be an alist that maps each function symbol in the ~c[:clique] to
  a list of ~c[t]'s and ~c[nil]'s of length equal to the arity of the function.
  For example, if ~c[:clique] consists of just two symbols, ~c[fn1] and
  ~c[fn2], of arities ~c[2] and ~c[3] respectively, then
  ~c[((fn1 t nil) (fn2 nil t t))] is a legal value of ~c[:controller-alist].
  The value associated with a function symbol in this alist is a ``mask''
  specifying which argument slots of the function ``control'' the recursion for
  heuristic purposes.  Sloppy choice of ~c[:clique] or ~c[:controller-alist]
  can result in infinite expansion and stack overflow.

  ~c[:Install-body] ~-[] this field may only be supplied if the ~c[:class] is
  ~c[:]~ilc[definition].  Its value must be ~c[t], ~c[nil], or the default,
  ~c[:normalize].  A value of ~c[t] or ~c[:normalize] will cause ACL2 to
  install this rule as the new body of the function being ``defined'' (~c[fn]
  in the paragraph just above); hence this definition will be installed for
  future ~c[:expand] ~il[hints].  Furthermore, if this field is omitted or the
  value is ~c[:normalize], then this definition will be simplified using the
  so-called ``normalization'' procedure that is used when processing
  definitions made with ~ilc[defun].  You must explicitly specify
  ~c[:install-body nil] in the following cases: ~c[fn] (as above) is a member
  of the value of constant ~c[*definition-minimal-theory*], the arguments are
  not a list of distinct variables, ~c[equiv] (as above) is not ~ilc[equal], or
  there are free variables in the hypotheses or right-hand side
  (~pl[free-variables]).  However, supplying ~c[:install-body nil] will not
  affect the rewriter's application of the ~c[:definition] rule, other than to
  avoid using the rule to apply ~c[:expand] hints.  If a definition rule
  equates ~c[(f a1 ... ak)] with ~c[body] but there are hypotheses, ~c[hyps],
  then ~c[:expand] ~il[hints] will replace terms ~c[(f term1 ... termk)] by
  corresponding terms ~c[(if hyps body (hide (f term1 ... termk)))].

  ~c[:]~ilc[Loop-stopper] ~-[] this field may only be supplied if the class is
  ~c[:]~ilc[rewrite].  Its value must be a list of entries each consisting of
  two variables followed by a (possibly empty) list of functions, for example
  ~c[((x y binary-+) (u v foo bar))].  It will be used to restrict application
  of rewrite rules by requiring that the list of instances of the second
  variables must be ``smaller'' than the list of instances of the first
  variables in a sense related to the corresponding functions listed;
  ~pl[loop-stopper].  The list as a whole is allowed to be ~c[nil], indicating
  that no such restriction shall be made.  Note that any such entry that
  contains a variable not being instantiated, i.e., not occurring on the left
  side of the rewrite rule, will be ignored.  However, for simplicity we merely
  require that every variable mentioned should appear somewhere in the
  corresponding ~c[:]~ilc[corollary] formula.

  ~c[:Pattern], ~c[:Condition], ~c[:Scheme] ~-[] the first and last of these
  fields must (and may only) be supplied if the class is ~c[:]~ilc[induction].
  ~c[:Condition] is optional but may only be supplied if the class is
  ~c[:]~ilc[induction].  The values must all be terms and indicate,
  respectively, the pattern to which a new induction scheme is to be attached,
  the condition under which the suggestion is to be made, and a term which
  suggests the new scheme.  ~l[induction].

  ~c[:Match-free] ~-[] this field must be ~c[:all] or ~c[:once] and may be
  supplied only if the ~c[:class] is either ~c[:]~ilc[rewrite],
  ~c[:]~ilc[linear], or ~c[:]~ilc[forward-chaining].  (This field is not
  implemented for other rule classes, including the
  ~c[:]~ilc[type-prescription] rule class.)  ~l[free-variables] for a
  description of this field.  Note: Although this field is intended to be used
  for controlling retries of matching free variables in hypotheses, it is legal
  to supply it even if there are no such free variables.  This can simplify the
  automated generation of rules, but note that when ~c[:match-free] is
  supplied, the warning otherwise provided for the presence of free variables
  in hypotheses will be suppressed.

  ~c[:Backchain-limit-lst] ~-[] this field may be supplied only if the
  ~c[:class] is either ~c[:]~ilc[rewrite], ~c[:]~ilc[meta], ~c[:]~ilc[linear],
  or ~c[:]~ilc[type-prescription].  It is further required either only one rule
  is generated from the formula or, at least, every such rule has the same list
  of hypotheses.  The value for ~c[:backchain-limit-lst] must be ~c[nil]; a
  non-negative integer; or, except in the case of ~c[:]~ilc[meta] rules, a true
  list each element of which is either ~c[nil] or a non-negative integer.  If
  it is a list, its length must be equal to the number of hypotheses of the
  rule and each item in the list is the ``backchain limit'' associated with the
  corresponding hypothesis.  If ~c[backchain-limit-lst] is a non-negative
  integer, it is defaulted to a list of the appropriate number of repetitions
  of that integer.  The backchain limit of a hypothesis is used to limit the
  effort that ACL2 will expend when relieving the hypothesis.  If it is
  ~c[NIL], no new limits are imposed; if it is an integer, the hypothesis will
  be limited to backchaining at most that many times.  Note that backchaining
  may be further limited by a global ~c[backchain-limit]; ~pl[backchain-limit]
  for details.  For different ways to reign in the rewriter,
  ~pl[rewrite-stack-limit] and ~pl[set-prover-step-limit].  Jared Davis has
  pointed out that you can set the ~c[:backchain-limit-lst] to 0 to avoid any
  attempt to relieve ~ilc[force]d hypotheses, which can lead to a significant
  speed-up in some cases.

  ~eq[]Once ~c[thm] has been proved (in the case of ~ilc[defthm]) and each rule
  class object has been checked for well-formedness (which might require
  additional proofs), we consider each rule class object in turn to generate
  and add rules.  Let ~c[:class] be the class keyword token of the ~c[i]th
  class object (counting from left to right).  Generate the ~il[rune]
  ~c[(:class name . x)], where ~c[x] is ~c[nil] if there is only one class and
  otherwise ~c[x] is ~c[i].  Then, from the ~c[:]~ilc[corollary] of that
  object, generate one or more rules, each of which has the name
  ~c[(:class name . x)].  See the ~c[:]~ilc[doc] entry for each rule class to
  see how formulas determine rules.  Note that it is in principle possible for
  several rules to share the same name; it happens whenever a
  ~c[:]~ilc[corollary] determines more than one rule.  This in fact only occurs
  for ~c[:]~ilc[rewrite], ~c[:]~ilc[linear], and ~c[:]~ilc[forward-chaining]
  class rules and only then if the ~c[:]~ilc[corollary] is essentially a
  conjunction.  (See the documentation for ~il[rewrite], ~il[linear], or
  ~il[forward-chaining] for details.)~/")

(defun tau-system (x)

  ":Doc-Section Rule-Classes

  make a rule for the ACL2 ``type checker''~/

  This documentation topic describes the syntactic form of ``tau-system''
  rules; these rules extend ACL2's ``type checker.''  For an introduction to
  the tau system, ~pl[introduction-to-the-tau-system].

  There happens to be a ~i[function] named ~c[tau-system], defined as the
  identity function.  Its only role is to provide the rune
  ~c[(:EXECUTABLE-COUNTERPART TAU-SYSTEM)], which is used to enable and disable
  the tau system.  Otherwise the function ~c[tau-system] has no purpose and we
  recommend that you avoid using it so you are free to enable and disable the
  tau system.

  When in the default (``greedy'') mode (see ~ilc[set-tau-auto-mode]), every
  ~ilc[defun] and every ~c[:corollary] (see ~c[:]~ilc[rule-classes]) of every
  ~ilc[defthm] stored as a rule ~i[of any] ~c[:rule-class] is inspected to
  determine if it is of one of the forms below.  Rules of these forms are added
  to the tau database, even if they are not labeled as ~c[:tau-system] rules,
  e.g., a ~c[:]~ilc[rewrite] rule might contribute to the tau database!  To
  add a rule to the tau database without adding any other kind of rule, tag it
  with ~c[:]~ilc[rule-classes] ~c[:tau-system].  If a theorem has
  ~c[:]~ilc[rule-classes] ~c[nil], it is not considered for the tau database.

  ~bv[]
  General Forms:
  ~i[Boolean]:
  (booleanp (p v))

  ~i[Eval]:
  (p 'const) or
  (p *const*)

  ~i[Simple]:
  (implies (p v) (q v))

  ~i[Conjunctive]:
  (implies (and (p1 v) ... (pk v)) (q v)), ; Here k must exceed 1.

  ~i[Signature Form 1]:
  (implies (and (p1 x1) (p2 x2) ...)
           (q (fn x1 x2 ...)))

  ~i[Signature Form 2]:
  (implies (and (p1 x1) (p2 x2) ...)
           (q (mv-nth 'n (fn x1 x2 ...))))

  ~i[Bounder Form 1 (or Form 2)]:
  (implies (and (tau-intervalp i1)
                ...
                (or (equal (tau-interval-dom i1) 'dom1-1)
                    ...)
                ...
                (in-tau-intervalp x1 i1)
                ...)
           (and (tau-intervalp (bounder-fn i1 ...))
                (in-tau-intervalp ~i[target]
                                  (bounder-fn i1 ...))))

  where ~i[target] is
  (fn x1 ... y1 ...)             in ~i[Form 1], and
  (mv-nth 'n (fn x1 ... y1 ...)) in ~i[Form 2]

  ~i[Big Switch]:
  (equal (fn . formals) body)

  ~i[MV-NTH Synonym]:
  (equal (nth-alt x y) (mv-nth x y)) or
  (equal (mv-nth x y) (nth-alt x y))
  ~ev[]

  The symbols ~c[p], ~c[q], ~c[p1], etc., denote monadic (one-argument)
  Boolean-valued function symbols, or equalities in which one argument is
  constant, arithmetic comparisons in which one argument is a rational or
  integer constant, or the logical negations of such terms.  By ``equalities''
  we allow ~ilc[EQUAL], ~ilc[EQ], ~ilc[EQL], and ~ilc[=].  By ``arithmetic
  comparison'' we mean ~ilc[<], ~ilc[<=], ~ilc[>=], or ~ilc[>].  Any of
  these tau predicates may appear negated.

  The notation ~c[(p v)] above might stand for any one of:
  ~bv[]
  (INTEGERP X)
  (EQUAL V 'MONDAY)
  (<= I 16)
  (NOT (EQUAL X 'SUNDAY))
  ~ev[]

  The different rule forms above affect different aspects of the tau system.
  We discuss each form in more detail below.~/

  The documentation below is written as though the tau system is in auto mode!
  To insure that the only rules added to the tau system are those explicitly
  assigned to ~c[:rule-class] ~c[:tau-system], you should use
  ~ilc[set-tau-auto-mode] to select manual mode.

  ~bv[]
  General Form: ~i[Boolean]:
  (booleanp (p v))
  ~ev[]
  Here ~c[p] must be a function symbol and ~c[v] must be a variable.  Such a
  ~c[:tau-system] rule adds ~c[p] to the list of tau predicates.  If ~c[p] was
  recognized as Boolean when it was defined, there is no need to state this
  rule.  This form is needed if you define a monadic Boolean function in such a
  way that the system does not recognize that it is Boolean.

  ~bv[]
  General Form: ~i[Eval]:
  (p 'const) or
  (p *const*)
  ~ev[]

  Here ~c[p] must be a function symbol.  In addition, recall that these general
  tau predicate forms may appear negated.  So the form above includes such
  theorems as ~c[(NOT (GOOD-STATEP *INITIAL-STATE*))].  A theorem of this form thus
  records whether a named predicate is true or false on the given constant.

  Generally, when the tau system must determine whether an enabled tau
  predicate is true or false on a constant, it simply evaluates the predicate
  on the constant.  This can be impossible or very inefficient if ~c[p] is not
  defined but constrained, or if ~c[p] is defined in a hard-to-compute
  way (e.g., ~c[(defun p (x) (evenp (ack x x)))] where ~c[ack] is the Ackermann
  function), or perhaps if the constant is very large.  By proving a
  ~c[:tau-system] rule of Eval form, you cause the tau system to note the value
  of the predicate on the constant and henceforth to look it up instead of
  evaluating the definition.

  A difficulty, however, is determining that a slow down is due to the
  evaluation of tau predicates and not some other reason.  The first step is
  determining that tau is slowing the proof down.  See ~ilc[time-tracker-tau]
  for an explanation of ~c[TIME-TRACKER-NOTE]s output during some proofs
  involving tau reasoning.  These notes can alert you to the fact that
  significant amounts of time are being spent in the tau system.
  ~ilc[Time-tracker-tau] gives some ways of determining whether tau predicate
  evaluation is involved.  (If worse comes to worst, consider the following
  hack: In the ACL2 source file ~c[tau.lisp], immediately after the definition
  of the system function ~c[ev-fncall-w-tau-recog], there is a comment which
  contains some raw Lisp code that can be used to investigate whether tau's use
  of evaluation on constants is causing a problem.)  However, once a recognizer
  and the constants on which it is being evaluated are identified, the tau
  system can be sped up by proving Eval rules to pre-compute and store the
  values of the recognizer on those constants.  Alternatively, at the possible
  loss of some completeness in the tau system, the executable counterpart of
  the recognizer can be disabled.

  ~bv[]
  General Form: ~i[Simple]:
  (implies (p v) (q v))
  ~ev[]
  Here ~c[v] must be a variable symbol.  This rule builds-in the information
  that anything satisfying ~c[p] must also satisfy ~c[q], i.e., the ``type''
  ~c[q] includes the ``type'' ~c[p].  Recall that the forms may be negated.
  Most of the time, ~c[p] and ~c[q] will be predicate symbols but it is
  possible they will be equalities- or inequalities-with-constants.  Examples
  of Simple rules include the following, which are in fact built-in:

  ~bv[]
  (implies (natp x) (integerp x))
  (implies (integerp x) (rationalp x))
  (implies (integerp x) (not (true-listp x)))
  (implies (natp x) (not (< x 0)))
  (implies (symbol-alistp x) (alistp x))
  ~ev[]
  Because the tau system records the transitive closure of the Simple rules,
  any time a term is known to satisfy ~c[natp] it is also known to satisfy
  ~c[integerp] and ~c[rationalp], and known not to satisfy ~c[true-listp],
  and known to be non-negative.

  ~bv[]
  General Form: ~i[Conjunctive]:
  (implies (and (p1 v) ... (pk v)) (q v)), ; Here k must exceed 1.
  ~ev[]
  The ~c[pi] and ~c[q] may be any tau predicates or their negations, ~c[v] must
  be a variable symbol, and ~c[i] must exceed 1 or else this is a Simple rule.
  An obvious operational interpretation of this rule is that if an object is
  known to satisfy all of the ~c[pi], then it is known to satisfy ~c[q].
  However, the actual interpretation is more general.  For example, if an
  object is known to satisfy all but one of the ~c[pi] and is known not to
  satisfy ~c[q], then the object is known not to satisfy the ``missing''
  ~c[pi].

  For example, the following Conjunctive rule allows tau to conclude that if
  weekday ~c[D] is not ~c[MON], ~c[TUE], ~c[THU] or ~c[FRI], then it is ~c[WED]:
  ~bv[]
  (implies (and (weekdayp d)
                (not (eq d 'MON))
                (not (eq d 'TUE))
                (not (eq d 'WED))
                (not (eq d 'THU)))
           (eq d 'FRI))
  ~ev[]
  The tau database is not closed under conjunctive rules; they are applied dynamically.

  ~bv[]
  General Form: ~i[Signature Form 1]:
  (implies (and (p1 x1) (p2 x2) ... (pn xn) dep-hyp)
           (q (fn x1 x2 ... xn)))
  ~ev[]
  The ~c[pi] and ~c[q] may be any tau predicates or their negations, ~c[fn]
  must be a function symbol of arity ~c[n], the ~c[xi] must be distinct
  variable symbols and ~c[dep-hyp] may be any term, provided it is not of the
  ~c[(pi xi)] shape and the only the variables in it are the ~c[xi].

  The Signature form actually allows multiple tau predicates to be applied to
  each variable, e.g., x1 might be required to be both an ~c[INTEGERP] and
  ~c[EVENP].  The Signature form allows there to be multiple hypotheses
  classified as ~c[dep-hyp]s, i.e., not fitting any of the previous shapes, and
  they are implicitly just conjoined.  The name ``dep-hyp'' is an abbreviation
  of ``dependent hypothesis'' and stems from the fact they often express
  relations between several of the function's inputs rather than type-like
  constraints on individual inputs.

  A Signature rule informs tau that the function ~c[fn] returns an object
  satisfying ~c[q] provided that the arguments satisfy the respective ~c[pi]
  and provided that ~c[dep-hyp] occurs in the current context.  Note: to be
  precise, dependent hypotheses are relieved only by applying ACL2's most
  primitive form of reasoning, ~il[type-set].  In particular, tau reasoning is
  not used to establish dependent hypotheses.  The presence of a ~c[dep-hyp] in
  a signature rule may severely restrict its applicability.  We discuss this
  after showing a few mundane examples.

  An example Signature rule is
  ~bv[]
  (implies (and (integer-listp x)
                (integer-listp y))
           (integer-listp (append x y)))
  ~ev[]
  Of course, a function may have multiple signatures:
  ~bv[]
  (implies (and (symbol-listp x)
                (symbol-listp y))
           (symbol-listp (append x y)))
  ~ev[]
  Here is a Signature rule for the function ~c[pairlis$]:
  ~bv[]
  (implies (and (symbol-listp x)
                (integer-listp y))
           (symbol-alistp (pairlis$ x y)))
  ~ev[]
  The tau system can consequently check this theorem by composing the last two
  rules shown and exploiting Simple rule stating that symbol-alists are also
  alists:
  ~bv[]
  (thm (implies (and (symbol-listp a)
                     (symbol-listp b)
                     (integer-listp y))
                (alistp (pairlis$ (append a b) y))))
  ~ev[]
  Since ~c[a] and ~c[b] are known to be lists of symbols and a signature for
  ~c[append] is that it preserves that predicate, the first argument to the
  ~c[pairlis$] expression is known to be a list of symbols.  This means the
  Signature rule for ~c[pairlis$] tells us the result is a ~c[symbol-alistp], but
  the previously mentioned Simple rule, ~c[(implies (symbol-alistp x) (alistp x))],
  tells us the result is also an ~c[alistp].

  When a Signature rule has an ~c[dep-hyp], that hypothesis is not an expression
  in the tau system.  Tau is not used to check that hypothesis.  Instead, tau uses the
  more primitive ~il[type-set] mechanism of ACL2.  Here is an example of a Signature
  rule with a ~c[dep-hyp]:
  ~bv[]
  (implies (and (natp n)
                (integer-listp a)
                (< n (len a)))
           (integerp (nth n a)))
  ~ev[]

  Note that the last hypothesis is a dependent hypothesis: it is not a tau
  predicate but a relationship between ~c[n] and ~c[a].  It is relieved by
  ~il[type-set].  If one is trying to compute the signature of an ~c[(nth n a)]
  expression in a context in which ~c[(< n (len a))] is explicitly assumed,
  then this mechanism would establish the dependent hypothesis.  But one can
  easily imagine an almost identical context where, say ~c[(< n (len (rev a)))]
  is explicitly assumed.  In that context, the Signature rule would not be
  fired because ~ilc[type-set] cannot establish ~c[(< n (len a))] from
  ~c[(< n (len (rev a)))], even though it would be easily proved by rewriting
  using the theorem ~c[(equal (len (rev a)) (len a))].

  Note also that if this signature could be phrased in a way that eliminates
  the dependency between ~c[n] and ~c[a] it would be more effective.  For example,
  here is a related Signature rule without a dependent hypothesis:

  ~bv[]
  (implies (and (natp n)
                (register-filep a)
                (< n 16))
           (integerp (nth n a)))
  ~ev[]
  In this theorem we require only that ~c[n] be less than 16, which is a tau
  predicate and hence just an additional tau constraint on ~c[n].

  ~bv[]
  General Form: ~i[Signature Form 2]:
  (implies (and (p1 x1) (p2 x2) ... (pn xn) dep-hyp)

           (q (mv-nth 'n (fn x1 x2 ... xn))))
  ~ev[]
  This form of signature rule is just like form 1 except that it is useful for functions
  that return multiple-values and allows us to ``type-check'' their individual outputs.

  ~bv[]
  General Form: ~i[Bounder Forms 1 and 2]:
  (implies (and (tau-intervalp i1)
                ...
                (or (equal (tau-interval-dom i1) 'dom1-1)
                    ...)
                ...
                (in-tau-intervalp x1 i1)
                ...)
           (and (tau-intervalp (bounder-fn i1 ...))
                (in-tau-intervalp ~i[target]
                                  (bounder-fn i1 ...))))
  ~ev[]
  where ~i[target] is either ~c[(fn x1 ... y1 ...)] in ~i[Form 1] or
  ~c[(mv-nth 'n (fn x1 ... y1 ...))] in ~i[Form 2].

  This form is for advanced users only and the schema given above is
  just a reminder of the general shape.  A ``bounder'' for a given function
  symbol, ~c[fn], is a function symbol ~c[bounder-fn] that computes an interval
  containing ~c[(fn x1 ... y1 ...)] (or its ~c[n]th component in the case of
  Form 2 rules) from the intervals containing certain of the arguments of
  ~c[fn].  The correctness theorem for a bounder function informs the tau
  system that bounds for ~c[fn] are computed by ~c[bounder-fn] and sets up the
  correspondence between the relevant arguments, ~c[xi], of ~c[fn] and the
  intervals containing those arguments, ~c[ii] to which ~c[bounder-fn] is
  applied.  When the tau system computes the tau for a call of ~c[fn], it
  computes the tau of the relevant arguments and applies the bounder to the
  intervals of those tau.  This provides a domain and upper and/or lower bounds
  for the value of the term.  The tau system then further augments that with
  signature rules.  ~l[bounders] for details on intervals, bounders, and
  bounder correctness theorems.

  ~bv[]
  General Form: ~i[Big Switch]:
  (equal (fn . formals) body)
  ~ev[]
  In the Big Switch form, ~c[fn] must be a function symbol, ~c[formals] must be
  a list of distinct variable symbols, and ~c[body] must be a ``big switch''
  term, i.e., one that case splits on tau predicates about a single variable
  and produces a term not involving that variable.  An example of a Big Switch
  rule is
  ~bv[]
  (equal (conditional-type x y)
         (if (consp x)
             (consp y)
             (integerp y)))
  ~ev[]
  The idea is that the tau system can treat calls of ~c[conditional-type] as
  a tau-predicate after determining the tau of an argument.

  Since equality-to-constants are tau predicates, a more common example of a
  Big Switch rule is
  ~bv[]
  (equal (dtypep x expr)
         (case x
               (STMT (stmt-typep expr))
               (EXPR (expr-typep expr))
               (MODULE (module-typep expr))
               (otherwise nil)))
  ~ev[]
  This is because ~c[(case x (STMT ...) ...)] macroexpands in ACL2 to
  ~c[(if (eql x 'STMT) ... ...)] and ~c[(eql x 'STMT)] is a tau predicate
  about ~c[x].

  Big Switch rules are recognized when a function is defined (if tau is in
  automatic mode).  They generally do not have to be proved explicitly, though
  they might be when mutual recursion is involved.  Only the first detected Big
  Switch rule about a function ~c[fn] is recognized.

  ~bv[]
  General Form: ~i[MV-NTH Synonym]:
  (equal (nth-alt x y) (mv-nth x y)) or
  (equal (mv-nth x y) (nth-alt x y))
  ~ev[]
  Rules of this form just tell the tau system that the user-defined function
  ~c[nth-alt] is synonymous with the ACL2 primitive function ~c[mv-nth].
  Because ACL2's rewriter gives special handling to ~c[mv-nth], users sometimes
  define their own versions of that function so they can disable them and control
  rewriting better.  By revealing to the tau system that such a synonym has been
  introduced you allow Signature rules of Form 2 to be used.~/"

  (declare (xargs :mode :logic :guard t))
  x)

; Essay on the Status of the Tau System During and After Bootstrapping

; Think of there being two ``status bits'' associated with the tau system: (a)
; whether it is enabled or disabled and (b) whether it is automatically making
; :tau-system rules from non-:tau-system rules.  These two bits are independent.

; Bit (a) may be inspected by (enabled-numep *tau-system-xnume* (ens state))
; Bit (b) may be inspected by (table acl2-defaults-table :tau-auto-modep)

; To boot, we must think about two things: how we want these bits set DURING
; bootstrap and how we want them set (for the user) AFTER bootstrap.  Our
; current choices are:

; During Bootstrapping:
; (1.a) tau is disabled -- unavailable for use in boot-strap proofs, and
; (1.b) tau is in manual mode -- make no :tau-system rules except those so tagged

; We don't actually have any reason for (1.a).  The bootstrap process works
; fine either way, as of this writing (Aug, 2011) when the tau system was first
; integrated into ACL2.  But we feel (1.b) is important: it is convenient if  <------ ???? tau to do
; the tau database contains the rules laid down during the bootstrap process,
; e.g., the tau signatures of the primitives so that if the user immediately
; selects automatic mode for the session, the tau database is up to date as of
; that selection.

; After Bootstrapping:
; (2.a) tau is disabled -- not available for use in proofs, BUT
; (2.b) tau is in automatic mode -- makes :tau-system rules out of  <---- ??? actually in manual mode
; non-:tau-system rules

; We feel that after booting, (2.a) is important because of backwards
; compatibility during book certification: we don't want goals eliminated by
; tau, causing subgoals to be renumbered.  We feel that (2.b) is important in the
; long run: we'd like tau to be fully automatic and robust in big proof
; efforts, so we are trying to stress it by collecting tau rules even during
; book certification.  In addition, we want the user who turns on the tau
; system to find that it knows as much as possible.

; Our post-bootstrap selections for these two bits affects the regression
; suite.  If the tau system is enabled by default, then some adjustments must
; be made in the regression suite books!  We have successfully recertified the
; regression suite with tau enabled, but only after making certain changes
; described in Essay on Tau-Clause -- Using Tau to Prove or Mangle Clauses.
; If tau is enabled by default, the regression slows down by about
; real slowdown:  5.3%
; user slowdown:  5.8%
; sys  slowdown: 12.3%
; as measured with time make -j 3 regression-fresh on a Macbook Pro 2.66 GHz
; Intel Core i7 with 8 GB 1067 MHz DDR3 running Clozure Common Lisp Version
; 1.6-dev-r14316M-trunk (DarwinX8632).

; How do we achieve these settings?  The following constant defines all four
; settings.  To rebuild the system with different settings, just redefine this
; constant.  It is not (always) possible to adjust these settings during boot
; by set-tau-auto-mode events, for example, because the acl2-defaults-table may
; not exist.

(defconst *tau-status-boot-strap-settings*
   '((t . t) . (t . t)))                         ; See Warning below!
;  '((t . t) . (nil . t)))                       ; ((1.a . 1.b) . (2.a . 2.b))

; Thus,
; (1.a) = (caar *tau-status-boot-strap-settings*) ; tau system on/off during boot
; (1.b) = (cdar *tau-status-boot-strap-settings*) ; tau auto mode during boot
; (2.a) = (cadr *tau-status-boot-strap-settings*) ; tau system on/off after boot
; (2.b) = (cddr *tau-status-boot-strap-settings*) ; tau auto mode after boot

; Warning: If you change these defaults, be sure to change the documentation
; topics tau-system and introduction-to-the-tau-system and set-tau-auto-mode
; and probably tau-status, where we are likely to say that the default setting
; the user sees is tau-system on, auto mode on.

(in-theory (if (caar *tau-status-boot-strap-settings*)
               (enable (:executable-counterpart tau-system))
               (disable (:executable-counterpart tau-system))))

(defconst *tau-system-xnume*
  (+ *force-xnume* 12))

; These constants record the tau indices of the arithmetic predicates.
(defconst *tau-acl2-numberp-pair* '(0 . ACL2-NUMBERP))
(defconst *tau-integerp-pair*
  #+non-standard-analysis
  '(5 . INTEGERP)
  #-non-standard-analysis
  '(4 . INTEGERP))
(defconst *tau-rationalp-pair*
  #+non-standard-analysis
  '(6 . RATIONALP)
  #-non-standard-analysis
  '(5 . RATIONALP))
(defconst *tau-natp-pair*
  #+non-standard-analysis
  '(20 . NATP)
  #-non-standard-analysis
  '(17 . NATP))
(defconst *tau-posp-pair*
  #+non-standard-analysis
  '(21 . POSP)
  #-non-standard-analysis
  '(18 . POSP))
(defconst *tau-minusp-pair*
  #+non-standard-analysis
  '(29 . MINUSP)
  #-non-standard-analysis
  '(26 . MINUSP))
(defconst *tau-booleanp-pair*
  #+(and (not non-standard-analysis) acl2-par)
  '(103 . BOOLEANP)
  #+(and (not non-standard-analysis) (not acl2-par))
  '(102 . BOOLEANP)
  #+(and non-standard-analysis (not acl2-par))
  '(105 . BOOLEANP)
  #+(and non-standard-analysis acl2-par)
  '(106 . BOOLEANP)
  )

; Note: The constants declared above are checked for accuracy after bootstrap
; by check-built-in-constants in interface-raw.lisp.

; The following axiom can be proved.  John Cowles has proved some of these and
; we have proved others in our efforts to verify the guards in our code.
; Eventually we will replace some of these axioms by theorems.  But not now
; because things are too fluid.

;; RAG - This axiom was strengthened to include the reals.  Amusingly,
;; it was also weakened, since it leaves open the possibility that for
;; rational x, x*x is irrational.  Luckily, the type-system knows this
;; isn't the case, so hopefully we have not weakened ACL2.

(defaxiom nonnegative-product

; Note that in (* x x), x might be complex.  So, we do not want to force the
; hypothesis below.

  (implies (real/rationalp x)
           (and (real/rationalp (* x x))
                (<= 0 (* x x))))

; We need the :type-prescription rule class below.  Without it, ACL2 cannot
; prove (implies (rationalp x) (<= 0 (* x x))); primitive type-set reasoning
; will not notice that both arguments of * are identical.

  :rule-classes ((:type-prescription
                  :typed-term (* x x))))

; (add-schema Induction Schema
;             (and (implies (not (integerp x)) (p x))
;                  (p 0)
;                  (implies (and (integerp x)
;                                (< 0 x)
;                                (p (- x 1)))
;                           (p x))
;                  (implies (and (integerp x)
;                                (< x 0)
;                                (p (+ x 1)))
;                           (p x)))
;             (p x))
;

(defaxiom Integer-0
  (integerp 0)
  :rule-classes nil)

(defaxiom Integer-1
  (integerp 1)
  :rule-classes nil)

(defaxiom Integer-step
  (implies (integerp x)
           (and (integerp (+ x 1))
                (integerp (+ x -1))))
  :rule-classes nil)

(defaxiom Lowest-Terms
  (implies (and (integerp n)
                (rationalp x)
                (integerp r)
                (integerp q)
                (< 0 n)
                (equal (numerator x) (* n r))
                (equal (denominator x) (* n q)))
           (equal n 1))
  :rule-classes nil)

; The following predicates are disjoint and these facts are all built into type-set:
;   (((acl2-numberp x)
;     (complex-rationalp x)
;     ((rationalp x)
;      ((integerp x) (< 0 x) (equal x 0) (< x 0))
;      ((not (integerp x)) (< 0 x) (< x 0))))
;    ((consp x) (proper-consp x) (improper-consp x))
;    ((symbolp x) (equal x nil) (equal x T) (not (or (equal x T)
;                                                    (equal x NIL))))
;    (stringp x)
;    (characterp x)
;    (other-kinds-of-objects))

; Here we prove some rules that the tau system uses to manage primitive type-sets.
; The rules for natp, posp, and minusp are messy because those concepts are not
; simply predicates on the signs but also (sometimes) on INTEGERP.

(defthm basic-tau-rules
  (and (implies (natp v) (not (minusp v)))
       (implies (natp v) (integerp v))

       (implies (posp v) (natp v))

       (implies (minusp v) (acl2-numberp v))

       (implies (integerp v) (rationalp v))
       (implies (rationalp v) (not (complex-rationalp v)))
       (implies (rationalp v) (not (characterp v)))
       (implies (rationalp v) (not (stringp v)))
       (implies (rationalp v) (not (consp v)))
       (implies (rationalp v) (not (symbolp v)))

       (implies (complex-rationalp v) (not (characterp v)))
       (implies (complex-rationalp v) (not (stringp v)))
       (implies (complex-rationalp v) (not (consp v)))
       (implies (complex-rationalp v) (not (symbolp v)))

       (implies (characterp v) (not (stringp v)))
       (implies (characterp v) (not (consp v)))
       (implies (characterp v) (not (symbolp v)))

       (implies (stringp v) (not (consp v)))
       (implies (stringp v) (not (symbolp v)))

       (implies (consp v) (not (symbolp v)))

; We catch Boolean type-prescriptions and convert them to tau signature rules.
; The first lemma below links booleanp to symbolp and thus to the other recogs.
; The next two deal with special cases: boolean functionse that do not have
; type-prescriptions because we have special functions for computing their
; type-sets.

       (implies (booleanp v) (symbolp v))
       (booleanp (equal x y))
       (booleanp (< x y))

       )

  :rule-classes :tau-system)

; ; For each of the primitives we have the axiom that when their guards
; ; are unhappy, the result is given by apply.  This is what permits us
; ; to replace unguarded terms by apply's.  E.g.,
;
; (defaxiom +-guard
;   (implies (or (not (rationalp x))
;                (not (rationalp y)))
;            (equal (+ x y)
;                   (apply '+ (list x y)))))

(defaxiom car-cdr-elim
  (implies (consp x)
           (equal (cons (car x) (cdr x)) x))
  :rule-classes :elim)

(defaxiom car-cons (equal (car (cons x y)) x))

(defaxiom cdr-cons (equal (cdr (cons x y)) y))

(defaxiom cons-equal
  (equal (equal (cons x1 y1) (cons x2 y2))
         (and (equal x1 x2)
              (equal y1 y2))))

; Induction Schema:   (and (implies (not (consp x)) (p x))
;                          (implies (and (consp x) (p (car x)) (p (cdr x)))
;                                   (p x)))
;                     ----------------------------------------------
;                     (p x)
;
;

(defaxiom booleanp-characterp
  (booleanp (characterp x))
  :rule-classes nil)

(defaxiom characterp-page
  (characterp #\Page)
  :rule-classes nil)

(defaxiom characterp-tab
  (characterp #\Tab)
  :rule-classes nil)

(defaxiom characterp-rubout
  (characterp #\Rubout)
  :rule-classes nil)

; No-duplicatesp

(defun no-duplicatesp-eq-exec (l)
  (declare (xargs :guard (symbol-listp l)))
  (cond ((endp l) t)
        ((member-eq (car l) (cdr l)) nil)
        (t (no-duplicatesp-eq-exec (cdr l)))))

(defun no-duplicatesp-eql-exec (l)
  (declare (xargs :guard (eqlable-listp l)))
  (cond ((endp l) t)
        ((member (car l) (cdr l)) nil)
        (t (no-duplicatesp-eql-exec (cdr l)))))

(defun no-duplicatesp-equal (l)
  (declare (xargs :guard (true-listp l)))
  (cond ((endp l) t)
        ((member-equal (car l) (cdr l)) nil)
        (t (no-duplicatesp-equal (cdr l)))))

(defmacro no-duplicatesp-eq (x)
  `(no-duplicatesp ,x :test 'eq))

(defthm no-duplicatesp-eq-exec-is-no-duplicatesp-equal
  (equal (no-duplicatesp-eq-exec x)
         (no-duplicatesp-equal x)))

(defthm no-duplicatesp-eql-exec-is-no-duplicatesp-equal
  (equal (no-duplicatesp-eql-exec x)
         (no-duplicatesp-equal x)))

(defmacro no-duplicatesp (x &key (test ''eql))

  ":Doc-Section ACL2::ACL2-built-ins

  check for duplicates in a list~/
  ~bv[]
  General Forms:
  (no-duplicatesp x)
  (no-duplicatesp x :test 'eql)   ; same as above (eql as equality test)
  (no-duplicatesp x :test 'eq)    ; same, but eq is equality test
  (no-duplicatesp x :test 'equal) ; same, but equal is equality test
  ~ev[]

  ~c[(no-duplicatesp lst)] is true if and only if no member of ~c[lst] occurs
  twice in ~c[lst].  The optional keyword, ~c[:TEST], has no effect logically,
  but provides the test (default ~ilc[eql]) used for comparing elements of
  ~c[lst].~/

  The ~il[guard] for a call of ~c[no-duplicatesp] depends on the test.  In all
  cases, the argument must satisfy ~ilc[true-listp].  If the test is ~ilc[eql],
  then the argument must satisfy ~ilc[eqlable-listp].  If the test is ~ilc[eq],
  then the argument must satisfy ~ilc[symbol-listp].

  ~l[equality-variants] for a discussion of the relation between
  ~c[no-duplicatesp] and its variants:
  ~bq[]
  ~c[(no-duplicatesp-eq x lst)] is equivalent to
  ~c[(no-duplicatesp x lst :test 'eq)];

  ~c[(no-duplicatesp-equal x lst)] is equivalent to
  ~c[(no-duplicatesp x lst :test 'equal)].
  ~eq[]
  In particular, reasoning about any of these primitives reduces to reasoning
  about the function ~c[no-duplicatesp-equal].~/"

  (declare (xargs :guard (or (equal test ''eq)
                             (equal test ''eql)
                             (equal test ''equal))))
  (cond
   ((equal test ''eq)
    `(let-mbe ((x ,x))
              :logic (no-duplicatesp-equal x)
              :exec  (no-duplicatesp-eq-exec x)))
   ((equal test ''eql)
    `(let-mbe ((x ,x))
              :logic (no-duplicatesp-equal x)
              :exec  (no-duplicatesp-eql-exec x)))
   (t ; (equal test 'equal)
    `(no-duplicatesp-equal ,x))))

; The following is used in stobj-let.

(defun chk-no-duplicatesp (lst)
  (declare (xargs :guard (and (eqlable-listp lst)
                              (no-duplicatesp lst)))
           (ignore lst))
  nil)

; Rassoc

(defun r-eqlable-alistp (x)

; For guard to rassoc-eql-exec.

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for a true list of pairs whose ~ilc[cdr]s are suitable for ~ilc[eql]~/

  The predicate ~c[r-eqlable-alistp] tests whether its argument is a
  ~ilc[true-listp] of ~ilc[consp] objects whose ~ilc[cdr]s all satisfy
  ~ilc[eqlablep].

  To see the ACL2 definition of this function, ~pl[pf].~/~/"

  (declare (xargs :guard t))
  (cond ((atom x) (equal x nil))
        (t (and (consp (car x))
                (eqlablep (cdr (car x)))
                (r-eqlable-alistp (cdr x))))))

(defun r-symbol-alistp (x)

; For guard to rassoc-eq-exec.

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for association lists with symbols as values~/

  ~c[(R-symbol-alistp x)] is true if and only if ~c[x] is a list of pairs of
  the form ~c[(cons key val)] where ~c[val] is a ~ilc[symbolp].

  To see the ACL2 definition of this function, ~pl[pf].~/~/"

  (declare (xargs :guard t))
  (cond ((atom x) (equal x nil))
        (t (and (consp (car x))
                (symbolp (cdr (car x)))
                (r-symbol-alistp (cdr x))))))

(defun rassoc-eq-exec (x alist)
  (declare (xargs :guard (if (symbolp x)
                             (alistp alist)
                           (r-symbol-alistp alist))))
  (cond ((endp alist) nil)
        ((eq x (cdr (car alist))) (car alist))
        (t (rassoc-eq-exec x (cdr alist)))))

(defun rassoc-eql-exec (x alist)
  (declare (xargs :guard (if (eqlablep x)
                             (alistp alist)
                           (r-eqlable-alistp alist))))
  (cond ((endp alist) nil)
        ((eql x (cdr (car alist))) (car alist))
        (t (rassoc-eql-exec x (cdr alist)))))

(defun rassoc-equal (x alist)
  (declare (xargs :guard (alistp alist)))
  #-acl2-loop-only ; Jared Davis found efficiencies in using native assoc
  (rassoc x alist :test #'equal)
  #+acl2-loop-only
  (cond ((endp alist) nil)
        ((equal x (cdr (car alist))) (car alist))
        (t (rassoc-equal x (cdr alist)))))

(defmacro rassoc-eq (x alist)
  `(rassoc ,x ,alist :test 'eq))

(defthm rassoc-eq-exec-is-rassoc-equal
  (equal (rassoc-eq-exec x alist)
         (rassoc-equal x alist)))

(defthm rassoc-eql-exec-is-rassoc-equal
  (equal (rassoc-eql-exec x alist)
         (rassoc-equal x alist)))

#+acl2-loop-only
(defmacro rassoc (x alist &key (test ''eql))

  ":Doc-Section ACL2::ACL2-built-ins

  look up value in association list~/
  ~bv[]
  General Forms:
  (rassoc x alist)
  (rassoc x alist :test 'eql)   ; same as above (eql as equality test)
  (rassoc x alist :test 'eq)    ; same, but eq is equality test
  (rassoc x alist :test 'equal) ; same, but equal is equality test
  ~ev[]

  ~c[(Rassoc x alist)] is the first member of ~c[alist] whose ~ilc[cdr] is
  ~c[x], or ~c[nil] if no such member exists.  ~c[(rassoc x alist)] is thus
  similar to ~c[(assoc x alist)], the difference being that it looks for the
  first pair in the given alist whose ~ilc[cdr], rather than ~ilc[car], is
  ~ilc[eql] to ~c[x].  ~l[assoc].  The optional keyword, ~c[:TEST], has no
  effect logically, but provides the test (default ~ilc[eql]) used for
  comparing ~c[x] with the ~ilc[cdr]s of successive elements of ~c[lst].~/

  The ~il[guard] for a call of ~c[rassoc] depends on the test.  In all cases,
  the second argument must satisfy ~ilc[alistp].  If the test is ~ilc[eql],
  then either the first argument must be suitable for ~ilc[eql] (~pl[eqlablep])
  or the second argument must satisfy ~ilc[r-eqlable-alistp].  If the test is
  ~ilc[eq], then either the first argument must be a symbol or the second
  argument must satisfy ~ilc[r-symbol-alistp].

  ~l[equality-variants] for a discussion of the relation between ~c[rassoc] and
  its variants:
  ~bq[]
  ~c[(rassoc-eq x lst)] is equivalent to ~c[(rassoc x lst :test 'eq)];

  ~c[(rassoc-equal x lst)] is equivalent to ~c[(rassoc x lst :test 'equal)].
  ~eq[]
  In particular, reasoning about any of these primitives reduces to reasoning
  about the function ~c[rassoc-equal].

  ~c[Rassoc] is defined by Common Lisp.  See any Common Lisp documentation for
  more information.~/"

  (declare (xargs :guard (or (equal test ''eq)
                             (equal test ''eql)
                             (equal test ''equal))))
  (cond
   ((equal test ''eq)
    `(let-mbe ((x ,x) (alist ,alist))
              :logic (rassoc-equal x alist)
              :exec  (rassoc-eq-exec x alist)))
   ((equal test ''eql)
    `(let-mbe ((x ,x) (alist ,alist))
              :logic (rassoc-equal x alist)
              :exec  (rassoc-eql-exec x alist)))
   (t ; (equal test 'equal)
    `(rassoc-equal ,x ,alist))))

(defconst *standard-chars*
  '(#\Newline #\Space
    #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\0 #\1
    #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\: #\; #\< #\= #\> #\? #\@ #\A #\B
    #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S
    #\T #\U #\V #\W #\X #\Y #\Z #\[ #\\ #\] #\^ #\_ #\` #\a #\b #\c #\d
    #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u
    #\v #\w #\x #\y #\z #\{ #\| #\} #\~))

#+acl2-loop-only
(defun standard-char-p (x)

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for standard characters~/

  ~c[(Standard-char-p x)] is true if and only if ~c[x] is a ``standard''
  character, i.e., a member of the list ~c[*standard-chars*].  This list
  includes ~c[#\\Newline] and ~c[#\\Space] ~il[characters], as well as the
  usual punctuation and alphanumeric ~il[characters].~/

  ~c[Standard-char-p] has a ~il[guard] requiring its argument to be a
  character.

  ~c[Standard-char-p] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

; The following guard is required by p. 234 of CLtL.

  (declare (xargs :guard (characterp x)))
  (if (member x *standard-chars*)
      t
    nil))

(defun standard-char-listp (l)

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for a true list of standard characters~/

  ~c[(standard-char-listp x)] is true if and only if ~c[x] is a
  null-terminated list all of whose members are standard ~il[characters].
  ~l[standard-char-p].~/

  ~c[Standard-char-listp] has a ~il[guard] of ~c[t].

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard t))
  (cond ((consp l)
         (and (characterp (car l))
              (standard-char-p (car l))
              (standard-char-listp (cdr l))))
        (t (equal l nil))))


(defun character-listp (l)

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for a true list of characters~/

  The predicate ~c[character-listp] tests whether its argument is a
  true list of ~il[characters].

  To see the ACL2 definition of this function, ~pl[pf].~/~/"

  (declare (xargs :guard t))
  (cond ((atom l) (equal l nil))
        (t (and (characterp (car l))
                (character-listp (cdr l))))))

(defthm character-listp-forward-to-eqlable-listp
  (implies (character-listp x)
           (eqlable-listp x))
  :rule-classes :forward-chaining)

(defthm standard-char-listp-forward-to-character-listp
  (implies (standard-char-listp x)
           (character-listp x))
  :rule-classes :forward-chaining)

(defaxiom coerce-inverse-1
  (implies (character-listp x)
           (equal (coerce (coerce x 'string) 'list) x)))

; A "historical document" regarding standard characters:
;
; To: Kaufmann
; Subject: over strong axiom
; FCC: ~moore/old-mail
; --text follows this line--
; Axioms.lisp currently contains
;
; (defaxiom coerce-inverse-2
;   (implies (stringp x)
;            (equal (coerce (coerce x 'list) 'string) x)))
;
; But the guard for coerce (when the second argument is 'string) requires the first
; argument to be a standard-char-listp.  Thus, unless we know that (coerce x 'list)
; returns a standard-char-listp when (stringp x), the guard on the outer coerce is
; violated.
;
; If we are really serious that ACL2 strings may contain nonstandard chars, then
; this axiom is too strong.  I will leave this note in axioms.lisp and just go
; on.  But when the guard question is settled I would like to return to this and
; make explicit our occasional implicit assumption that strings are composed of
; standard chars.
;
; J

(defaxiom coerce-inverse-2
  (implies (stringp x)
           (equal (coerce (coerce x 'list) 'string) x)))

; Once upon a time, Moore (working alone) added the following axiom.

; (defaxiom standard-char-listp-coerce
;   (implies (stringp str)
;            (standard-char-listp (coerce str 'list))))

(defaxiom character-listp-coerce
  (character-listp (coerce str 'list))
  :rule-classes
  (:rewrite
   (:forward-chaining :trigger-terms
                      ((coerce str 'list)))))

; In AKCL the nonstandard character #\Page prints as ^L and may be included in
; strings, as in "^L".  Now if you try to type that string in ACL2, you get an
; error.  And ACL2 does not let you use coerce to produce the string, e.g.,
; with (coerce (list #\Page) 'string), because the guard for coerce is
; violated.  So here we have a situation in which no ACL2 function in LP will
; ever see a nonstandard char in a string, but CLTL permits it.  However, we
; consider the axiom to be appropriate, because ACL2 strings contain only
; standard characters.

(in-theory (disable standard-char-listp standard-char-p))

; (defthm standard-char-listp-coerce-forward-chaining
;
; ; If (stringp str) is in the context, we want to make a "note" that
; ; (coerce str 'list) is a standard-char-listp in case this fact is
; ; needed during later backchaining.  We see no need to forward chain
; ; from (standard-char-listp (coerce str 'list)), however; the rewrite
; ; rule generated here should suffice for relieving any such hypothesis.
;
;   (implies (stringp str)
;            (standard-char-listp (coerce str 'list)))
;   :rule-classes ((:forward-chaining :trigger-terms
;                                     ((coerce str 'list)))))

#+acl2-loop-only
(defun string (x)

  ":Doc-Section ACL2::ACL2-built-ins

  ~il[coerce] to a string~/

  ~c[(String x)] ~il[coerce]s ~c[x] to a string.  If ~c[x] is already a
  string, then it is returned unchanged; if ~c[x] is a symbol, then its
  ~ilc[symbol-name] is returned; and if ~c[x] is a character, the
  corresponding one-character string is returned.~/

  The ~il[guard] for ~c[string] requires its argument to be a string, a
  symbol, or a character.

  ~c[String] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard

; NOTE:  When we finally get hold of a definitive Common Lisp
; reference, let's clarify the statement near the bottom of p. 466 of
; CLtL2, which says:  "Presumably converting a character to a string
; always works according to this vote."  But we'll plunge ahead as
; follows, in part because we want to remain compliant with CLtL1,
; which isn't as complete as one might wish regarding which characters
; can go into strings.

                  (or (stringp x)
                      (symbolp x)
                      (characterp x))))
  (cond
   ((stringp x) x)
   ((symbolp x) (symbol-name x))
   (t (coerce (list x) 'string))))

#+acl2-loop-only
(defun alpha-char-p (x)

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for alphabetic characters~/

  ~c[(Alpha-char-p x)] is true if and only if ~c[x] is a alphabetic character,
  i.e., one of the ~il[characters] ~c[#\\a], ~c[#\\b], ..., ~c[#\\z], ~c[#\\A],
  ~c[#\\B], ..., ~c[#\\Z].~/

  The ~il[guard] for ~c[alpha-char-p] requires its argument to be a character.

  ~c[Alpha-char-p] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

; The following guard is required by p. 235 of CLtL.

  (declare (xargs :guard (characterp x)))
  (and (member x
               '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
                 #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z
                 #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M
                 #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z))
       t))

#+acl2-loop-only
(defun upper-case-p (x)

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for upper case characters~/

  ~c[(Upper-case-p x)] is true if and only if ~c[x] is an upper case character,
  i.e., a member of the list ~c[#\\A], ~c[#\\B], ..., ~c[#\\Z].~/

  The ~il[guard] for ~c[upper-case-p] requires its argument to be a standard
  character (~pl[standard-char-p]).

  ~c[Upper-case-p] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

; The guard characterp is required by p. 235 of CLtL.  However, In Allegro 6.0
; we see characters other than standard characters that are treated as upper
; case, such as (code-char (+ 128 65)).  So we strengthen that guard.

  (declare (xargs :guard (and (characterp x)
                              (standard-char-p x))))
  (and (member x
               '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M
                 #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z))
       t))

#+acl2-loop-only
(defun lower-case-p (x)

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for lower case characters~/

  ~c[(Lower-case-p x)] is true if and only if ~c[x] is a lower case character,
  i.e., a member of the list ~c[#\\A], ~c[#\\B], ..., ~c[#\\Z].~/

  The ~il[guard] for ~c[lower-case-p] requires its argument to be a standard
  character (~pl[standard-char-p]).

  ~c[Lower-case-p] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

; The guard characterp is required by p. 235 of CLtL.  However, In Allegro 6.0
; we see characters other than standard characters that are treated as upper
; case, such as (code-char (+ 128 65)).  So we strengthen that guard.

  (declare (xargs :guard (and (characterp x)
                              (standard-char-p x))))
  (and (member x
               '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
                 #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z))
       t))

#+acl2-loop-only
(defun char-upcase (x)

  ":Doc-Section ACL2::ACL2-built-ins

  turn lower-case ~il[characters] into upper-case ~il[characters]~/

  ~c[(Char-upcase x)] is equal to ~c[#\\A] when ~c[x] is ~c[#\\a], ~c[#\\B]
  when ~c[x] is ~c[#\\b], ..., and ~c[#\\Z] when ~c[x] is ~c[#\\z], and is
  ~c[x] for any other character.~/

  The ~il[guard] for ~c[char-upcase] requires its argument to be a standard
  character (~pl[standard-char-p]).

  ~c[Char-upcase] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

; The guard characterp is required by p. 231 of CLtL.  However, In Allegro 6.0
; we see characters other than standard characters that are treated as upper
; case, such as (code-char (+ 128 65)).  So we strengthen that guard.

  (declare (xargs :guard (and (characterp x)
                              (standard-char-p x))))
  (let ((pair (assoc x
                     '((#\a . #\A)
                       (#\b . #\B)
                       (#\c . #\C)
                       (#\d . #\D)
                       (#\e . #\E)
                       (#\f . #\F)
                       (#\g . #\G)
                       (#\h . #\H)
                       (#\i . #\I)
                       (#\j . #\J)
                       (#\k . #\K)
                       (#\l . #\L)
                       (#\m . #\M)
                       (#\n . #\N)
                       (#\o . #\O)
                       (#\p . #\P)
                       (#\q . #\Q)
                       (#\r . #\R)
                       (#\s . #\S)
                       (#\t . #\T)
                       (#\u . #\U)
                       (#\v . #\V)
                       (#\w . #\W)
                       (#\x . #\X)
                       (#\y . #\Y)
                       (#\z . #\Z)))))
    (cond (pair (cdr pair))
          ((characterp x) x)
          (t (code-char 0)))))

#+acl2-loop-only
(defun char-downcase (x)

  ":Doc-Section ACL2::ACL2-built-ins

  turn upper-case ~il[characters] into lower-case ~il[characters]~/

  ~c[(Char-downcase x)] is equal to ~c[#\\a] when ~c[x] is ~c[#\\A], ~c[#\\b]
  when ~c[x] is ~c[#\\B], ..., and ~c[#\\z] when ~c[x] is ~c[#\\Z], and is
  ~c[x] for any other character.~/

  The ~il[guard] for ~c[char-downcase] requires its argument to be a standard
  character (~pl[standard-char-p]).

  ~c[Char-downcase] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

; The guard characterp is required by p. 231 of CLtL.  However, In Allegro 6.0
; we see characters other than standard characters that are treated as upper
; case, such as (code-char (+ 128 65)).  So we strengthen that guard.

  (declare (xargs :guard (and (characterp x)
                              (standard-char-p x))))
    (let ((pair (assoc x
                       '((#\A . #\a)
                         (#\B . #\b)
                         (#\C . #\c)
                         (#\D . #\d)
                         (#\E . #\e)
                         (#\F . #\f)
                         (#\G . #\g)
                         (#\H . #\h)
                         (#\I . #\i)
                         (#\J . #\j)
                         (#\K . #\k)
                         (#\L . #\l)
                         (#\M . #\m)
                         (#\N . #\n)
                         (#\O . #\o)
                         (#\P . #\p)
                         (#\Q . #\q)
                         (#\R . #\r)
                         (#\S . #\s)
                         (#\T . #\t)
                         (#\U . #\u)
                         (#\V . #\v)
                         (#\W . #\w)
                         (#\X . #\x)
                         (#\Y . #\y)
                         (#\Z . #\z)))))
      (cond (pair (cdr pair))
            ((characterp x) x)
            (t (code-char 0)))))

(defthm lower-case-p-char-downcase
  (implies (and (upper-case-p x)
                (characterp x))
           (lower-case-p (char-downcase x))))

(defthm upper-case-p-char-upcase
  (implies (and (lower-case-p x)
                (characterp x))
           (upper-case-p (char-upcase x))))

(defthm lower-case-p-forward-to-alpha-char-p
  (implies (and (lower-case-p x)
                (characterp x))
           (alpha-char-p x))
  :rule-classes :forward-chaining)

(defthm upper-case-p-forward-to-alpha-char-p
  (implies (and (upper-case-p x)
                (characterp x))
           (alpha-char-p x))
  :rule-classes :forward-chaining)

(defthm alpha-char-p-forward-to-characterp
  (implies (alpha-char-p x)
           (characterp x))
  :rule-classes :forward-chaining)

(defthm characterp-char-downcase
  (characterp (char-downcase x))
  :rule-classes :type-prescription)

(defthm characterp-char-upcase
  (characterp (char-upcase x))
  :rule-classes :type-prescription)

; We disable the following functions in order to protect people from getting
; burned by their explosive definitions.
(in-theory (disable alpha-char-p upper-case-p lower-case-p
                    char-upcase char-downcase))

(defun string-downcase1 (l)
  (declare (xargs :guard (standard-char-listp l)
                  :guard-hints
                  (("Goal" :in-theory (enable standard-char-listp)))))
  (if (atom l)
      nil
    (cons (char-downcase (car l))
          (string-downcase1 (cdr l)))))

(defthm character-listp-string-downcase-1
  (character-listp (string-downcase1 x)))

#+acl2-loop-only
(defun string-downcase (x)

  ":Doc-Section ACL2::ACL2-built-ins

  in a given string, turn upper-case ~il[characters] into lower-case~/

  For a string ~c[x], ~c[(string-downcase x)] is the result of applying
  ~ilc[char-downcase] to each character in ~c[x].~/

  The ~il[guard] for ~c[string-downcase] requires its argument to be a string
  containing only standard characters.

  ~c[String-downcase] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (stringp x)
                              (standard-char-listp (coerce x 'list)))))

; As with other functions, e.g., reverse, the guards on this function
; can't currently be proved because the outer coerce below requires
; its argument to be made of standard characters.  We don't know that
; the string x is made of standard characters.

    (coerce (string-downcase1 (coerce x 'list)) 'string))

(defun string-upcase1 (l)
  (declare (xargs :guard (standard-char-listp l)
                  :guard-hints
                  (("Goal" :in-theory (enable standard-char-listp)))))
  (if (atom l)
      nil
    (cons (char-upcase (car l))
          (string-upcase1 (cdr l)))))

(defthm character-listp-string-upcase1-1
  (character-listp (string-upcase1 x)))

#+acl2-loop-only
(defun string-upcase (x)

  ":Doc-Section ACL2::ACL2-built-ins

  in a given string, turn lower-case ~il[characters] into upper-case~/

  For a string ~c[x], ~c[(string-upcase x)] is the result of applying
  ~ilc[char-upcase] to each character in ~c[x].~/

  The ~il[guard] for ~c[string-upcase] requires its argument to be a string
  containing only standard characters.

  ~c[String-upcase] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

    (declare (xargs :guard (and (stringp x)
                                (standard-char-listp (coerce x 'list)))))
    (coerce (string-upcase1 (coerce x 'list)) 'string))

(defun our-digit-char-p (ch radix)
  (declare (xargs :guard (and (characterp ch)
                              (integerp radix)
                              (<= 2 radix)
                              (<= radix 36))))
  (let ((l (assoc ch
                  '((#\0 . 0)
                    (#\1 . 1)
                    (#\2 . 2)
                    (#\3 . 3)
                    (#\4 . 4)
                    (#\5 . 5)
                    (#\6 . 6)
                    (#\7 . 7)
                    (#\8 . 8)
                    (#\9 . 9)
                    (#\a . 10)
                    (#\b . 11)
                    (#\c . 12)
                    (#\d . 13)
                    (#\e . 14)
                    (#\f . 15)
                    (#\g . 16)
                    (#\h . 17)
                    (#\i . 18)
                    (#\j . 19)
                    (#\k . 20)
                    (#\l . 21)
                    (#\m . 22)
                    (#\n . 23)
                    (#\o . 24)
                    (#\p . 25)
                    (#\q . 26)
                    (#\r . 27)
                    (#\s . 28)
                    (#\t . 29)
                    (#\u . 30)
                    (#\v . 31)
                    (#\w . 32)
                    (#\x . 33)
                    (#\y . 34)
                    (#\z . 35)
                    (#\A . 10)
                    (#\B . 11)
                    (#\C . 12)
                    (#\D . 13)
                    (#\E . 14)
                    (#\F . 15)
                    (#\G . 16)
                    (#\H . 17)
                    (#\I . 18)
                    (#\J . 19)
                    (#\K . 20)
                    (#\L . 21)
                    (#\M . 22)
                    (#\N . 23)
                    (#\O . 24)
                    (#\P . 25)
                    (#\Q . 26)
                    (#\R . 27)
                    (#\S . 28)
                    (#\T . 29)
                    (#\U . 30)
                    (#\V . 31)
                    (#\W . 32)
                    (#\X . 33)
                    (#\Y . 34)
                    (#\Z . 35)))))
    (cond ((and l (< (cdr l) radix))
           (cdr l))
          (t nil))))

#+acl2-loop-only
(defmacro digit-char-p (ch &optional (radix '10))

  ":Doc-Section ACL2::ACL2-built-ins

  the number, if any, corresponding to a given character~/

  ~c[(digit-char-p ch)] is the integer corresponding to the character
  ~c[ch] in base ~c[10].  For example, ~c[(digit-char-p #\\3)] is equal to
  the integer ~c[3].  More generally, an optional second argument
  specifies the radix (default ~c[10], as indicated above).~/

  The ~il[guard] for ~c[digit-char-p] (more precisely, for the function
  ~c[our-digit-char-p] that calls of this macro expand to) requires its
  second argument to be an integer between 2 and 36, inclusive, and
  its first argument to be a character.

  ~c[Digit-char-p] is a Common Lisp function, though it is implemented
  in the ACL2 logic as an ACL2 macro.  See any Common Lisp
  documentation for more information.~/"

  `(our-digit-char-p ,ch ,radix))

#+acl2-loop-only
(defun char-equal (x y)

  ":Doc-Section ACL2::ACL2-built-ins

  character equality without regard to case~/

  For ~il[characters] ~c[x] and ~c[y], ~c[(char-equal x y)] is true if and only if ~c[x]
  and ~c[y] are the same except perhaps for their case.~/

  The ~il[guard] on ~c[char-equal] requires that its arguments are both
  standard ~il[characters] (~pl[standard-char-p]).

  ~c[Char-equal] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (characterp x)
                              (standard-char-p x)
                              (characterp y)
                              (standard-char-p y))))
  (eql (char-downcase x)
       (char-downcase y)))

(defun atom-listp (lst)

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for a true list of ~il[atom]s~/

  The predicate ~c[atom-listp] tests whether its argument is a
  ~ilc[true-listp] of ~il[atom]s, i.e., of non-conses.~/

  Also ~pl[good-atom-listp].

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard t))
  (cond ((atom lst) (eq lst nil))
        (t (and (atom (car lst))
                (atom-listp (cdr lst))))))

(defthm atom-listp-forward-to-true-listp
  (implies (atom-listp x)
           (true-listp x))
  :rule-classes :forward-chaining)

(defthm eqlable-listp-forward-to-atom-listp
  (implies (eqlable-listp x)
           (atom-listp x))
  :rule-classes :forward-chaining)

(defun good-atom-listp (lst)

; Keep this in sync with bad-atom.

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for a true list of ``good'' ~il[atom]s~/

  The predicate ~c[good-atom-listp] tests whether its argument is a
  ~ilc[true-listp] of ``good'' ~il[atom]s, i.e., where each element is a
  number, a symbol, a character, or a string.~/

  Also ~pl[atom-listp].

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard t))
  (cond ((atom lst) (eq lst nil))
        (t (and (or (acl2-numberp (car lst))
                    (symbolp (car lst))
                    (characterp (car lst))
                    (stringp (car lst)))
                (good-atom-listp (cdr lst))))))

(defthm good-atom-listp-forward-to-atom-listp
  (implies (good-atom-listp x)
           (atom-listp x))
  :rule-classes :forward-chaining)

(defthm characterp-nth
  (implies (and (character-listp x)
                (<= 0 i)
                (< i (len x)))
           (characterp (nth i x))))

(defun ifix (x)

  ":Doc-Section ACL2::ACL2-built-ins

  coerce to an integer~/

  ~c[Ifix] simply returns any integer argument unchanged, returning ~c[0]
  on a non-integer argument.  Also ~pl[nfix], ~pl[rfix],
  ~pl[realfix] and ~pl[fix] for analogous functions that coerce to
  a natural number, a rational number, a real, and a number,
  respectively.~/

  ~c[Ifix] has a ~il[guard] of ~c[t].

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard t))
  (if (integerp x) x 0))

(defun rfix (x)

  ":Doc-Section ACL2::ACL2-built-ins

  coerce to a rational number~/

  ~c[Rfix] simply returns any rational number argument unchanged,
  returning ~c[0] on a non-rational argument.  Also ~pl[nfix],
  ~pl[ifix], ~pl[realfix], and ~pl[fix] for analogous
  functions that coerce to a natural number, an integer, a real, and a
  number, respectively.~/

  ~c[Rfix] has a ~il[guard] of ~c[t].

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard t))
  (if (rationalp x) x 0))

;; RAG - I added "realfix" to coerce numbers into reals.  I would have
;; liked to use "rfix" for it, but "rfix" was taken for the
;; rationals.  "ifix" as in "irrational-fix" would be a misnomer,
;; since it's the identity functions for rationals as well as
;; irrationals.  In desperation, we called it realfix, even though
;; that makes it more awkward to use than the other "fix" functions.

; Since the next function, realfix, is referred to by other :doc topics, do not
; make it conditional upon #+:non-standard-analysis.

(defun realfix (x)

  ":Doc-Section ACL2::ACL2-built-ins

  coerce to a real number~/

  ~c[Realfix] simply returns any real number argument unchanged,
  returning ~c[0] on a non-real argument.  Also ~pl[nfix],
  ~pl[ifix], ~pl[rfix], and ~pl[fix] for analogous functions
  that coerce to a natural number, an integer, a rational, and a
  number, respectively.~/

  ~c[Realfix] has a ~il[guard] of ~c[t].

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard t))
  (if (real/rationalp x) x 0))

(defun nfix (x)

  ":Doc-Section ACL2::ACL2-built-ins

  coerce to a natural number~/

  ~c[Nfix] simply returns any natural number argument unchanged,
  returning ~c[0] on an argument that is not a natural number.  Also
  ~pl[ifix], ~pl[rfix], ~pl[realfix], and ~pl[fix] for
  analogous functions that coerce to an integer, a rational number, a
  real, and a number, respectively.~/

  ~c[Nfix] has a ~il[guard] of ~c[t].

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard t))
  (if (and (integerp x) (>= x 0))
      x
    0))

(defun string-equal1 (str1 str2 i maximum)
  (declare (xargs :guard (and (stringp str1)
                              (standard-char-listp (coerce str1 'list))
                              (stringp str2)
                              (standard-char-listp (coerce str2 'list))
                              (integerp i)
                              (integerp maximum)
                              (<= maximum (length str1))
                              (<= maximum (length str2))
                              (<= 0 i)
                              (<= i maximum))

; We make this function :program until we know enough about o-p
; to prove its termination.

                  :mode :program))
  (let ((i (nfix i)))
    (cond
     ((>= i (ifix maximum))
      t)
     (t (and (char-equal (char str1 i)
                         (char str2 i))
             (string-equal1 str1 str2 (+ 1 i) maximum))))))

#+acl2-loop-only
(defun string-equal (str1 str2)

  ":Doc-Section ACL2::ACL2-built-ins

  string equality without regard to case~/

  For strings ~c[str1] and ~c[str2], ~c[(string-equal str1 str2)] is true if
  and only ~c[str1] and ~c[str2] are the same except perhaps for the cases of
  their ~il[characters].~/

  The ~il[guard] on ~c[string-equal] requires that its arguments are strings
  consisting of standard characters (~pl[standard-char-listp]).

  ~c[String-equal] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (stringp str1)
                              (standard-char-listp (coerce str1 'list))
                              (stringp str2)
                              (standard-char-listp (coerce str2 'list)))
                  :mode :program))
  (let ((len1 (length str1)))
    (and (= len1 (length str2))
         (string-equal1 str1 str2 0 len1))))

(defun standard-string-alistp (x)

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for association lists with standard strings as keys~/

  ~c[(Standard-string-alistp x)] is true if and only if ~c[x] is a list of
  pairs of the form ~c[(cons key val)] where ~c[key] is a string all of whose
  characters are standard (~pl[standard-char-p]).~/

  ~c[Standard-string-alistp] has a ~il[guard] of ~c[t].

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard t))
  (cond ((atom x) (eq x nil))
        (t (and (consp (car x))
                (stringp (car (car x)))
                (standard-char-listp (coerce (car (car x)) 'list))
                (standard-string-alistp (cdr x))))))

(defthm standard-string-alistp-forward-to-alistp
  (implies (standard-string-alistp x)
           (alistp x))
  :rule-classes :forward-chaining)

(defun assoc-string-equal (str alist)

  ":Doc-Section ACL2::ACL2-built-ins

  look up key, a string, in association list~/

  ~c[(Assoc-string-equal x alist)] is similar to ~ilc[assoc-equal].
  However, for string ~c[x] and alist ~c[alist], the comparison of ~c[x]
  with successive keys in ~c[alist] is done using ~ilc[string-equal]
  rather than ~ilc[equal].~/

  The ~il[guard] for ~c[assoc-string-equal] requires that ~c[x] is a string
  and ~c[alist] is an alist.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (stringp str)
                              (standard-char-listp (coerce str 'list))
                              (standard-string-alistp alist))
                  :mode :program))
  (cond
   ((endp alist)
    nil)
   ((string-equal str (car (car alist)))
    (car alist))
   (t (assoc-string-equal str (cdr alist)))))

; Ordinal stuff.  It seems more or less impossible to get o<g and o< admitted
; during boot-strapping unless we cheat by declaring them explicitly :mode
; :logic so that they will be admitted in the first pass of the build.  But
; then we also need to declare functions on which they depend to be :mode
; :logic as well (since :logic mode functions cannot have :program mode
; functions in their bodies).

;first: we mention the old ordinals:

(defdoc e0-ordinalp
  ":Doc-Section ACL2::ACL2-built-ins

   the old recognizer for ACL2 ordinals~/

   ~l[o-p] for the current recognizer for ACL2 ordinals.~/

   The functions ~c[e0-ordinalp] and ~ilc[e0-ord-<] were replaced in ACL2
   Version_2.8 by ~ilc[o-p] and ~ilc[o<], respectively.  However, books created
   before that version used the earlier functions for termination proofs; the
   old functions might be of use in these cases.  To use the old functions in
   termination proofs, include the community book ~c[books/ordinals/e0-ordinal]
   and execute the event ~c[(set-well-founded-relation e0-ord-<)]
   (~pl[set-well-founded-relation]).  For a more thorough discussion of
   these functions, see the documentation at the end of community book
   ~c[books/ordinals/e0-ordinal.lisp].")

(defdoc e0-ord-<
  ":Doc-Section ACL2::ACL2-built-ins

   the old ordering function for ACL2 ordinals~/

   ~l[o<] for the current new ordering function for ACL2 ordinals.~/

   The functions ~c[e0-ordinalp] and ~ilc[e0-ord-<] were replaced in ACL2
   Version_2.8 by ~ilc[o-p] and ~ilc[o<], respectively.  However, books created
   before that version used the earlier functions for termination proofs; the
   old functions might be of use in these cases.  To use the old functions in
   termination proofs, include the community book ~c[books/ordinals/e0-ordinal]
   and execute the event ~c[(set-well-founded-relation e0-ord-<)]
   (~pl[set-well-founded-relation]).  For a more thorough discussion of
   these functions, see the documentation at the end of community book
   ~c[books/ordinals/e0-ordinal.lisp].")

(defun natp (x)

  ":Doc-Section ACL2::ACL2-built-ins

   a recognizer for the natural numbers~/~/

  The natural numbers is the set of all non-negative integers,
  ~c[{0,1,2,3,...}].  ~c[Natp] returns ~c[t] if and only its argument is a
  natural number, and ~c[nil] otherwise.  We recommend the community book
  ~c[books/arithmetic/natp-posp.lisp] as a book for reasoning about ~c[posp]
  and ~c[natp].  This book is included by community books
  ~c[books/arithmetic/top] and ~c[books/arithmetic/top-with-meta].

  To see the ACL2 definition of this function, ~pl[pf]."

  (declare (xargs :guard t :mode :logic))
  (and (integerp x)
       (<= 0 x)))

(defthm natp-compound-recognizer
  (equal (natp x)
         (and (integerp x)
              (<= 0 x)))
  :rule-classes :compound-recognizer)

(defun posp (x)
  ":Doc-Section ACL2::ACL2-built-ins

   a recognizer for the positive integers~/~/

  ~c[(posp x)] is logically equivalent to ~c[(not (zp x))] (~pl[zp]) and also
  to ~c[(and (natp x) (not (equal x 0)))].  We recommend the community book
  ~c[books/ordinals/natp-posp] for reasoning about ~c[posp] and ~c[natp].  This
  book is included by community books ~c[books/arithmetic/top] and
  ~c[books/arithmetic/top-with-meta].

  To see the ACL2 definition of this function, ~pl[pf]."

  (declare (xargs :guard t :mode :logic))
  (and (integerp x)
       (< 0 x)))

(defthm posp-compound-recognizer
  (equal (posp x)
         (and (integerp x)
              (< 0 x)))
  :rule-classes :compound-recognizer)

(defun o-finp (x)
  ":Doc-Section ACL2::ACL2-built-ins

  recognizes if an ordinal is finite~/~/

  We introduce the function ~c[o-finp] which returns ~c[t] for any ordinal that
  is finite, else ~c[nil].  This function is equivalent to the function
  ~ilc[atom], and is introduced so that we can ~ilc[disable] its definition
  when dealing with ordinals (also ~pl[make-ord]).

  To see the ACL2 definition of this function, ~pl[pf]."

  (declare (xargs :guard t :mode :logic))
  (atom x))

(defmacro o-infp (x)
  ":Doc-Section ACL2::ACL2-built-ins

  recognizes if an ordinal is infinite~/~/

  ~c[O-infp] is a macro.  ~c[(O-infp x)] opens up to ~c[(not (o-finp x))]
  (~pl[o-finp])."

  `(not (o-finp ,x)))

(defun o-first-expt (x)
  ":Doc-Section ACL2::ACL2-built-ins

  the first exponent of an ordinal~/~/

  An ACL2 ordinal is either a natural number or, for an infinite ordinal, a
  list whose elements are exponent-coefficient pairs (~pl[o-p]).  In the latter
  case, this function returns the ~ilc[car] of the first pair in the list.  In
  the case of a natural number, the value returned is 0 (since a natural
  number, ~c[n], can be thought of as (w^0)n).

  For the corresponding coefficient, ~pl[o-first-coeff].

  To see the ACL2 definition of this function, ~pl[pf]."

  (declare (xargs :guard (or (o-finp x) (consp (car x))) :mode :logic))
  (if (o-finp x)
      0
    (caar x)))

(defun o-first-coeff (x)
  ":Doc-Section ACL2::ACL2-built-ins

  returns the first coefficient of an ordinal~/~/

  An ACL2 ordinal is either a natural number or, for an infinite ordinal, a
  list whose elements are exponent-coefficient pairs (~pl[o-p]).  In the latter
  case, this function returns the ~ilc[cdr] of the first pair in the list.  In
  the case of a natural number, this function returns the ordinal itself
  (since a natural number, n, can be thought of as (w^0)n).

  For the corresponding exponent, ~pl[o-first-expt].

  To see the ACL2 definition of this function, ~pl[pf]."

  (declare (xargs :guard (or (o-finp x) (consp (car x))) :mode :logic))
  (if (o-finp x)
      x
    (cdar x)))

(defun o-rst (x)
  ":Doc-Section ACL2::ACL2-built-ins

  returns the rest of an infinite ordinal~/~/

  An ACL2 infinite ordinal is a list whose elements are exponent-coefficient
  pairs (~pl[o-p] and ~pl[o-infp]).  The first exponent and first coefficient
  of an ordinal can be obtained by using ~ilc[o-first-expt] and
  ~ilc[o-first-coeff] respectively.  To obtain the rest of the ordinal (for
  recursive analysis), use the ~c[o-rst] function. It returns the rest of the
  ordinal after the first exponent and coefficient are removed.

  To see the ACL2 definition of this function, ~pl[pf]."

  (declare (xargs :guard (consp x) :mode :logic))
  (cdr x))

(defun o<g (x)

; This function is used only for guard proofs.

  (declare (xargs :guard t :mode :logic))
  (if (atom x)
      (rationalp x)
    (and (consp (car x))
         (rationalp (o-first-coeff x))
         (o<g (o-first-expt x))
         (o<g (o-rst x)))))

(defun o< (x y)

  ":Doc-Section ACL2::ACL2-built-ins

   the well-founded less-than relation on ordinals up to ~c[epsilon-0]~/

   If ~c[x] and ~c[y] are both ~c[o-p]s (~pl[o-p]) then
   ~c[(o< x y)] is true iff ~c[x] is strictly less than ~c[y].  ~c[o<] is
   well-founded on the ~ilc[o-p]s.  When ~c[x] and ~c[y] are both nonnegative
   integers, ~c[o<] is just the familiar ``less than'' relation (~ilc[<]).~/

   ~c[o<] plays a key role in the formal underpinnings of the ACL2
   logic.  In order for a recursive definition to be admissible it must
   be proved to ``terminate.''  By terminate we mean that the arguments to
   the function ``get smaller'' as the function recurses and this sense
   of size comparison must be such that there is no ``infinitely
   descending'' sequence of ever smaller arguments.  That is, the
   relation used to compare successive arguments must be well-founded
   on the domain being measured.

   The most basic way ACL2 provides to prove termination requires the
   user to supply (perhaps implicitly) a mapping of the argument tuples
   into the ordinals with some ``measure'' expression in such a way
   that the measures of the successive argument tuples produced by
   recursion decrease according to the relation ~c[o<].  The validity
   of this method rests on the well-foundedness of ~c[o<] on the
   ~ilc[o-p]s.

   Without loss of generality, suppose the definition in question
   introduces the function ~c[f], with one formal parameter ~c[x] (which might
   be a list of objects).  Then we require that there exist a measure
   expression, ~c[(m x)], that always produces an ~ilc[o-p].
   Furthermore, consider any recursive call, ~c[(f (d x))], in the body of
   the definition.  Let ~c[hyps] be the conjunction of terms, each of which is
   either the test of an ~ilc[if] in the body or else the negation of such a
   test, describing the path through the body to the recursive call in
   question.  Then it must be a theorem that
   ~bv[]
     (IMPLIES hyps (O< (m (d x)) (m x))).
   ~ev[]
   When we say ~c[o<] is ``well-founded'' on the ~ilc[o-p]s we
   mean that there is no infinite sequence of ~ilc[o-p]s such that
   each is smaller than its predecessor in the sequence.  Thus, the
   theorems that must be proved about ~c[f] when it is introduced establish
   that it cannot recur forever because each time a recursive call is
   taken ~c[(m x)] gets smaller.  From this, and the syntactic restrictions
   on definitions, it can be shown (as on page 44 in ``A Computational
   Logic'', Boyer and Moore, Academic Press, 1979) that there exists a
   function satisfying the definition; intuitively, the value assigned
   to any given ~c[x] by the alleged function is that computed by a
   sufficiently large machine.  Hence, the logic is consistent if the
   axiom defining ~c[f] is added.

   ~l[o-p] for a discussion of the ordinals and how to
   compare two ordinals.

   The definitional principle permits the use of relations other than
   ~c[o<] but they must first be proved to be well-founded on some
   domain.  ~l[well-founded-relation].  Roughly put, alternative
   relations are shown well-founded by providing an order-preserving
   mapping from their domain into the ordinals.  ~l[defun] for
   details on how to specify which well-founded relation is to be
   used.

  To see the ACL2 definition of this function, ~pl[pf]."
  (declare (xargs :guard (and (o<g x) (o<g y)) :mode :logic))
  (cond ((o-finp x)
         (or (o-infp y) (< x y)))
        ((o-finp y) nil)
        ((not (equal (o-first-expt x) (o-first-expt y)))
         (o< (o-first-expt x) (o-first-expt y)))
        ((not (= (o-first-coeff x) (o-first-coeff y)))
         (< (o-first-coeff x) (o-first-coeff y)))
        (t (o< (o-rst x) (o-rst y)))))

(defmacro o> (x y)
  ":Doc-Section ACL2::ACL2-built-ins

  the greater-than relation for the ordinals~/~/

  ~c[O>] is a macro and ~c[(o> x y)] expands to ~c[(o< y x)].  ~l[o<]."

  `(o< ,y ,x))

(defmacro o<= (x y)
  ":Doc-Section ACL2::ACL2-built-ins

  the less-than-or-equal relation for the ordinals~/~/

  ~c[o<=] is a macro and ~c[(o<= x y)] expands to ~c[(not (o< y x))].  ~l[o<]."

  `(not (o< ,y ,x)))

(defmacro o>= (x y)
  ":Doc-Section ACL2::ACL2-built-ins

  the greater-than-or-equal relation for the ordinals~/~/

  ~c[O>=] is a macro and ~c[(o>= x y)] expands to ~c[(not (o< x y))].  ~l[o<]."

  `(not (o< ,x ,y)))

(defun o-p (x)

  ":Doc-Section ACL2::ACL2-built-ins

   a recognizer for the ordinals up to epsilon-0~/

   Using the nonnegative integers and lists we can represent the ordinals up to
   ~c[epsilon-0]. The ordinal representation used in ACL2 has changed as
   of Version_2.8 from that of Nqthm-1992, courtesy of Pete Manolios and Daron
   Vroon; additional discussion may be found in ``Ordinal Arithmetic in ACL2'',
   proceedings of ACL2 Workshop 2003,
   ~url[http://www.cs.utexas.edu/users/moore/acl2/workshop-2003/].  Previously,
   ACL2's notion of ordinal was very similar to the development given in ``New
   Version of the Consistency Proof for Elementary Number Theory'' in The
   Collected Papers of Gerhard Gentzen, ed. M.E. Szabo, North-Holland
   Publishing Company, Amsterdam, 1969, pp 132-213.~/

   The following essay is intended to provide intuition about ordinals.
   The truth, of course, lies simply in the ACL2 definitions of
   ~c[o-p] and ~ilc[o<].

   Very intuitively, think of each non-zero natural number as by being
   denoted by a series of the appropriate number of strokes, i.e.,
   ~bv[]
   0             0
   1             |
   2             ||
   3             |||
   4             ||||
   ...           ...
   ~ev[]
   Then ``~c[omega],'' here written as ~c[w], is the ordinal that might be
   written as
   ~bv[]
   w             |||||...,
   ~ev[]
   i.e., an infinite number of strokes.  Addition here is just
   concatenation.  Observe that adding one to the front of ~c[w] in the
   picture above produces ~c[w] again, which gives rise to a standard
   definition of ~c[w]:  ~c[w] is the least ordinal such that adding another
   stroke at the beginning does not change the ordinal.

   We denote by ~c[w+w] or ~c[w*2] the ``~c[doubly infinite]'' sequence that we
   might write as follows.
   ~bv[]
   w*2           |||||... |||||...
   ~ev[]
   One way to think of ~c[w*2] is that it is obtained by replacing each
   stroke in ~c[2] ~c[(||)] by ~c[w].  Thus, one can imagine ~c[w*3], ~c[w*4], etc., which
   leads ultimately to the idea of ``~c[w*w],'' the ordinal obtained by
   replacing each stroke in ~c[w] by ~c[w].  This is also written as ``~c[omega]
   squared'' or ~c[w^2], or:
   ~bv[]
    2
   w             |||||... |||||... |||||... |||||... |||||... ...
   ~ev[]
   We can analogously construct ~c[w^3] by replacing each stroke in ~c[w] by
   ~c[w^2] (which, it turns out, is the same as replacing each stroke in
   ~c[w^2] by ~c[w]).  That is, we can construct ~c[w^3] as ~c[w] copies of ~c[w^2],
   ~bv[]
    3              2       2       2       2
   w              w  ...  w  ...  w  ...  w ... ...
   ~ev[]
   Then we can construct ~c[w^4] as ~c[w] copies of ~c[w^3], ~c[w^5] as ~c[w] copies of
   ~c[w^4], etc., ultimately suggesting ~c[w^w].  We can then stack ~c[omega]s,
   i.e., ~c[(w^w)^w] etc.  Consider the ``limit'' of all of those stacks,
   which we might display as follows.
   ~bv[]
          .
         .
        .
       w
      w
     w
    w
   w
   ~ev[]
   That is epsilon-0.

   Below we begin listing some ordinals up to ~c[epsilon-0]; the reader can
   fill in the gaps at his or her leisure.  We show in the left column
   the conventional notation, using ~c[w] as ``~c[omega],'' and in the right
   column the ACL2 object representing the corresponding ordinal.
   ~bv[]
     ordinal            ACL2 representation

     0                  0
     1                  1
     2                  2
     3                  3
     ...                ...
     w                 '((1 . 1) . 0)
     w+1               '((1 . 1) . 1)
     w+2               '((1 . 1) . 2)
     ...                ...
     w*2               '((1 . 2) . 0)
     (w*2)+1           '((1 . 2) . 1)
     ...                ...
     w*3               '((1 . 3) . 0)
     (w*3)+1           '((1 . 3) . 1)
     ...                ...

      2
     w                 '((2 . 1) . 0)
     ...                ...

      2
     w +w*4+3          '((2 . 1) (1 . 4) . 3)
     ...                ...

      3
     w                 '((3 . 1) . 0)
     ...                ...


      w
     w                 '((((1 . 1) . 0) . 1) . 0)
     ...                ...

      w  99
     w +w  +w4+3       '((((1 . 1) . 0) . 1) (99 . 1) (1 . 4) . 3)
     ...                ...

       2
      w
     w                 '((((2 . 1) . 0) . 1) . 0)

     ...                ...

       w
      w
     w                 '((((((1 . 1) . 0) . 1) . 0) . 1) . 0)
     ...               ...
   ~ev[]
   Observe that the sequence of ~c[o-p]s starts with the natural
   numbers (which are recognized by ~ilc[natp]). This is convenient
   because it means that if a term, such as a measure expression for
   justifying a recursive function (~pl[o<]) must produce an ~c[o-p],
   it suffices for it to produce a natural number.

   The ordinals listed above are listed in ascending order.  This is
   the ordering tested by ~ilc[o<].

   The ``~c[epsilon-0] ordinals'' of ACL2 are recognized by the recursively
   defined function ~c[o-p].  The base case of the recursion tells us that
   natural numbers are ~c[epsilon-0] ordinals.  Otherwise, an ~c[epsilon-0]
   ordinal is a list of ~ilc[cons] pairs whose final ~ilc[cdr] is a natural
   number, ~c[((a1 . x1) (a2 . x2) ... (an . xn) . p)].  This corresponds to
   the ordinal ~c[(w^a1)x1 + (w^a2)x2 + ... + (w^an)xn + p].  Each ~c[ai] is an
   ordinal in the ACL2 representation that is not equal to 0.  The sequence of
   the ~c[ai]'s is strictly decreasing (as defined by ~ilc[o<]). Each ~c[xi]
   is a positive integer (as recognized by ~ilc[posp]).

   Note that infinite ordinals should generally be created using the ordinal
   constructor, ~ilc[make-ord], rather than ~ilc[cons]. The functions
   ~ilc[o-first-expt], ~ilc[o-first-coeff], and ~ilc[o-rst] are ordinals
   destructors.  Finally, the function ~ilc[o-finp] and the macro ~ilc[o-infp]
   tell whether an ordinal is finite or infinite, respectively.

   The function ~ilc[o<] compares two ~c[epsilon-0] ordinals, ~c[x] and ~c[y].
   If both are integers, ~c[(o< x y)] is just ~c[x<y].  If one is an integer
   and the other is a ~ilc[cons], the integer is the smaller.  Otherwise,
   ~ilc[o<] recursively compares the ~ilc[o-first-expt]s of the ordinals to
   determine which is smaller.  If they are the same, the ~ilc[o-first-coeff]s
   of the ordinals are compared.  If they are equal, the ~ilc[o-rst]s of the
   ordinals are recursively compared.

   Fundamental to ACL2 is the fact that ~ilc[o<] is well-founded on
   ~c[epsilon-0] ordinals.  That is, there is no ``infinitely descending
   chain'' of such ordinals.  ~l[proof-of-well-foundedness].

  To see the ACL2 definition of this function, ~pl[pf]."

  (declare (xargs :guard t
                  :verify-guards nil))
  (if (o-finp x)
      (natp x)
    (and (consp (car x))
         (o-p (o-first-expt x))
         (not (eql 0 (o-first-expt x)))
         (posp (o-first-coeff x))
         (o-p (o-rst x))
         (o< (o-first-expt (o-rst x))
             (o-first-expt x)))))

(defthm o-p-implies-o<g
  (implies (o-p a)
           (o<g a)))

(verify-guards o-p)

(defun make-ord (fe fco rst)

  ":Doc-Section ACL2::ACL2-built-ins

  a constructor for ordinals.~/

  ~c[Make-ord] is the ordinal constructor.  Its use is recommended instead of
  using ~ilc[cons] to make ordinals.  For a discussion of ordinals,
  ~pl[ordinals].~/

  For any ordinal, ~c[alpha < epsilon-0], there exist natural numbers ~c[p] and
  ~c[n], positive integers ~c[x1, x2, ..., xn] and ordinals
  ~c[a1 > a2 > ... > an > 0] such that ~c[alpha > a1] and
  ~c[alpha = w^(a1)x1 + w^(a2)x2 + ... + w^(an)xn + p].  We call ~c[a1] the ``first
  exponent'', ~c[x1] the ``first coefficient'', and the remainder
  ~c[(w^(a2)x2 + ... + w^(an)xn + p)] the ``rest'' of alpha.

  ~c[(Make-ord fe fco rst)] corresponds to the ordinal
  ~c[(w^fe)fco + rst].  Thus the first infinite ordinal, ~c[w] (~c[omega]), is
  constructed by
  ~bv[]
  (make-ord 1 1 0)
  ~ev[]
  and, for example, the ordinal ~c[(w^2)5 + w2 + 7] is constructed by:
  ~bv[]
  (make-ord 2 5 (make-ord 1 2 7)) .
  ~ev[]

  The reason ~c[make-ord] is used rather than ~ilc[cons] is that it
  allows us to reason more abstractly about the ordinals, without
  having to worry about the underlying representation.

  To see the ACL2 definition of this function, ~pl[pf]."

  (declare (xargs :guard (and (posp fco)
                              (o-p fe)
                              (o-p rst))))
  (cons (cons fe fco) rst))

(defun list*-macro (lst)
  (declare (xargs :guard (and (true-listp lst)
                              (consp lst))))
  (if (endp (cdr lst))
      (car lst)
      (cons 'cons
            (cons (car lst)
                  (cons (list*-macro (cdr lst)) nil)))))

#+acl2-loop-only
(defmacro list* (&rest args)

  ":Doc-Section ACL2::ACL2-built-ins

  build a list~/

  ~c[List*] is the Common Lisp macro for building a list of objects from
  given elements and a tail.  For example, ~c[(list* 5 6 '(7 8 9))] equals
  the list ~c['(5 6 7 8 9)].  Also ~pl[list].~/

  ~c[List*] is a Common Lisp function.  See any Common Lisp
  documentation for more information.~/"

  (declare (xargs :guard (consp args)))
  (list*-macro args))

#-acl2-loop-only
(progn

(defmacro throw-without-attach (ignored-attachment fn formals)
  `(throw-raw-ev-fncall
    (list* 'ev-fncall-null-body-er
           ,ignored-attachment
           ',fn
           (print-list-without-stobj-arrays (list ,@formals)))))

(defvar *aokp*

; We set *aokp* to t simply so that we can use attachments in raw Lisp.  It
; will be bound suitably inside the ACL2 loop by calls of raw-ev-fncall.

  t)

(defmacro aokp ()
  '*aokp*)

#+hons
(defvar *attached-fn-called* nil)

#+hons
(defmacro update-attached-fn-called (fn)
  `(when (null *attached-fn-called*)
     (setq *attached-fn-called* ,fn)))

(defmacro throw-or-attach (fn formals &optional *1*-p)

; Warning: this macro assumes that (attachment-symbol fn) is special and, more
; important, bound.  So it is probably best to lay down calls of of this macro
; using throw-or-attach-call.

  (let ((at-fn (attachment-symbol fn))
        (at-fn-var (gensym)))

; It is tempting to insert the form (eval `(defvar ,at-fn nil)) here.  But that
; would only be evaluated at compile time.  When loading a compiled file on
; behalf of including a book, this eval call would no longer be around; it
; would instead have been executed during compilation.  The Warning above is
; intended to guarantee that at-fn has already been both declared special and
; bound.

    `(let ((,at-fn-var ,at-fn)) ; to look up special var value only once
       (cond ((and ,at-fn-var (aokp))
              #+hons
              (update-attached-fn-called ',fn)
              (funcall ,(if *1*-p
                            `(*1*-symbol ,at-fn-var)
                          at-fn-var)
                       ,@formals))
             (t (throw-without-attach ,at-fn ,fn ,formals))))))

)

(defun throw-or-attach-call (fn formals)

; A call of throw-or-attach assumes that the attachment-symbol is special and,
; more importantly, bound.  So we ensure that property here.

; It's a bit subtle why this approach works.  Indeed, consider the following
; example.  Suppose the book foo.lisp has the just following two forms.

;   (in-package "ACL2")
;   (encapsulate ((foo (x) t)) (local (defun foo (x) x)))

; Now certify the book, with (certify-book "foo"), and then in a new session:

;   :q
;   (load "foo")
;   (boundp (attachment-symbol 'foo))

; Then boundp call returns nil.  If instead we do this in a new session

;   (include-book "foo")
;   :q
;   (boundp (attachment-symbol 'foo))

; then the boundp call returns t.  This is not surprising, since we can see by
; tracing throw-or-attach-call that it is being called, thus defining the
; attachment-symbol.

; There might thus seem to be the following possibility of errors due to
; unbound attachment-symbols.  Suppose that foo were called before its
; attachment-symbol is defined by evaluation of the above encapsulate form in
; the loop, say, during the early load of the compiled file for foo.lisp on
; behalf of include-book.  Then an error would occur, because the
; attachment-symbol for foo would not yet be defined.  However, the only way we
; can imagine this case occurring for a certified book is if foo gets an
; attachment before it is called (else the book wouldn't have been
; certifiable).  Yet in raw Lisp, defattach calls defparameter for the
; attachment-symbol for every function receiving an attachment, thus avoiding
; the possibility of this proposed problem of unbound attachment-symbols.

  (declare (xargs :guard t))
  #-acl2-loop-only
  (eval `(defvar ,(attachment-symbol fn) nil))
  (list 'throw-or-attach fn formals))

(defun null-body-er (fn formals maybe-attach)
  (declare (xargs :guard t))
  (if maybe-attach
      (throw-or-attach-call fn formals)
    (list 'throw-without-attach nil fn formals)))

; CLTL2 and the ANSI standard have made the main Lisp package name be
; COMMON-LISP rather than the older LISP.  Before Version_2.6 we
; handled this discrepancy in a way that could be said to be unsound.
; For example, one could prove (equal (symbol-package-name 'car)
; "LISP") in an ACL2 built on top of GCL, then prove (equal
; (symbol-package-name 'car) "COMMON-LISP")) in an ACL2 built on top
; of Allegro CL.  Thus, one could certify a book with the former
; theorem in a GCL-based ACL2, then include that book in an
; Allegro-based ACL2 and prove NIL.  Our solution is to make the
; "LISP" package look like "COMMON-LISP" from the perspective of ACL2,
; for example: (symbol-package-name 'car) = "COMMON-LISP".

; Warning: If you change the following, change the corresponding line in the
; defparameter for *ever-known-package-alist* above, consider changing
; symbol-package-name, and perhaps adjust the check for "LISP" in defpkg-fn.

(defconst *main-lisp-package-name*
; Keep this in sync with *main-lisp-package-name-raw*.
  "COMMON-LISP")

; Warning: If you add primitive packages to this list, be sure to add
; the defaxioms that would be done by defpkg.  For example, below you
; will find a defaxiom for ACL2-INPUT-CHANNEL-PACKAGE and any new
; package should have an analogous axiom added.  Each of the primitive
; packages below has such an axiom explicitly added in axioms.lisp
; (except for the main lisp package name, whose import list is
; essentially unknown).

; Warning:  Keep the initial value of the following constant identical to
; that of the raw lisp defparameter *ever-known-package-alist* above.

(defconst *initial-known-package-alist*
  (list (make-package-entry :name "ACL2-INPUT-CHANNEL"
                            :imports nil)
        (make-package-entry :name "ACL2-OUTPUT-CHANNEL"
                            :imports nil)
        (make-package-entry :name "ACL2"
                            :imports *common-lisp-symbols-from-main-lisp-package*)
        (make-package-entry :name *main-lisp-package-name*

; From a logical perspective, ACL2 pretends that no symbols are imported into
; the main Lisp package, "COMMON-LISP".  This perspective is implemented by
; bad-lisp-objectp, as described in a comment there about maintaining the
; Invariant on Symbols in the Common Lisp Package.  In short, every good ACL2
; symbol not in a package known to ACL2 must be imported into the main Lisp
; package and must have "COMMON-LISP" as its *initial-lisp-symbol-mark*
; property.

                            :imports nil)
        (make-package-entry :name "KEYWORD"
                            :imports nil)))

(defaxiom stringp-symbol-package-name
  (stringp (symbol-package-name x))
  :rule-classes :type-prescription)

(defaxiom symbolp-intern-in-package-of-symbol
  (symbolp (intern-in-package-of-symbol x y))
  :rule-classes :type-prescription)

(defaxiom symbolp-pkg-witness
  (symbolp (pkg-witness x))
  :rule-classes :type-prescription)

#-acl2-loop-only
(defparameter *ld-level*

; This parameter will always be equal to the number of recursive calls of LD
; and/or WORMHOLE we are in.  Since each pushes a new frame on
; *acl2-unwind-protect-stack* the value of *ld-level* should always be the
; length of the stack.  But *ld-level* is maintained as a special, i.e., it is
; always bound when we enter LD while the stack is a global.  An abort may
; possibly rip us out of a call of LD, causing *ld-level* to decrease but not
; affecting the stack.  It is this violation of the "invariant" between the two
; that indicates that the stack must be unwound some (to cleanup after an
; aborted inferior).

; Parallelism blemish: This variable is let-bound in ld-fn (and hence by
; wormhole).  Perhaps this could present a problem.  For example, we wonder
; about the case where waterfall-parallelism is enabled and a parent thread
; gets confused about the value of *ld-level* (or (@ ld-level)) when changed by
; the child thread.  For a second example, we can imagine (and we may have
; seen) a case in which there are two threads doing rewriting, and one does a
; throw (say, because time has expired), which puts the two threads temporarily
; out of sync in their values of *ld-level*.  Wormholes involve calls of ld and
; hence also give us concern.  As of this writing we know of no cases where any
; such problems exist, and there is at least one case, the definition of
; mt-future, where we explicitly provide bindings to arrange that a child
; thread receives its *ld-level* and (@ ld-level) from its parent (not from
; some spurious global values).  Mt-future also has an assertion to check that
; we keep *ld-level* and (@ ld-level) in sync with each other.

  0)

; For an explanation of the next defvar, see the comment in
; hard-error, below.

#-acl2-loop-only
(defvar *hard-error-returns-nilp* nil)

#-acl2-loop-only
(defun-one-output throw-raw-ev-fncall (val)

; This function just throws to raw-ev-fncall (or causes an
; interface-er if there is no raw-ev-fncall).  The coding below
; actually assumes that we are in a raw-ev-fncall if *ld-level* > 0.

; This assumption may not be entirely true.  If we have a bug in our
; LD code, e.g., in printing the prompt, we could throw to a
; nonexistent tag.  We might get the GCL

; Error: The tag RAW-EV-FNCALL is undefined.

  (cond ((or (= *ld-level* 0)
             (raw-mode-p *the-live-state*))
         (interface-er "~@0"
                       (ev-fncall-msg val
                                      (w *the-live-state*)
                                      (user-stobj-alist *the-live-state*))))
        (t
         (throw 'raw-ev-fncall val))))

(defun hard-error (ctx str alist)

; Logically, this function just returns nil.  The implementation
; usually signals a hard error, which is sound since it is akin to
; running out of stack or some other resource problem.

; But if this function is called as part of a proof, e.g.,
; (thm (equal (car (cons (hard-error 'ctx "Test" nil) y)) nil))
; we do not want to cause an error!  (Note:  the simpler example
; (thm (equal (hard-error 'ctx "Test" nil) nil)) can be proved
; without any special handling of the executable counterpart of
; hard-error, because we know its type-set is *ts-nil*.  So to cause
; an error, you have to have the hard-error term used in a place
; where type-reasoning alone won't do the job.)

; Sometimes hard-error is used in the guard of a function, e.g.,
; illegal.  Generally evaluating that guard is to signal an error.
; But if guard-checking-on is nil, then we want to cause no error and
; just let the guard return nil.  We evaluate the guard even when
; guard-checking-on is nil (though not for user-defined functions when
; it is :none) so we know whether to call the raw Lisp version or the
; ACL2_*1*_ACL2 version of a function.

; Logically speaking the two behaviors of hard-error, nil or error,
; are indistinguishable.  So we can choose which behavior we want
; without soundness concerns.  Therefore, we have a raw Lisp special
; variable, named *hard-error-returns-nilp*, and if it is true, we
; return nil.  It is up to the environment to somehow set that special
; variable.

; In ev-fncall we provide the argument hard-error-returns-nilp which
; is used as the binding of *hard-error-returns-nil* when we invoke
; the raw code.  This also infects ev and the other functions in the
; ev-fncall clique, namely ev-lst and ev-acl2-unwind-protect.  It is
; up to the user of ev-fncall to specify which behavior is desired.
; Generally speaking, that argument of ev-fncall is set to t in those
; calls of ev-fncall that are from within the theorem prover and on
; terms from the conjecture being proved.  Secondly, (up to
; Version_2.5) in oneify-cltl-code and oneify-cltl-code, when we
; generated the ACL2_*1*_ACL2 code for a function, we laid down a
; binding for *hard-error-returns-nil*.  That binding is in effect
; just when we evaluate the guard of the function.  The binding is t
; if either it was already (meaning somebody above us has asked for
; hard-error to be treated this way) or if guard checking is turned
; off.

; See the comment after ILLEGAL (below) for a discussion of an
; earlier, inadequate handling of these issues.

  ":Doc-Section ACL2::ACL2-built-ins

  print an error message and stop execution~/

  ~c[(Hard-error ctx str alist)] causes evaluation to halt with a short
  message using the ``context'' ~c[ctx].  An error message is first printed
  using the string ~c[str] and alist ~c[alist] that are of the same kind
  as expected by ~ilc[fmt].  ~l[fmt].  Also ~pl[er] for a macro that provides a
  unified way of signaling errors.~/

  ~c[Hard-error] has a guard of ~c[t].  Also ~pl[illegal] for a
  similar capability which however has a guard of ~c[nil] that supports
  static checking using ~ilc[guard] verification, rather than using dynamic
  (run-time) checking.   This distinction is illustrated elsewhere:
  ~pl[prog2$] for examples.

  Semantically, ~c[hard-error] ignores its arguments and always returns
  ~c[nil].  But if a call ~c[(hard-error ctx str alist)] is encountered
  during evaluation, then the string ~c[str] is printed using the
  association list ~c[alist] (as in ~ilc[fmt]), after which evaluation halts
  immediately.  Here is a trivial, contrived example.
  ~bv[]
  ACL2 !>(cons 3 (hard-error 'my-context
                              \"Printing 4: ~~n0\"
                              (list (cons #\\0 4))))


  HARD ACL2 ERROR in MY-CONTEXT:  Printing 4: four



  ACL2 Error in TOP-LEVEL:  Evaluation aborted.

  ACL2 !>
  ~ev[]~/"

  (declare (xargs :guard t))
  #-acl2-loop-only
  (cond
   ((not *hard-error-returns-nilp*)

; We are going to ``cause an error.''  We print an error message with error-fms
; even though we do not have state.  To do that, we must bind *wormholep* to
; nil so we don't try to push undo information (or, in the case of error-fms,
; cause an error for illegal state changes).  If error-fms could evaluate arbitrary
; forms, e.g., to make legal state changes while in wormholes, then this would be
; a BAD IDEA.  But error-fms only prints stuff that was created earlier (and passed
; in via alist).

    (cond ((fboundp 'acl2::error-fms)                        ;;; Print a msg
           (let ((*standard-output* *error-output*)          ;;; one way ...
                 (*wormholep* nil)
                 (fn 'acl2::error-fms))
             (funcall fn t ctx str alist *the-live-state*)))
          (t (print (list ctx str alist) *error-output*)))   ;;; or another.

; Once upon a time hard-error took a throw-flg argument and did the
; following throw-raw-ev-fncall only if the throw-flg was t.  Otherwise,
; it signalled an interface-er.  Note that in either case it behaved like
; an error -- interface-er's are rougher because they do not leave you in
; the ACL2 command loop.  I think this aspect of the old code was a vestige
; of the pre-*ld-level* days when we didn't know if we could throw or not.

      (throw-raw-ev-fncall 'illegal)))
  #+acl2-loop-only
  (declare (ignore ctx str alist))
  nil)

(defun illegal (ctx str alist)

  ":Doc-Section ACL2::ACL2-built-ins

  print an error message and stop execution~/

  ~c[(Illegal ctx str alist)] causes evaluation to halt with a short
  message using the ``context'' ~c[ctx].  An error message is first printed
  using the string ~c[str] and alist ~c[alist] that are of the same kind
  as expected by ~ilc[fmt].  ~l[fmt], and ~pl[prog2$] for an
  example of how to use a related function, ~ilc[hard-error]
  (~pl[hard-error]).  Also ~pl[er] for a macro that provides a unified
  way of signaling errors.~/

  The difference between ~c[illegal] and ~ilc[hard-error] is that the former
  has a guard of ~c[nil] while the latter has a ~ilc[guard] of ~c[t].  Thus,
  you may want to use ~c[illegal] rather than ~c[hard-error] when you intend
  to do ~ilc[guard] verification at some point, and you expect the guard
  to guarantee that the ~c[illegal] call is never executed.
  ~l[prog2$] for an example.~/"

; We would like to use this function in :common-lisp-compliant function
; definitions, but prove that it's never called.  Thus we have to make this
; function :common-lisp-compliant, and its guard is then nil.

  (declare (xargs :guard (hard-error ctx str alist)))
  (hard-error ctx str alist))

; Note on Inadequate Handling of Illegal.

; Once upon a time (pre-Version  2.4) we had hard-error take an additional
; argument and the programmer used that argument to indicate whether the
; function was to cause an error or return nil.  When hard-error was used
; in the :guard of ILLEGAL it was called so as not to cause an error (if
; guard checking was off) and when it was called in the body of ILLEGAL it
; was programmed to cause an error.  However, the Rockwell folks, using
; LETs in support of stobjs, discovered that we caused hard errors on
; some guard verifications.  Here is a simple example distilled from theirs:

;  (defun foo (i)
;    (declare (xargs :guard (integerp i)))
;    (+ 1
;       (car
;        (let ((j i))
;          (declare (type integer j))
;          (cons j nil)))))

; This function caused a hard error during guard verification.  The
; troublesome guard conjecture is:

;  (IMPLIES
;   (INTEGERP I)
;   (ACL2-NUMBERP
;    (CAR (LET ((J I))
;           (PROG2$ (IF (INTEGERP J)
;                       T
;                       (ILLEGAL 'VERIFY-GUARDS
;                                "Some TYPE declaration is violated."
;                                NIL))
;                   (LIST J))))))

; The problem was that we eval'd the ILLEGAL during the course of trying
; to prove this.  A similar challenge is the above mentioned
; (thm (equal (car (cons (hard-error 'ctx "Test" nil) y)) nil))
; We leave this note simply in case the current handling of
; hard errors is found still to be inadequate.

#+acl2-loop-only
(defmacro intern (x y)
  (declare (xargs :guard (member-equal y
                                       (cons *main-lisp-package-name*
                                             '("ACL2"
                                               *main-lisp-package-name*
                                               "ACL2-INPUT-CHANNEL"
                                               "ACL2-OUTPUT-CHANNEL"
                                               "KEYWORD")))))
  ":Doc-Section ACL2::ACL2-built-ins

  create a new symbol in a given package~/

  ~c[(intern symbol-name symbol-package-name)] returns a symbol with
  the given ~ilc[symbol-name] and the given ~ilc[symbol-package-name].  We
  restrict Common Lisp's ~c[intern] so that the second argument is
  either the symbol *main-lisp-package-name*, the value of that
  constant, or is one of \"ACL2\", \"ACL2-INPUT-CHANNEL\",
  \"ACL2-OUTPUT-CHANNEL\", or \"KEYWORD\".  To avoid that restriction,
  ~pl[intern$].~/

  In ACL2 ~c[intern] is actually implemented as a macro that expands to
  a call of a similar function whose second argument is a symbol.
  Invoke ~c[:pe intern] to see the definition, or
  ~pl[intern-in-package-of-symbol].

  To see why is ~c[intern] so restricted consider
  ~c[(intern \"X\" \"P\")].  In particular, is it a symbol and if so,
  what is its ~ilc[symbol-package-name]?  One is tempted to say ``yes, it
  is a symbol in the package ~c[\"P\"].''  But if package ~c[\"P\"] has
  not yet been defined, that would be premature because the imports to
  the package are unknown.  For example, if ~c[\"P\"] were introduced
  with
  ~bv[]
  (defpkg \"P\" '(LISP::X))
  ~ev[]
  then in Common Lisp ~c[(symbol-package-name (intern \"X\" \"P\"))] returns
  ~C[\"LISP\"].

  The obvious restriction on ~c[intern] is that its second argument be
  the name of a package known to ACL2.  We cannot express such a
  restriction (except, for example, by limiting it to those packages
  known at some fixed time, as we do).  Instead, we provide
  ~ilc[intern-in-package-of-symbol] which requires a ``witness symbol''
  for the package instead of the package.  The witness symbol is any
  symbol (expressible in ACL2) and uniquely specifies a package
  necessarily known to ACL2."

  (list 'intern-in-package-of-symbol
        x
        (cond
         ((equal y "ACL2")
          ''rewrite)
         ((equal y "ACL2-INPUT-CHANNEL")
          ''acl2-input-channel::a-random-symbol-for-intern)
         ((equal y "ACL2-OUTPUT-CHANNEL")
          ''acl2-output-channel::a-random-symbol-for-intern)
         ((equal y "KEYWORD")
          ':a-random-symbol-for-intern)
         ((or (equal y *main-lisp-package-name*)
              (eq y '*main-lisp-package-name*))
          ''car)
         (t (illegal 'intern
                     "The guard for INTERN is out of sync with its ~
                      definition.~%Consider adding a case for a second ~
                      argument of ~x0."
                     (list (cons #\0 y)))))))

(defmacro intern$ (x y)

  ":Doc-Section ACL2::ACL2-built-ins

  create a new symbol in a given package~/

  ~c[Intern$] is a macro that behaves the same as the macro ~ilc[intern],
  except for weakening the restriction to a fixed set of package names so that
  any package name other than ~c[\"\"] is legal.  ~l[intern].  Note that if you
  evaluate a call ~c[(intern$ x y)] for which there is no package with name
  ~c[y] that is known to ACL2, you will get an error.~/

  ~c[(Intern$ x y)] expands to:
  ~bv[]
  (intern-in-package-of-symbol x (pkg-witness y))
  ~ev[]
  ~l[intern-in-package-of-symbol] and ~pl[pkg-witness].~/"

  `(intern-in-package-of-symbol ,x (pkg-witness ,y)))

#+acl2-loop-only
(defun keywordp (x)

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for keywords~/

  ~c[(Keywordp x)] is true if and only if ~c[x] is a keyword, i.e., a symbol in
  the \"KEYWORD\" package.  Such symbols are typically printed using a colon
  (:) followed by the ~ilc[symbol-name] of the symbol.~/

  ~c[Keywordp] has a ~il[guard] of ~c[t].

  ~c[Keywordp] is a Common Lisp function.  See any Common Lisp documentation
  for more information.  The following log may be illuminating.
  ~bv[]
  ACL2 !>(intern \"ABC\" \"KEYWORD\")
  :ABC
  ACL2 !>(symbol-name ':ABC)
  \"ABC\"
  ACL2 !>(symbol-package-name ':ABC)
  \"KEYWORD\"
  ACL2 !>
  ~ev[]

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard t))
  (and (symbolp x) (equal (symbol-package-name x) "KEYWORD")))

(defthm keywordp-forward-to-symbolp
  (implies (keywordp x)
           (symbolp x))
  :rule-classes :forward-chaining)

(defaxiom intern-in-package-of-symbol-symbol-name

; This axiom assumes that "" is not the name of any package, but is instead
; used as a default value when symbol-package-name is applied to a non-symbol.
; So, the hypotheses below imply (symbolp y).  See also the lemma
; symbol-package-name-of-symbol-is-not-empty-string, below.  See also
; chk-acceptable-defpkg for a related comment, in which a proof of nil is shown
; using this axiom when "" is not disallowed as a package name.

  (implies (and (symbolp x)
                (equal (symbol-package-name x) (symbol-package-name y)))
           (equal (intern-in-package-of-symbol (symbol-name x) y) x)))

(defthm symbol-package-name-of-symbol-is-not-empty-string

; This rule became necessary for the proof of lemma nice->simple-inverse in
; community book books/workshops/2003/sumners/support/n2n.lisp, after axiom
; symbol-package-name-pkg-witness-name (below) was modified after Version_3.0.1
; by adding the condition (not (equal pkg-name "")).  We make it a
; :forward-chaining rule in order to avoid hanging a rewrite rule on 'equal.

  (implies (symbolp x)
           (not (equal (symbol-package-name x) "")))
  :hints (("Goal"
           :use ((:instance intern-in-package-of-symbol-symbol-name
                            (x x) (y 3)))
           :in-theory (disable intern-in-package-of-symbol-symbol-name)))
  :rule-classes ((:forward-chaining :trigger-terms ((symbol-package-name x)))))

(defconst *pkg-witness-name* "ACL2-PKG-WITNESS")

(defaxiom symbol-name-pkg-witness
  (equal (symbol-name (pkg-witness pkg-name))
         *pkg-witness-name*))

(defaxiom symbol-package-name-pkg-witness-name
  (equal (symbol-package-name (pkg-witness pkg-name))
         (if (and (stringp pkg-name)
                  (not (equal pkg-name "")))
             pkg-name

; See the comment in intern-in-package-of-symbol-symbol-name for why we do not
; use "" below.  We avoid questions about names of built-in Lisp and keyword
; packages by using our own package name.

           "ACL2")))

; Member-symbol-name is used in defpkg axioms.  We keep it disabled in order to
; avoid stack overflows, for example in the proof of theorem
; symbol-listp-raw-acl2-exports in file community book
; books/misc/check-acl2-exports.lisp.

(defun member-symbol-name (str l)
  (declare (xargs :guard (symbol-listp l)))
  (cond ((endp l) nil)
        ((equal str (symbol-name (car l))) l)
        (t (member-symbol-name str (cdr l)))))

; Defund is not yet available here:
(in-theory (disable member-symbol-name))

(defthm symbol-equality

; This formula is provable using intern-in-package-of-symbol-symbol-name.

   (implies (and (symbolp s1)
                 (symbolp s2)
                 (equal (symbol-name s1) (symbol-name s2))
                 (equal (symbol-package-name s1) (symbol-package-name s2)))
            (equal s1 s2))
   :rule-classes nil
   :hints (("Goal"
            :in-theory (disable intern-in-package-of-symbol-symbol-name)
            :use
            ((:instance
              intern-in-package-of-symbol-symbol-name
              (x s1) (y s2))
             (:instance
              intern-in-package-of-symbol-symbol-name
              (x s2) (y s2))))))

(defaxiom symbol-name-intern-in-package-of-symbol
  (implies (and (stringp s)
                (symbolp any-symbol))
           (equal (symbol-name (intern-in-package-of-symbol s any-symbol)) s)))

(defaxiom symbol-package-name-intern-in-package-of-symbol
  (implies (and (stringp x)
                (symbolp y)
                (not (member-symbol-name
                      x
                      (pkg-imports (symbol-package-name y)))))
           (equal (symbol-package-name (intern-in-package-of-symbol x y))
                  (symbol-package-name y))))

(defaxiom intern-in-package-of-symbol-is-identity
  (implies (and (stringp x)
                (symbolp y)
                (member-symbol-name
                 x
                 (pkg-imports (symbol-package-name y))))
           (equal (intern-in-package-of-symbol x y)
                  (car (member-symbol-name
                        x
                        (pkg-imports (symbol-package-name y)))))))

(defaxiom symbol-listp-pkg-imports
  (symbol-listp (pkg-imports pkg))
  :rule-classes ((:forward-chaining :trigger-terms ((pkg-imports pkg)))))

(defaxiom no-duplicatesp-eq-pkg-imports
  (no-duplicatesp-eq (pkg-imports pkg))
  :rule-classes :rewrite)

(defaxiom completion-of-pkg-imports
  (equal (pkg-imports x)
         (if (stringp x)
             (pkg-imports x)
           nil))
  :rule-classes nil)

; These axioms are just the ones that would be added by defpkg had the packages
; in question been introduced that way.

; Warning: If the forms of these axioms are changed, you should
; probably visit the same change to the rules added by defpkg.

(defaxiom acl2-input-channel-package
  (equal (pkg-imports "ACL2-INPUT-CHANNEL")
         nil))

(defaxiom acl2-output-channel-package
  (equal (pkg-imports "ACL2-OUTPUT-CHANNEL")
         nil))

(defaxiom acl2-package
  (equal (pkg-imports "ACL2")
         *common-lisp-symbols-from-main-lisp-package*))

(defaxiom keyword-package
  (equal (pkg-imports "KEYWORD")
         nil))

; The following two axioms are probably silly.  But at least they may provide
; steps towards building up the ACL2 objects constructively from a few
; primitives.

(defaxiom string-is-not-circular
  (equal 'string
         (intern-in-package-of-symbol
          (coerce (cons #\S (cons #\T (cons #\R (cons #\I (cons #\N (cons #\G 0))))))
                  (cons #\S (cons #\T (cons #\R (cons #\I (cons #\N (cons #\G 0)))))))
          (intern-in-package-of-symbol 0 0)))
  :rule-classes nil)

(defaxiom nil-is-not-circular
  (equal nil
         (intern-in-package-of-symbol
          (coerce (cons #\N (cons #\I (cons #\L 0))) 'string)
          'string))
  :rule-classes nil)

; Essay on Symbols and Packages

; A symbol may be viewed as a pair consisting of two strings: its symbol-name
; and its symbol-package-name, where the symbol-package-name is not "".  (A
; comment in intern-in-package-of-symbol-symbol-name discusses why we disallow
; "".)  However, some such pairs are not symbols because of the import
; structure (represented in world global 'known-package-alist).  For example,
; the "ACL2" package imports a symbol with symbol-name "CAR" from the
; "COMMON-LISP" package, so the symbol-package-name of ACL2::CAR is
; "COMMON-LISP".  Thus there is no symbol with a symbol-name of "CAR" and a
; symbol-package-name of "ACL2".

; The package system has one additional requirement: No package is allowed to
; import any symbol named *pkg-witness-name* from any other package.  The
; function pkg-witness returns a symbol with that name; moreover, the
; symbol-package-name of (pkg-witness p) is p if p is a string other than "",
; else is "ACL2".

; Logically, we imagine that a package exists for every string (serving as the
; symbol-package-name of its symbols) except "".  Of course, at any given time
; only finite many packages have been specified (either being built-in, or
; specified with defpkg); and, ACL2 will prohibit explicit specification of
; packages for certain strings, such as "ACL2_INVISIBLE".

; Finally, we specify that the symbol-name and symbol-package-name of any
; non-symbol are "".

#-acl2-loop-only
(defun-one-output intern-in-package-of-symbol (str sym)

; In general we require that intern be given an explicit string constant
; that names a package known at translate time.  This avoids the run-time
; check that the package is known -- which would require passing state down
; to intern everywhere.  However, we would like a more general intern
; mechanism and hence define the following, which is admitted by special
; decree in translate.  The beauty of this use of intern is that the user
; supplies a symbol which establishes the existence of the desired package.

  (declare (type string str)
           (type symbol sym))
  (let* ((mark (get sym *initial-lisp-symbol-mark*))
         (pkg (if mark *main-lisp-package* (symbol-package sym))))
    (multiple-value-bind
     (ans status)
     (intern str pkg)
     (declare (ignore status))

; We next guarantee that if sym is an ACL2 object then so is ans.  We assume
; that every import of a symbol into a package known to ACL2 is via defpkg,
; except perhaps for imports into the "COMMON-LISP" package.  So unless sym
; resides in the "COMMON-LISP" package (whether natively or not), the
; symbol-package of sym is one of those known to ACL2.  Thus, the only case of
; concern is the case that sym resides in the "COMMON-LISP" package.  Since sym
; is an ACL2 object, then by the Invariant on Symbols in the Common Lisp
; Package (see bad-lisp-objectp), its symbol-package is *main-lisp-package* or
; else its *initial-lisp-symbol-mark* property is "COMMON-LISP".  So we set the
; *initial-lisp-symbol-mark* for ans in each of these sub-cases, which
; preserves the above invariant.

     (when (and (eq pkg *main-lisp-package*)
                (not (get ans *initial-lisp-symbol-mark*)))
       (setf (get ans *initial-lisp-symbol-mark*)
             *main-lisp-package-name-raw*))
     ans)))

(defdoc pkg-imports
  ":Doc-Section ACL2::ACL2-built-ins

  list of symbols imported into a given package~/

  Completion Axiom (~c[completion-of-pkg-imports]):
  ~bv[]
  (equal (pkg-imports x)
         (if (stringp x)
             (pkg-imports x)
           nil))
  ~ev[]~/
  ~il[Guard] for ~c[(pkg-imports x)]:
  ~bv[]
  (stringp x)
  ~ev[]

  ~c[(Pkg-imports pkg)] returns a duplicate-free list of all symbols imported
  into ~c[pkg], which should be the name of a package known to ACL2.  For
  example, suppose ~c[\"MY-PKG\"] was created by
  ~bv[]
  (defpkg \"MY-PKG\" '(ACL2::ABC LISP::CAR)).
  ~ev[]
  Then ~c[(pkg-imports \"MY-PKG\")] equals the list ~c[(ACL2::ABC LISP::CAR)].

  If ~c[pkg] is not a string, then ~c[(pkg-imports pkg)] is ~c[nil].  If
  ~c[pkg] is a string but not the name of a package known to ACL2, then the
  value of the form ~c[(pkg-imports pkg)] is unspecified, and it evaluation
  will fail to yield a value.  By ``the symbols imported into ~c[pkg]'' we mean
  the symbols imported into ~c[pkg] by the ~ilc[defpkg] event that introduced
  ~c[pkg].  There are no imports for built-in packages except for the
  ~c[\"ACL2\"] package, which imports the symbols in the list value of the
  constant ~c[*common-lisp-symbols-from-main-lisp-package*].  In particular,
  this is the case for the ~c[\"COMMON-LISP\"] package.  Users familiar with
  Common Lisp may find this surprising, since in actual Common Lisp
  implementations it is often the case that many symbols in that package are
  imported from other packages.  However, ACL2 treats all symbols in the
  constant ~c[*common-lisp-symbols-from-main-lisp-package*] as having a
  ~ilc[symbol-package-name] of ~c[\"COMMON-LISP\"], as though they were not
  imported.  ACL2 admits a symbol imported into in the ~c[\"COMMON-LISP\"]
  package only if it belongs to that list: any attempt to read any other symbol
  imported into the ~c[\"COMMON-LISP\"] package, or to produce such a symbol
  with ~ilc[intern$] or ~ilc[intern-in-package-of-symbol], will cause an
  error.

  The following axioms formalize properties of ~c[pkg-imports] discussed above
  (use ~c[:]~ilc[pe] to view them).
  ~bv[]
  symbol-package-name-intern-in-package-of-symbol
  intern-in-package-of-symbol-is-identity
  symbol-listp-pkg-imports
  no-duplicatesp-pkg-imports
  completion-of-pkg-imports
  ~ev[]")

#-acl2-loop-only
(defun-one-output pkg-imports (pkg)
  (declare (type string pkg))
  (let ((entry (find-non-hidden-package-entry pkg
                                              (known-package-alist
                                               *the-live-state*))))
    (cond (entry (package-entry-imports entry))
          (t (throw-raw-ev-fncall (list 'pkg-imports-er pkg))))))

(defdoc pkg-witness
  ":Doc-Section ACL2::ACL2-built-ins

  return a specific symbol in the indicated package~/

  For any string ~c[pkg] that names a package currently known to ACL2,
  ~c[(pkg-witness pkg)] is a symbol in that package whose ~ilc[symbol-name] is
  the value of constant ~c[*pkg-witness-name*].  Logically, this is the case
  even if the package is not currently known to ACL2.  However, if
  ~c[pkg-witness] is called on a string that is not the name of a package known
  to ACL2, a hard Lisp error will result.~/

  ~c[(Pkg-witness pkg)] has a guard of
  ~c[(and (stringp pkg) (not (equal pkg \"\")))].  If ~c[pkg] is not a string,
  then ~c[(pkg-witness pkg)] is equal to ~c[(pkg-witness \"ACL2\")]~/")

#-acl2-loop-only
(defun-one-output pkg-witness (pkg)
  (declare (type string pkg))
  (cond ((find-non-hidden-package-entry pkg
                                        (known-package-alist *the-live-state*))
         (let ((ans (intern *pkg-witness-name* pkg)))
; See comment in intern-in-package-of-symbol for an explanation of this trick.
           ans))
        (t

; We use error rather than illegal, because we want to throw an error even when
; *hard-error-returns-nilp* is true.

         (error "The argument supplied to PKG-WITNESS, ~s, is not the name of ~
                 a package currently known to ACL2."
                pkg))))

;  UTILITIES - definitions of the rest of applicative Common Lisp.

(defun binary-append (x y)

  ":Doc-Section ACL2::ACL2-built-ins

  ~il[concatenate] two lists~/

  This binary function implements ~ilc[append], which is a macro in ACL2.
  ~l[append]~/

  The ~il[guard] for ~c[binary-append] requires the first argument to be a
  ~ilc[true-listp].

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (true-listp x)))
  (cond ((endp x) y)
        (t (cons (car x) (binary-append (cdr x) y)))))

#+acl2-loop-only
(defmacro append (&rest rst)

  ":Doc-Section ACL2::ACL2-built-ins

  ~il[concatenate] zero or more lists~/

  ~c[Append], which takes zero or more arguments, expects all the arguments
  except perhaps the last to be true (null-terminated) lists.  It returns the
  result of concatenating all the elements of all the given lists into a single
  list.  Actually, in ACL2 ~c[append] is a macro that expands into calls of the
  binary function ~ilc[binary-append] if there are at least two arguments; if
  there is just one argument then the expansion is that argument; and finally,
  ~c[(append)] expands to ~c[nil].~/

  ~c[Append] is a Common Lisp function.  See any Common Lisp documentation for
  more information.~/"

  (cond ((null rst) nil)
        ((null (cdr rst)) (car rst))
        (t (xxxjoin 'binary-append rst))))

(defthm true-listp-append

; This rule has the effect of making the system automatically realize that (rev
; x) is a true-list, for example, where:

;   (defun rev (x)
;     (if (endp x)
;         nil
;       (append (rev (cdr x))
;               (list (car x)))))

; That in turn means that when it generalizes (rev x) to z it adds (true-listp
; z).

; That in turn means it can prove

;   (defthm rev-append
;     (equal (rev (append a b))
;            (append (rev b) (rev a))))
;
; automatically, doing several generalizations and inductions.

  (implies (true-listp b)
           (true-listp (append a b)))
  :rule-classes :type-prescription)

; The following lemma originally appeared to be useful for accepting the
; definition of make-input-channel.  Then it became useful for accepting the
; definition of string-append, though that's changed a bit.

(defthm standard-char-listp-append
  (implies (true-listp x)
           (equal (standard-char-listp (append x y))
                  (and (standard-char-listp x)
                       (standard-char-listp y))))
  :hints (("Goal" :in-theory (enable standard-char-listp))))

(defthm character-listp-append
  (implies (true-listp x)
           (equal (character-listp (append x y))
                  (and (character-listp x)
                       (character-listp y)))))

(defthm append-to-nil
  (implies (true-listp x)
           (equal (append x nil)
                  x)))

#+acl2-loop-only
(defmacro concatenate (result-type &rest sequences)

  ":Doc-Section ACL2::ACL2-built-ins

  concatenate lists or strings together~/
  ~bv[]
  Examples:
  (concatenate 'string \"ab\" \"cd\" \"ef\")     ; equals \"abcdef\"
  (concatenate 'string \"ab\")               ; equals \"ab\"
  (concatenate 'list '(a b) '(c d) '(e f)) ; equals '(a b c d e f)
  (concatenate 'list)                      ; equals nil~/

  General Form:
  (concatenate result-type x1 x2 ... xn)
  ~ev[]
  where ~c[n >= 0] and either:  ~c[result-type] is ~c[']~ilc[string] and each ~c[xi] is a
  string; or ~c[result-type] is ~c[']~ilc[list] and each ~c[xi] is a true list.
  ~c[Concatenate] simply concatenates its arguments to form the result
  string or list.  Also ~pl[append] and ~pl[string-append].  (The latter
  immediately generates a call to ~c[concatenate] when applied to strings.)

  Note:  We do *not* try to comply with the Lisp language's insistence
  that ~c[concatenate] copies its arguments.  Not only are we in an
  applicative setting, where this issue shouldn't matter for the
  logic, but also we do not actually modify the underlying lisp
  implementation of ~c[concatenate]; we merely provide a definition for
  it.

  ~c[Concatenate] is a Common Lisp function.  See any Common Lisp
  documentation for more information.~/"

  (declare (xargs :guard (member-equal result-type
                                       '('string 'list))))
  (cond
   ((equal result-type ''string)
    (cond ((and sequences (cdr sequences) (null (cddr sequences)))

; Here we optimize for a common case, but more importantly, we avoid expanding
; to a call of string-append-lst for the call of concatenate in the definition
; of string-append.

           (list 'string-append (car sequences) (cadr sequences)))
          (t
           (list 'string-append-lst (cons 'list sequences)))))
   ((endp sequences) nil)
   (t

; Consider the call (concatenate 'list .... '(a . b)).  At one time we tested
; for (endp (cdr sequences)) here, returning (car sequences) in that case.  And
; otherwise, we returned (cons 'append sequences).  However, these are both
; errors, because the last member of sequences might be a non-true-listp, in
; which case append signals no guard violation but Common Lisp breaks.

    (cons 'append (append sequences (list nil))))))

(defun string-append (str1 str2)

  ":Doc-Section ACL2::ACL2-built-ins

  ~il[concatenate] two strings~/

  ~c[String-append] takes two arguments, which are both strings (if the
  ~il[guard] is to be met), and returns a string obtained by concatenating
  together the ~il[characters] in the first string followed by those in the
  second.  Also ~pl[concatenate], noting that the macro call
  ~bv[]
  (concatenate 'string str1 str2).
  ~ev[]
  expands to the call
  ~bv[]
  (string-append str1 str2).
  ~ev[]

  To see the ACL2 definition of this function, ~pl[pf].~/~/"

  (declare (xargs :guard (and (stringp str1)
                              (stringp str2))))
  (mbe :logic
       (coerce (append (coerce str1 'list)
                       (coerce str2 'list))
               'string)
       :exec

; This code may seem circular, since string-append calls the concatenate macro,
; which expands here into a call of string-append.  However, the :exec case is
; only called if we are executing the raw Lisp code for string-append, in which
; case we will be executing the raw Lisp code for concatenate, which of course
; does not call the ACL2 function string-append.

       (concatenate 'string str1 str2)))

(defun string-listp (x)

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for a true list of strings~/

  The predicate ~c[string-listp] tests whether its argument is a
  ~ilc[true-listp] of strings.

  To see the ACL2 definition of this function, ~pl[pf].~/~/"

  (declare (xargs :guard t))
  (cond
   ((atom x)
    (eq x nil))
   (t
    (and (stringp (car x))
         (string-listp (cdr x))))))

(defun string-append-lst (x)
  (declare (xargs :guard (string-listp x)))
  (cond
   ((endp x)
    "")
   (t
    (string-append (car x)
                   (string-append-lst (cdr x))))))

; We make 1+ and 1- macros in order to head off the potentially common error of
; using these as nonrecursive functions on left-hand sides of rewrite rules.

#+acl2-loop-only
(defmacro 1+ (x)

  ":Doc-Section ACL2::ACL2-built-ins

  increment by 1~/

  ~c[(1+ x)] is the same as ~c[(+ 1 x)].  ~l[+].~/

  ~c[1+] is a Common Lisp function.  See any Common Lisp documentation
  for more information.~/"

  (list '+ 1 x))

#+acl2-loop-only
(defmacro 1- (x)

  ":Doc-Section ACL2::ACL2-built-ins

  decrement by 1~/

  ~c[(1- x)] is the same as ~c[(- x 1)].  ~l[-].~/

  ~c[1-] is a Common Lisp function.  See any Common Lisp documentation
  for more information.~/"

  (list '- x 1))

; Remove

(defun remove-eq-exec (x l)
  (declare (xargs :guard (if (symbolp x)
                             (true-listp l)
                           (symbol-listp l))))
  (cond ((endp l) nil)
        ((eq x (car l))
         (remove-eq-exec x (cdr l)))
        (t (cons (car l) (remove-eq-exec x (cdr l))))))

(defun remove-eql-exec (x l)
  (declare (xargs :guard (if (eqlablep x)
                             (true-listp l)
                           (eqlable-listp l))))
  (cond ((endp l) nil)
        ((eql x (car l))
         (remove-eql-exec x (cdr l)))
        (t (cons (car l) (remove-eql-exec x (cdr l))))))

(defun remove-equal (x l)
  (declare (xargs :guard (true-listp l)))
  #-acl2-loop-only ; for assoc-eq, Jared Davis found native assoc efficient
  (remove x l :test #'equal)
  #+acl2-loop-only
  (cond ((endp l) nil)
        ((equal x (car l))
         (remove-equal x (cdr l)))
        (t (cons (car l) (remove-equal x (cdr l))))))

(defmacro remove-eq (x lst)
  `(remove ,x ,lst :test 'eq))

(defthm remove-eq-exec-is-remove-equal
  (equal (remove-eq-exec x l)
         (remove-equal x l)))

(defthm remove-eql-exec-is-remove-equal
  (equal (remove-eql-exec x l)
         (remove-equal x l)))

#+acl2-loop-only
(defmacro remove (x l &key (test ''eql))

  ":Doc-Section ACL2::ACL2-built-ins

  remove all occurrences~/
  ~bv[]
  General Forms:
  (remove x lst)
  (remove x lst :test 'eql)   ; same as above (eql as equality test)
  (remove x lst :test 'eq)    ; same, but eq is equality test
  (remove x lst :test 'equal) ; same, but equal is equality test
  ~ev[]

  ~c[(Remove x lst)] is equal to ~c[lst] if ~c[x] is not a member of ~c[lst],
  else is the result of removing all occurrences of ~c[x] from ~c[lst].  The
  optional keyword, ~c[:TEST], has no effect logically, but provides the
  test (default ~ilc[eql]) used for comparing ~c[x] with successive elements of
  ~c[lst].

  Also ~pl[remove1].~/

  The ~il[guard] for a call of ~c[remove] depends on the test.  In all cases,
  the second argument must satisfy ~ilc[true-listp].  If the test is ~ilc[eql],
  then either the first argument must be suitable for ~ilc[eql] (~pl[eqlablep])
  or the second argument must satisfy ~ilc[eqlable-listp].  If the test is
  ~ilc[eq], then either the first argument must be a symbol or the second
  argument must satisfy ~ilc[symbol-listp].

  ~l[equality-variants] for a discussion of the relation between ~c[remove] and
  its variants:
  ~bq[]
  ~c[(remove-eq x lst)] is equivalent to ~c[(remove x lst :test 'eq)];

  ~c[(remove-equal x lst)] is equivalent to ~c[(remove x lst :test 'equal)].
  ~eq[]
  In particular, reasoning about any of these primitives reduces to reasoning
  about the function ~c[remove-equal].

  ~c[Remove] is defined by Common Lisp.  See any Common Lisp documentation for
  more information.~/"

  (declare (xargs :guard (or (equal test ''eq)
                             (equal test ''eql)
                             (equal test ''equal))))
  (cond
   ((equal test ''eq)
    `(let-mbe ((x ,x) (l ,l))
              :logic (remove-equal x l)
              :exec  (remove-eq-exec x l)))
   ((equal test ''eql)
    `(let-mbe ((x ,x) (l ,l))
              :logic (remove-equal x l)
              :exec  (remove-eql-exec x l)))
   (t ; (equal test 'equal)
    `(remove-equal ,x ,l))))

; Remove1

(defun remove1-eq-exec (x l)
  (declare (xargs :guard (if (symbolp x)
                             (true-listp l)
                           (symbol-listp l))))
  (cond ((endp l) nil)
        ((eq x (car l))
         (cdr l))
        (t (cons (car l) (remove1-eq-exec x (cdr l))))))

(defun remove1-eql-exec (x l)
  (declare (xargs :guard (if (eqlablep x)
                             (true-listp l)
                           (eqlable-listp l))))
  (cond ((endp l) nil)
        ((eql x (car l))
         (cdr l))
        (t (cons (car l) (remove1-eql-exec x (cdr l))))))

(defun remove1-equal (x l)
  (declare (xargs :guard (true-listp l)))
  (cond ((endp l) nil)
        ((equal x (car l))
         (cdr l))
        (t (cons (car l) (remove1-equal x (cdr l))))))

(defmacro remove1-eq (x lst)
  `(remove1 ,x ,lst :test 'eq))

(defthm remove1-eq-exec-is-remove1-equal
  (equal (remove1-eq-exec x l)
         (remove1-equal x l)))

(defthm remove1-eql-exec-is-remove1-equal
  (equal (remove1-eql-exec x l)
         (remove1-equal x l)))

(defmacro remove1 (x l &key (test ''eql))

  ":Doc-Section ACL2::ACL2-built-ins

  remove first occurrences, testing using ~ilc[eql]~/
  ~bv[]
  General Forms:
  (remove1 x lst)
  (remove1 x lst :test 'eql)   ; same as above (eql as equality test)
  (remove1 x lst :test 'eq)    ; same, but eq is equality test
  (remove1 x lst :test 'equal) ; same, but equal is equality test
  ~ev[]

  ~c[(Remove1 x lst)] is equal to ~c[lst] if ~c[x] is not a member of ~c[lst],
  else is the result of removing the first occurrences of ~c[x] from ~c[lst].
  The optional keyword, ~c[:TEST], has no effect logically, but provides the
  test (default ~ilc[eql]) used for comparing ~c[x] with successive elements of
  ~c[lst].

  Also ~pl[remove].~/

  The ~il[guard] for a call of ~c[remove1] depends on the test.  In all cases,
  the second argument must satisfy ~ilc[true-listp].  If the test is ~ilc[eql],
  then either the first argument must be suitable for ~ilc[eql] (~pl[eqlablep])
  or the second argument must satisfy ~ilc[eqlable-listp].  If the test is
  ~ilc[eq], then either the first argument must be a symbol or the second
  argument must satisfy ~ilc[symbol-listp].

  ~l[equality-variants] for a discussion of the relation between ~c[remove1] and
  its variants:
  ~bq[]
  ~c[(remove1-eq x lst)] is equivalent to ~c[(remove1 x lst :test 'eq)];

  ~c[(remove1-equal x lst)] is equivalent to ~c[(remove1 x lst :test 'equal)].
  ~eq[]
  In particular, reasoning about any of these primitives reduces to reasoning
  about the function ~c[remove1-equal].~/"

  (declare (xargs :guard (or (equal test ''eq)
                             (equal test ''eql)
                             (equal test ''equal))))
  (cond
   ((equal test ''eq)
    `(let-mbe ((x ,x) (l ,l))
              :logic (remove1-equal x l)
              :exec  (remove1-eq-exec x l)))
   ((equal test ''eql)
    `(let-mbe ((x ,x) (l ,l))
              :logic (remove1-equal x l)
              :exec  (remove1-eql-exec x l)))
   (t ; (equal test 'equal)
    `(remove1-equal ,x ,l))))

(deflabel pairlis
  :doc
  ":Doc-Section ACL2::ACL2-built-ins

  ~l[pairlis$]~/

  The Common Lisp language allows its ~c[pairlis] function to construct
  an alist in any order!  So we have to define our own version:
  ~l[pairlis$].~/~/")

(defun pairlis$ (x y)

; CLTL allows its pairlis to construct an alist in any order!  So we
; have to give this function a different name.

  ":Doc-Section ACL2::ACL2-built-ins

  zipper together two lists~/

  The Common Lisp language allows its ~ilc[pairlis] function to construct
  an alist in any order!  So we have to define our own version,
  ~c[pairlis$].  It returns the list of pairs obtained by ~ilc[cons]ing
  together successive respective members of the given lists until the
  first list runs out.  (Hence in particular, if the second argument
  is ~c[nil] then each element of the first argument is paired with ~c[nil].)~/

  The ~il[guard] for ~c[pairlis$] requires that its arguments are true lists.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (true-listp x)
                              (true-listp y))))
  (cond ((endp x) nil)
        (t (cons (cons (car x) (car y))
                 (pairlis$ (cdr x) (cdr y))))))

; Remove-duplicates

(defun remove-duplicates-eq-exec (l)
  (declare (xargs :guard (symbol-listp l)))
  (cond
   ((endp l) nil)
   ((member-eq (car l) (cdr l)) (remove-duplicates-eq-exec (cdr l)))
   (t (cons (car l) (remove-duplicates-eq-exec (cdr l))))))

(defun remove-duplicates-eql-exec (l)
  (declare (xargs :guard (eqlable-listp l)))
  (cond
   ((endp l) nil)
   ((member (car l) (cdr l)) (remove-duplicates-eql-exec (cdr l)))
   (t (cons (car l) (remove-duplicates-eql-exec (cdr l))))))

(defun remove-duplicates-equal (l)
  (declare (xargs :guard (true-listp l)))
  (cond
   ((endp l) nil)
   ((member-equal (car l) (cdr l)) (remove-duplicates-equal (cdr l)))
   (t (cons (car l) (remove-duplicates-equal (cdr l))))))

(defmacro remove-duplicates-eq (x)
  `(remove-duplicates ,x :test 'eq))

(defthm remove-duplicates-eq-exec-is-remove-duplicates-equal
  (equal (remove-duplicates-eq-exec x)
         (remove-duplicates-equal x)))

(defthm remove-duplicates-eql-exec-is-remove-duplicates-equal
  (equal (remove-duplicates-eql-exec x)
         (remove-duplicates-equal x)))

(defmacro remove-duplicates-logic (x)
  `(let ((x ,x))
     (if (stringp x)
         (coerce (remove-duplicates-equal (coerce x 'list))
                 'string)
       (remove-duplicates-equal x))))

#+acl2-loop-only
(defmacro remove-duplicates (x &key (test ''eql))

  ":Doc-Section ACL2::ACL2-built-ins

  remove duplicates from a string or a list~/
  ~bv[]
  General Forms:
  (remove-duplicates x)
  (remove-duplicates x :test 'eql)   ; same as above (eql as equality test)
  (remove-duplicates x :test 'eq)    ; same, but eq is equality test
  (remove-duplicates x :test 'equal) ; same, but equal is equality test
  ~ev[]

  ~c[(Remove-duplicates x)] returns the result of deleting duplicate elements
  from the beginning of the list or string ~c[x].  For example,
  ~c[(remove-duplicates '(1 2 3 2 4))] is equal to ~c['(1 3 2 4)].  The
  optional keyword, ~c[:TEST], has no effect logically, but provides the
  test (default ~ilc[eql]) used for comparing ~c[x] with successive elements of
  ~c[lst].~/

  The ~il[guard] for a call of ~c[remove-duplicates] depends on the test.  In
  all cases, the argument must satisfy ~ilc[stringp] or ~ilc[true-listp].  If
  the test is ~ilc[eql], then the argument must satisfy either ~ilc[stringp] or
  ~ilc[eqlable-listp].  If the test is ~ilc[eq], then the argument must satisfy
  ~ilc[symbol-listp].

  The relation between ~c[remove-duplicates] and its variants is related to the
  usual pattern for equality variants; ~pl[equality-variants].  However, the
  possibility of a string argument changes the usual pattern a bit.  As one
  might expect:
  ~bq[]
  ~c[(remove-duplicates-eq lst)] is equivalent to
  ~c[(remove-duplicates lst :test 'eq)].
  ~eq[]
  However, ~c[remove-duplicates-equal] is defined without consideration of
  strings, for backward compatibility with versions of ACL2 through
  Version_4.2.  The macro ~c[remove-duplicates-logic] has been introduced to
  model the behavior of ~c[remove-duplicates] even on strings; use
  ~c[:]~ilc[pe] if you wish to see its definition.  So we can say the
  following.
  ~bq[]
  ~c[(remove-duplicates-logic lst)] is equivalent to
  ~c[(remove-duplicates lst :test 'equal)]; and

  ~c[(remove-duplicates-logic lst)] is equal to
  ~c[(remove-duplicates-equal lst)] when ~c[lst] is not a string.
  ~eq[]
  In particular, when the argument is not a string, reasoning about any of
  these primitives reduces to reasoning about the function
  ~c[remove-duplicates-equal].

  ~c[Remove-duplicates] is defined by Common Lisp.  See any Common Lisp
  documentation for more information.~/"

  (declare (xargs :guard (or (equal test ''eq)
                             (equal test ''eql)
                             (equal test ''equal))))
  (cond
   ((equal test ''eq)
    `(let-mbe ((x ,x))
              :logic (remove-duplicates-logic x)
              :exec  (remove-duplicates-eq-exec x)))
   ((equal test ''eql)
    `(let-mbe ((x ,x))
              :logic (remove-duplicates-logic x)
              :exec  (if (stringp x)
                         (coerce (remove-duplicates-eql-exec (coerce x 'list))
                                 'string)
                       (remove-duplicates-eql-exec x))))
   (t ; (equal test 'equal)
    `(remove-duplicates-logic ,x))))

(defthm character-listp-remove-duplicates
  (implies (character-listp x)
           (character-listp (remove-duplicates x))))

; We now define the first five documentation sections: Events,
; Documentation, History, Other, and Miscellaneous.  These
; are defined here simply so we can use them freely throughout.  The
; first four are advertised in :help.

(deflabel events
  :doc
  ":Doc-Section Events

  functions that extend the logic~/~/

  Any extension of the syntax of ACL2 (i.e., the definition of a new
  constant or macro), the axioms (i.e., the definition of a function),
  or the rule database (i.e., the proof of a theorem), constitutes a
  logical ``event.''  Events change the ACL2 logical world
  (~pl[world]).  Indeed, the only way to change the ACL2
  ~il[world] is via the successful evaluation of an event function.
  Every time the ~il[world] is changed by an event, a landmark is left
  on the ~il[world] and it is thus possible to identify the ~il[world]
  ``as of'' the evaluation of a given event.  An event may introduce
  new logical names.  Some events introduce no new names (e.g.,
  ~ilc[verify-guards]), some introduce exactly one (e.g., ~ilc[defmacro] and
  ~ilc[defthm]), and some may introduce many (e.g., ~ilc[encapsulate] ).

  ACL2 typically completes processing of an event by printing a summary.
  Unless proofs are skipped (~pl[ld-skip-proofsp]) or summary output is
  inhibited (~pl[set-inhibit-output-lst]), information about the proof attempt
  (if any) is printed that includes a list of rules used, a summary of
  warnings, and the number of ``prover steps'' (if any;
  ~pl[with-prover-step-limit]).  A breakdown of the time used is also printed,
  which by default is runtime (cpu time), but can be changed to realtime
  (wall clock time); ~pl[get-internal-time].

  ~l[embedded-event-form] for a discussion of events permitted in
  ~il[books].~/")

(deflabel documentation
  :doc
  ":Doc-Section Documentation

  functions that display documentation~/

  This section explains the ACL2 online documentation system.  Thus,
  most of it assumes that you are typing at the terminal, inside an ACL2
  session.  If you are reading this description in another setting
  (for example, in a web browser, in Emacs info, or on paper), simply
  ignore the parts of this description that involve typing at the
  terminal.

  ACL2 users are welcome to contribute additional documentation.  See
  the web page ~url[http://www.cs.utexas.edu/users/moore/acl2/contrib/].

  For an introduction to the ACL2 online documentation system, type
  ~c[:]~ilc[more] below.  Whenever the documentation system concludes with
  ``(type :more for more, :more! for the rest)'' you may type ~c[:]~ilc[more]
  to see the next block of documentation.

  Topics related to documentation are documented individually:~/

  To view the documentation in a web browser, open a browser to file
  ~c[doc/HTML/acl2-doc.html] under your ACL2 source directory, or just go to
  the ACL2 home page at ~url[http://www.cs.utexas.edu/users/moore/acl2/].

  Alternatively, follow a link on the ACL2 home page to a manual, known as the
  xdoc manual, which incorporates (but rearranges) the ACL2 documentation as
  well as documentation from many ACL2 community books.  You can build a local
  copy of that manual; see for example the section ``BUILDING THE XDOC MANUAL''
  in the community books ~c[Makefile] for instructions.

  To use Emacs Info (inside Emacs), first load distributed file
  ~c[emacs/emacs-acl2.el] (perhaps inside your ~c[.emacs] file) and then
  execute ~c[meta-x acl2-info].  In order to see true links to external web
  pages, you may find the following addition to your ~c[.emacs] file to be
  helpful.
  ~bv[]
  ; For emacs-version 22 or (presumably) later, you can probably set
  ; arrange that in Emacs Info, URLs become links, in the sense that
  ; if you hit ~c[<RETURN>] while standing on a URL, then you will be
  ; taken to that location in a web browser.  If this does not happen
  ; automatically, then evaluating the `setq' form below might work
  ; if you have firefox.  If that does not work, then you can probably
  ; figure out what to do as follows.  First type
  ;   control-h v browse-url-browser-function
  ; and then from the resulting help page,
  ; hit <return> on the link ``customize'' in:
  ; ``You can customize this variable''
  ; and then follow instructions.
  (setq browse-url-browser-function (quote browse-url-firefox))
  ~ev[]

  There is a print version of the documentation, though we recommend using one
  of the other methods (web, Emacs Info, or online) to browse it.  If you
  really want the print version, you can find it here:
  ~url[http://www.cs.utexas.edu/users/moore/publications/acl2-book.ps.gz].

  Below we focus on how to access the online documentation, but some of the
  discussion is relevant to other formats.

  The ACL2 online documentation feature allows you to see extensive
  documentation on many ACL2 functions and ideas.  You may use the
  documentation facilities to document your own ACL2 functions and
  theorems.

  If there is some name you wish to know more about, then type
  ~bv[]
  ACL2 !>:doc name
  ~ev[]
  in the top-level loop.  If the name is documented, a brief blurb
  will be printed.  If the name is not documented, but is ``similar''
  to some documented names, they will be listed.  Otherwise, ~c[nil] is
  returned.

  Every name that is documented contains a one-line description, a few
  notes, and some details.  ~c[:]~ilc[Doc] will print the one-liner and the
  notes.  When ~c[:]~ilc[doc] has finished it stops with the message
  ``(type :more for more, :more! for the rest)'' to remind you that details are
  available.  If you then type
  ~bv[]
  ACL2 !>:more
  ~ev[]
  a block of the continued text will be printed, again concluding
  with ``(type :more for more, :more! for the rest)'' if the text continues
  further, or concluding with ``~c[*-]'' if the text has been exhausted.  By
  continuing to type ~c[:]~ilc[more] until exhausting the text you can read
  successive blocks.  Alternatively, you can type ~c[:]~ilc[more!] to get all
  the remaining blocks.

  If you want to get the details and don't want to see the elementary
  stuff typed by ~c[:]~ilc[doc] name, type:
  ~bv[]
  ACL2 !>:MORE-DOC name
  ~ev[]
  We have documented not just function names but names of certain
  important ideas too.  For example, ~pl[rewrite] and
  ~pl[meta] to learn about ~c[:]~ilc[rewrite] rules and ~c[:]~ilc[meta] rules,
  respectively.  ~l[hints] to learn about the structure of the
  ~c[:]~ilc[hints] argument to the prover.  The ~ilc[deflabel] event
  (~pl[deflabel]) is a way to introduce a logical name for no
  reason other than to attach documentation to it; also
  ~pl[defdoc].

  How do you know what names are documented?  There is a documentation
  database which is querried with the ~c[:]~ilc[docs] command.

  The documentation database is divided into sections.  The sections
  are listed by
  ~bv[]
  ACL2 !>:docs *
  ~ev[]
  Each section has a name, ~c[sect], and by typing
  ~bv[]
  ACL2 !>:docs sect
  ~ev[]
  or equivalently
  ~bv[]
  ACL2 !>:doc sect
  ~ev[]
  you will get an enumeration of the topics within that section.
  Those topics can be further explored by using ~c[:]~ilc[doc] (and ~c[:]~ilc[more]) on
  them.  In fact the section name itself is just a documented name.
  ~c[:]~ilc[more] generally gives an informal overview of the general subject of
  the section.
  ~bv[]
  ACL2 !>:docs **
  ~ev[]
  will list all documented topics, by section.  This fills several
  pages but might be a good place to start.

  If you want documentation on some topic, but none of our names or
  brief descriptions seem to deal with that topic, you can invoke a
  command to search the text in the database for a given string.
  This is like the GNU Emacs ``~ilc[apropos]'' command.
  ~bv[]
  ACL2 !>:docs \"functional inst\"
  ~ev[]
  will list every documented topic whose ~c[:]~ilc[doc] or ~c[:]~ilc[more-doc] text
  includes the substring ~c[\"functional inst\"], where case and the exact
  number of spaces are irrelevant.

  If you want documentation on an ACL2 function or macro and the
  documentation database does not contain any entries for it, there
  are still several alternatives.
  ~bv[]
  ACL2 !>:args fn
  ~ev[]
  will print the arguments and some other relevant information about
  the named function or macro.  This information is all gleaned from
  the definition (not from the documentation database) and hence this
  is a definitive way to determine if ~c[fn] is defined as a function or
  macro.

  You might also want to type:
  ~bv[]
  ACL2 !>:pc fn
  ~ev[]
  which will print the ~il[command] which introduced ~c[fn].  You should
  ~pl[command-descriptor] for details on the kinds of input you
  can give the ~c[:]~ilc[pc] command.

  The entire ACL2 documentation database is user extensible.  That
  is, if you document your function definitions or theorems, then that
  documentation is made available via the database and its query
  commands.

  The implementation of our online documentation system makes use of
  Common Lisp's ``documentation strings.'' While Common Lisp permits a
  documentation string to be attached to any defined concept, Common
  Lisp assigns no interpretation to these strings.  ACL2 attaches
  special significance to documentation strings that begin with the
  characters ``~c[:Doc-Section]''.  When such a documentation string is
  seen, it is stored in the database and may be displayed via ~c[:]~ilc[doc],
  ~c[:]~ilc[more], ~c[:]~ilc[docs], etc.  Such documentation strings must follow rigid
  syntactic rules to permit their processing by our commands.  These
  are spelled out elsewhere; ~pl[doc-string].

  A description of the structure of the documentation database may
  also be found; ~pl[doc-string].

  Finally: To build the HTML documentation, proceed with the following sequence
  of steps.
  ~bq[]
  1. In the ~c[doc/] subdirectory of the ACL2 distribution, start ACL2 and then
  evaluate ~c[(certify-book \"write-acl2-html\")].

  2. Exit ACL2 and start it up again (or, evaluate ~c[:]~ilc[u]).

  3. Include the documented ~il[books] within your ACL2 loop using
  ~ilc[include-book].

  4. Evaluate ~c[(include-book \"../doc/write-acl2-html\" :dir :system)].

  5. Call macro ~c[write-html-file], following the instructions at the end of
  distributed file ~c[doc/write-acl2-html.lisp].
  ~eq[]~/")

(deflabel history
  :doc
  ":Doc-Section History

  functions that display or change history~/~/

  ACL2 keeps track of the ~il[command]s that you have executed that have
  extended the logic or the rule database, as by the definition of
  macros, functions, etc.  Using the facilities in this section you
  can review the sequence of ~il[command]s executed so far.  For example,
  you can ask to see the most recently executed ~il[command], or the
  ~il[command] ~c[10] before that, or the ~il[command] that introduced a given
  function symbol.  You can also undo back through some previous
  ~il[command], restoring the logical ~il[world] to what it was before the given
  ~il[command].

  The annotations printed in the margin in response to some of these
  commands (such as `P', `L', and `V') are explained in the
  documentation for ~c[:]~ilc[pc].

  Several technical terms are used in the documentation of the history
  ~il[command]s.  You must understand these terms to use the ~il[command]s.
  These terms are documented via ~c[:]~ilc[doc] entries of their own.
  ~l[command], ~pl[events], ~pl[command-descriptor], and
  ~pl[logical-name].~/")

#+acl2-loop-only
(defmacro first (x)
  ":Doc-Section ACL2::ACL2-built-ins

  first member of the list~/

  See any Common Lisp documentation for details.~/~/"
  (list 'car x))

#+acl2-loop-only
(defmacro second (x)
  ":Doc-Section ACL2::ACL2-built-ins

  second member of the list~/

  See any Common Lisp documentation for details.~/~/"
  (list 'cadr x))

#+acl2-loop-only
(defmacro third (x)
  ":Doc-Section ACL2::ACL2-built-ins

  third member of the list~/

  See any Common Lisp documentation for details.~/~/"
  (list 'caddr x))

#+acl2-loop-only
(defmacro fourth (x)
  ":Doc-Section ACL2::ACL2-built-ins

  fourth member of the list~/

  See any Common Lisp documentation for details.~/~/"
  (list 'cadddr x))

#+acl2-loop-only
(defmacro fifth (x)
  ":Doc-Section ACL2::ACL2-built-ins

  fifth member of the list~/

  See any Common Lisp documentation for details.~/~/"
  (list 'car (list 'cddddr x)))

#+acl2-loop-only
(defmacro sixth (x)
  ":Doc-Section ACL2::ACL2-built-ins

  sixth member of the list~/

  See any Common Lisp documentation for details.~/~/"
  (list 'cadr (list 'cddddr x)))

#+acl2-loop-only
(defmacro seventh (x)
  ":Doc-Section ACL2::ACL2-built-ins

  seventh member of the list~/

  See any Common Lisp documentation for details.~/~/"
  (list 'caddr (list 'cddddr x)))

#+acl2-loop-only
(defmacro eighth (x)
  ":Doc-Section ACL2::ACL2-built-ins

  eighth member of the list~/

  See any Common Lisp documentation for details.~/~/"
  (list 'cadddr (list 'cddddr x)))

#+acl2-loop-only
(defmacro ninth (x)
  ":Doc-Section ACL2::ACL2-built-ins

  ninth member of the list~/

  See any Common Lisp documentation for details.~/~/"
  (list 'car (list 'cddddr (list 'cddddr x))))

#+acl2-loop-only
(defmacro tenth (x)
  ":Doc-Section ACL2::ACL2-built-ins

  tenth member of the list~/

  See any Common Lisp documentation for details.~/~/"
  (list 'cadr (list 'cddddr (list 'cddddr x))))

#+acl2-loop-only
(defmacro rest (x)

  ":Doc-Section ACL2::ACL2-built-ins

  rest (~ilc[cdr]) of the list~/

  In the logic, ~c[rest] is just a macro for ~ilc[cdr].~/

  ~c[Rest] is a Common Lisp function.  See any Common Lisp
  documentation for more information.~/"

  (list 'cdr x))

#+acl2-loop-only
(defun identity (x) (declare (xargs :guard t))

  ":Doc-Section ACL2::ACL2-built-ins

  the identity function~/

  ~c[(Identity x)] equals ~c[x]; what else can we say?~/

  ~c[Identity] is a Common Lisp function.  See any Common Lisp
  documentation for more information.~/"

  x)

#+acl2-loop-only
(defun revappend (x y)

  ":Doc-Section ACL2::ACL2-built-ins

  concatentate the ~il[reverse] of one list to another~/

  ~c[(Revappend x y)] ~il[concatenate]s the ~il[reverse] of the list ~c[x] to ~c[y],
  which is also typically a list.~/

  The following theorem characterizes this English description.
  ~bv[]
  (equal (revappend x y)
         (append (reverse x) y))
  ~ev[]
  Hint:  This lemma follows immediately from the definition of ~ilc[reverse]
  and the following lemma.
  ~bv[]
  (defthm revappend-append
    (equal (append (revappend x y) z)
           (revappend x (append y z))))
  ~ev[]

  The ~il[guard] for ~c[(revappend x y)] requires that ~c[x] is a true list.

  ~c[Revappend] is defined in Common Lisp.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (true-listp x)))
  (if (endp x)
      y
    (revappend (cdr x) (cons (car x) y))))

(defthm character-listp-revappend
  (implies (true-listp x)
           (equal (character-listp (revappend x y))
                  (and (character-listp x)
                       (character-listp y))))

; In some versions of ACL2, the following :induct hint hasn't been necessary.

  :hints (("Goal" :induct (revappend x y))))

#+acl2-loop-only
(defun reverse (x)

  ":Doc-Section ACL2::ACL2-built-ins

  reverse a list or string~/

  ~c[(Reverse x)] is the result of reversing the order of the
  elements of the list or string ~c[x].~/

  The ~il[guard] for ~c[reverse] requires that its argument is a true list
  or a string.

  ~c[Reverse] is defined in Common Lisp.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (or (true-listp x)
                             (stringp x))))
  (cond ((stringp x)
         (coerce (revappend (coerce x 'list) nil) 'string))
        (t (revappend x nil))))

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

  a variety of ways to modify the ACL2 environment~/

  The beginning user might pay special attention to documentation for
  ~ilc[logic] and ~ilc[program].  Other topics in this section can be read as
  one gains familiarity with ACL2.~/~/")

(defconst *valid-output-names*
  '(error warning warning! observation prove proof-checker event expansion
          summary proof-tree))

; Set-difference$

(defun set-difference-eq-exec (l1 l2)
  (declare (xargs :guard (and (true-listp l1)
                              (true-listp l2)
                              (or (symbol-listp l1)
                                  (symbol-listp l2)))))
  (cond ((endp l1) nil)
        ((member-eq (car l1) l2)
         (set-difference-eq-exec (cdr l1) l2))
        (t (cons (car l1) (set-difference-eq-exec (cdr l1) l2)))))

(defun set-difference-eql-exec (l1 l2)
  (declare (xargs :guard (and (true-listp l1)
                              (true-listp l2)
                              (or (eqlable-listp l1)
                                  (eqlable-listp l2)))))
  (cond ((endp l1) nil)
        ((member (car l1) l2)
         (set-difference-eql-exec (cdr l1) l2))
        (t (cons (car l1) (set-difference-eql-exec (cdr l1) l2)))))

(defun set-difference-equal (l1 l2)
  (declare (xargs :guard (and (true-listp l1)
                              (true-listp l2))))
  (cond ((endp l1) nil)
        ((member-equal (car l1) l2)
         (set-difference-equal (cdr l1) l2))
        (t (cons (car l1) (set-difference-equal (cdr l1) l2)))))

(defmacro set-difference-eq (l1 l2)
  `(set-difference$ ,l1 ,l2 :test 'eq))

(defthm set-difference-eq-exec-is-set-difference-equal
  (equal (set-difference-eq-exec l1 l2)
         (set-difference-equal l1 l2)))

(defthm set-difference-eql-exec-is-set-difference-equal
  (equal (set-difference-eql-exec l1 l2)
         (set-difference-equal l1 l2)))

(defmacro set-difference$ (l1 l2 &key (test ''eql))

  ":Doc-Section ACL2::ACL2-built-ins

  elements of one list that are not elements of another~/
  ~bv[]
  General Forms:
  (set-difference$ l1 l2)
  (set-difference$ l1 l2 :test 'eql)   ; same as above (eql as equality test)
  (set-difference$ l1 l2 :test 'eq)    ; same, but eq is equality test
  (set-difference$ l1 l2 :test 'equal) ; same, but equal is equality test
  ~ev[]

  ~c[(Set-difference$ l1 l2)] equals a list that contains the ~ilc[member]s of
  ~c[l1] that are not ~ilc[member]s of ~c[l2].  More precisely, the resulting
  list is the same as one gets by deleting the members of ~c[l2] from ~c[l1],
  leaving the remaining elements in the same order as in ~c[l1].  The optional
  keyword, ~c[:TEST], has no effect logically, but provides the test (default
  ~ilc[eql]) used for comparing members of the two lists.~/

  The ~il[guard] for a call of ~c[set-difference$] depends on the test.  In all
  cases, both arguments must satisfy ~ilc[true-listp].  If the test is
  ~ilc[eql], then one of the arguments must satisfy ~ilc[eqlable-listp].  If
  the test is ~ilc[eq], then one of the arguments must satisfy
  ~ilc[symbol-listp].

  ~l[equality-variants] for a discussion of the relation between
  ~c[set-difference$] and its variants:
  ~bq[]
  ~c[(set-difference-eq l1 l2)] is equivalent to
  ~c[(set-difference$ l1 l2 :test 'eq)];

  ~c[(set-difference-equal l1 l2)] is equivalent to
  ~c[(set-difference$ l1 l2 :test 'equal)].
  ~eq[]
  In particular, reasoning about any of these primitives reduces to reasoning
  about the function ~c[set-difference-equal].

  ~c[Set-difference$] is similar to the Common Lisp primitive
  ~c[set-difference].  However, Common Lisp does not specify the order of
  elements in the result of a call of ~c[set-difference].~/"

  (declare (xargs :guard (or (equal test ''eq)
                             (equal test ''eql)
                             (equal test ''equal))))
  (cond
   ((equal test ''eq)
    `(let-mbe ((l1 ,l1) (l2 ,l2))
              :logic (set-difference-equal l1 l2)
              :exec  (set-difference-eq-exec l1 l2)))
   ((equal test ''eql)
    `(let-mbe ((l1 ,l1) (l2 ,l2))
              :logic (set-difference-equal l1 l2)
              :exec  (set-difference-eql-exec l1 l2)))
   (t ; (equal test 'equal)
    `(set-difference-equal ,l1 ,l2))))

#+acl2-loop-only
(defun listp (x)

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for (not necessarily proper) lists~/

  ~c[(listp x)] is true when ~c[x] is either a ~ilc[cons] pair or is
  ~c[nil].~/

  ~c[Listp] has no ~il[guard], i.e., its ~il[guard] is ~c[t].

  ~c[Listp] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :mode :logic :guard t))
  (or (consp x)
      (equal x nil)))

(defconst *summary-types*
  '(header form rules hint-events warnings time steps value splitter-rules))

(defun with-output-fn (ctx args off on gag-mode off-on-p gag-p stack
                           summary summary-p)
  (declare (xargs :mode :program
                  :guard (true-listp args)))
  (cond
   ((endp args) nil)
   ((keywordp (car args))
    (let ((illegal-value-string
           "~x0 is not a legal value for a call of with-output, but has been ~
            supplied for keyword ~x1.  See :DOC with-output."))
      (cond
       ((consp (cdr args))
        (cond
         ((eq (car args) :gag-mode)
          (cond
           ((member-eq
             (cadr args)
             '(t :goals nil)) ; keep this list in sync with set-gag-mode
            (with-output-fn ctx (cddr args) off on (cadr args) off-on-p t
                           stack summary summary-p))
           (t (illegal ctx
                       illegal-value-string
                       (list (cons #\0 (cadr args))
                             (cons #\1 :gag-mode))))))
         ((eq (car args) :stack)
          (cond
           (stack
            (illegal ctx
                     "The keyword :STACK may only be supplied once in a call ~
                      of ~x0."
                     (list (cons #\0 'with-output))))
           ((member-eq (cadr args) '(:push :pop))
            (with-output-fn ctx (cddr args) off on gag-mode off-on-p gag-p
                           (cadr args) summary summary-p))
           (t (illegal ctx
                       illegal-value-string
                       (list (cons #\0 (cadr args))
                             (cons #\1 :stack))))))
         ((eq (car args) :summary)
          (cond (summary-p
                 (illegal ctx
                          "The keyword :SUMMARY may only be supplied once in ~
                           a call of ~x0."
                          (list (cons #\0 'with-output))))
                ((not (or (eq (cadr args) :all)
                          (and (symbol-listp (cadr args))
                               (subsetp-eq (cadr args) *summary-types*))))
                 (illegal ctx
                          "In a call of ~x0, the value of keyword :SUMMARY ~
                           must either be :ALL or a true-list contained in ~
                           the list ~x1."
                          (list (cons #\0 'with-output)
                                (cons #\1 *summary-types*))))
                (t
                 (with-output-fn ctx (cddr args) off on gag-mode off-on-p gag-p
                                 stack (cadr args) t))))
         ((not (member-eq (car args) '(:on :off)))
          (illegal ctx
                   "~x0 is not a legal keyword for a call of with-output.  ~
                    See :DOC with-output."
                   (list (cons #\0 (car args)))))
         (t (let ((syms (cond ((eq (cadr args) :all)
                               :all)
                              ((symbol-listp (cadr args))
                               (cadr args))
                              ((symbolp (cadr args))
                               (list (cadr args))))))
              (cond (syms
                     (cond ((eq (car args) :on)
                            (and (null on)
                                 (with-output-fn ctx (cddr args) off
                                                 (if (eq syms :all)
                                                     :all
                                                   syms)
                                                 gag-mode t gag-p stack summary
                                                 summary-p)))
                           (t ; (eq (car args) :off)
                            (and (null off)
                                 (with-output-fn ctx (cddr args)
                                                 (if (eq syms :all)
                                                     :all
                                                   syms)
                                                 on gag-mode t gag-p stack
                                                 summary summary-p)))))
                    (t (illegal ctx
                                illegal-value-string
                                (list (cons #\0 (cadr args))
                                      (cons #\1 (car args))))))))))
       (t (illegal ctx
                   "A with-output form has terminated with a keyword, ~x0.  ~
                    This is illegal.  See :DOC with-output."
                   (list (cons #\0 (car args))))))))
   ((cdr args)
    (illegal ctx
             "Illegal with-output form.  See :DOC with-output."
             nil))
   ((not (or (eq off :all)
             (subsetp-eq off *valid-output-names*)))
    (illegal ctx
             "The :off argument to with-output-fn must either be :all or a ~
              subset of the list ~X01, but ~x2 contains ~&3."
             (list (cons #\0 *valid-output-names*)
                   (cons #\1 nil)
                   (cons #\2 off)
                   (cons #\3 (set-difference-eq off *valid-output-names*)))))
   ((not (or (eq on :all)
             (subsetp-eq on *valid-output-names*)))
    (illegal ctx
             "The :on argument to with-output-fn must either be :all or a ~
              subset of the list ~X01, but ~x2 contains ~&3."
             (list (cons #\0 *valid-output-names*)
                   (cons #\1 nil)
                   (cons #\2 on)
                   (cons #\3 (set-difference-eq on *valid-output-names*)))))
   (t
    `(state-global-let*
      (,@
       (and gag-p
            `((gag-mode (f-get-global 'gag-mode state)
                        set-gag-mode-fn)))
       ,@
       (and (or off-on-p
                (eq stack :pop))
            '((inhibit-output-lst (f-get-global 'inhibit-output-lst state))))
       ,@
       (and stack
            '((inhibit-output-lst-stack
               (f-get-global 'inhibit-output-lst-stack state))))
       ,@
       (and summary-p
            `((inhibited-summary-types
               ,(if (eq summary :all)
                    nil
                  (list 'quote
                        (set-difference-eq *summary-types* summary)))))))
      (er-progn
       ,@(and gag-p
              `((pprogn (set-gag-mode ,gag-mode)
                        (value nil))))
       ,@(and stack
              `((pprogn ,(if (eq stack :pop)
                             '(pop-inhibit-output-lst-stack state)
                           '(push-inhibit-output-lst-stack state))
                        (value nil))))
       ,@(and off-on-p
              `((set-inhibit-output-lst
                 ,(cond ((eq on :all)
                         (if (eq off :all)
                             '*valid-output-names*
                           `(quote ,off)))
                        ((eq off :all)
                         `(set-difference-eq *valid-output-names* ',on))
                        (t
                         `(union-eq ',off
                                    (set-difference-eq
                                     (f-get-global 'inhibit-output-lst
                                                   state)
                                     ',on)))))))
       ,(car args))))))

#+acl2-loop-only
(defun last (l)

  ":Doc-Section ACL2::ACL2-built-ins

  the last ~ilc[cons] (not element) of a list~/

  ~c[(Last l)] is the last ~ilc[cons] of a list.  Here are examples.
  ~bv[]
  ACL2 !>(last '(a b . c))
  (B . C)
  ACL2 !>(last '(a b c))
  (C)
  ~ev[]
  ~/

  ~c[(Last l)] has a ~il[guard] of ~c[(listp l)]; thus, ~c[l] need not be a
  ~ilc[true-listp].

  ~c[Last] is a Common Lisp function.  See any Common Lisp
  documentation for more information.  Unlike Common Lisp, we do not
  allow an optional second argument for ~c[last].

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (listp l)))
  (if (atom (cdr l))
      l
    (last (cdr l))))

(defun first-n-ac (i l ac)
  (declare (type (integer 0 *) i)
           (xargs :guard (and (true-listp l)
                              (true-listp ac))))
  (cond ((zp i)
         (reverse ac))
        (t (first-n-ac (1- i) (cdr l) (cons (car l) ac)))))

(defun take (n l)

  ":Doc-Section ACL2::ACL2-built-ins

  initial segment of a list~/

  For any natural number ~c[n] not exceeding the length of ~c[l],
  ~c[(take n l)] collects the first ~c[n] elements of the list ~c[l].~/

  The following is a theorem (though it takes some effort, including
  lemmas, to get ACL2 to prove it):
  ~bv[]
  (equal (length (take n l)) (nfix n))
  ~ev[]
  If ~c[n] is an integer greater than the length of ~c[l], then
  ~c[take] pads the list with the appropriate number of ~c[nil]
  elements.  Thus, the following is also a theorem.
  ~bv[]
  (implies (and (integerp n)
                (true-listp l)
                (<= (length l) n))
           (equal (take n l)
                  (append l (make-list (- n (length l))))))
  ~ev[]
  For related functions, ~pl[nthcdr] and ~pl[butlast].

  The ~il[guard] for ~c[(take n l)] is that ~c[n] is a nonnegative integer
  and ~c[l] is a true list.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard
                   (and (integerp n)
                        (not (< n 0))
                        (true-listp l))))
  #-acl2-loop-only
  (when (<= n most-positive-fixnum)
    (return-from take
                 (loop for i fixnum from 1 to n

; Warning: Do not use "as x in l collect x" on the next line.  Sol Swords
; disovered that at least in CCL, the looping stops in that case when l is
; empty.

                       collect (pop l))))
  (first-n-ac n l nil))

#+acl2-loop-only
(defun butlast (lst n)

  ":Doc-Section ACL2::ACL2-built-ins

  all but a final segment of a list~/

  ~c[(Butlast l n)] is the list obtained by removing the last ~c[n]
  elements from the true list ~c[l].  The following is a theorem
  (though it takes some effort, including lemmas, to get ACL2 to prove
  it).
  ~bv[]
  (implies (and (integerp n)
                (<= 0 n)
                (true-listp l))
           (equal (length (butlast l n))
                  (if (< n (length l))
                      (- (length l) n)
                    0)))
  ~ev[]
  For related functions, ~pl[take] and ~pl[nthcdr].~/

  The ~il[guard] for ~c[(butlast l n)] requires that ~c[n] is a nonnegative
  integer and ~c[lst] is a true list.

  ~c[Butlast] is a Common Lisp function.  See any Common Lisp
  documentation for more information.  Note:  In Common Lisp the
  second argument of ~c[butlast] is optional, but in ACL2 it is
  required.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (true-listp lst)
                              (integerp n)
                              (<= 0 n))))
  (let ((lng (len lst))
        (n (nfix n)))
    (if (<= lng n)
        nil
      (take (- lng n) lst))))

#-acl2-loop-only
(defmacro with-output (&rest args)
  (car (last args)))

#+acl2-loop-only
(defmacro with-output (&rest args)

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

  suppressing or turning on specified output for an event~/
  ~bv[]
  Examples:

  ; Turn off all output during evaluation of the indicated thm form.
  (with-output
   :off :all
   :gag-mode nil
   (thm (equal (app (app x y) z) (app x (app y z)))))

  ; Prove the indicated theorem with the event summary turned off and
  ; using the :goals setting for gag-mode.
  (with-output
     :off summary
     :gag-mode :goals
     (defthm app-assoc (equal (app (app x y) z) (app x (app y z)))))

  ; Same effect as just above:
  (with-output
     :on summary
     :summary nil
     :gag-mode :goals
     (defthm app-assoc (equal (app (app x y) z) (app x (app y z)))))

  ; Turn on only the indicated parts of the summary.
  (with-output
     :on summary
     :summary (time rules)
     :gag-mode :goals  ; use gag-mode, with goal names printed
     (defthm app-assoc (equal (app (app x y) z) (app x (app y z)))))

  ; Same as specifying :off :all, but showing all output types:
  (with-output
   :off (error warning warning! observation prove proof-checker event expansion
               summary proof-tree)
   :gag-mode nil
   (thm (equal (app (app x y) z) (app x (app y z)))))

  ; Same as above, but :stack :push says to save the current
  ; inhibit-output-lst, which can be restored in a subsidiary with-output call
  ; that specifies :stack :pop.
  (with-output
   :stack :push
   :off :all
   :gag-mode nil
   (thm (equal (app (app x y) z) (app x (app y z)))))~/

  General Form:
  (with-output :key1 val1 ... :keyk valk form)
  ~ev[]
  where each ~c[:keyi] is either ~c[:off], ~c[:on], ~c[:stack],
  ~c[:summary], or ~c[:gag-mode]; ~c[form] evaluates to an error triple
  (~pl[error-triples]); and ~c[vali] is as follows.  If ~c[:keyi] is ~c[:off]
  or ~c[:on], then ~c[vali] can be ~c[:all], and otherwise is a symbol or
  non-empty list of symbols representing output types that can be inhibited;
  ~pl[set-inhibit-output-lst].  If ~c[:keyi] is ~c[:gag-mode], then ~c[vali] is
  one of the legal values for ~c[:]~ilc[set-gag-mode].  If ~c[:keyi] is
  ~c[:summary], then ~c[vali] is either ~c[:all] or a true-list of symbols each
  of which belongs to the list ~c[*summary-types*].  Otherwise ~c[:keyi] is
  ~c[:stack], in which case ~c[:vali] is ~c[:push] or ~c[:pop]; for now assume
  that ~c[:stack] is not specified (we'll return to it below).  The result of
  evaluating the General Form above is to evaluate ~c[form], but in an
  environment where output occurs as follows.  If ~c[:on :all] is specified,
  then every output type is turned on except as inhibited by ~c[:off]; else if
  ~c[:off :all] is specified, then every output type is inhibited except as
  specified by ~c[:on]; and otherwise, the currently-inhibited output types are
  reduced as specified by ~c[:on] and then extended as specified by ~c[:off].
  But if ~c[:gag-mode] is specified, then before modifying how output is
  inhibited, ~ilc[gag-mode] is set for the evaluation of ~c[form] as specified
  by the value of ~c[:gag-mode]; ~pl[set-gag-mode].  If ~c[summary] is among
  the output types that are turned on (not inhibited), then if ~c[:summary] is
  specified, the only parts of the summary to be printed will be those
  specified by the value of ~c[:summary].  The correspondence should be clear,
  except perhaps that ~c[header] refers to the line containing only the word
  ~c[Summary], and ~c[value] refers to the value of the form printed during
  evaluation of sequences of events as for ~ilc[progn] and ~ilc[encapsulate].

  Note that the handling of the ~c[:stack] argument pays no attention to the
  ~c[:summary] argument.

  Note: When the scope of ~c[with-output] is exited, then all modifications are
  undone, reverting ~c[gag-mode] and the state of output inhibition to those
  which were present before the ~c[with-output] call was entered.

  The ~c[:stack] keyword's effect is illustrated by the following example,
  where ``~c[(encapsulate nil)]'' may replaced by ``~c[(progn]'' without any
  change to the output that is printed.
  ~bv[]
  (with-output
   :stack :push :off :all
   (encapsulate ()
     (defun f1 (x) x)
     (with-output :stack :pop (defun f2 (x) x))
     (defun f3 (x) x)
     (with-output :stack :pop :off warning (in-theory nil))
     (defun f4 (x) x)))
  ~ev[]
  The outer ~c[with-output] call saves the current output settings (as may
  have been modified by earlier calls of ~ilc[set-inhibit-output-lst]), by
  pushing them onto a stack, and then turns off all output.  Each inner
  ~c[with-output] call temporarily pops that stack, restoring the starting
  output settings, until it completes and undoes the effects of that pop.
  Unless ~c[event] output was inhibited at the top level
  (~pl[set-inhibit-output-lst]), the following output is shown:
  ~bv[]
  Since F2 is non-recursive, its admission is trivial.  We observe that
  the type of F2 is described by the theorem (EQUAL (F2 X) X).
  ~ev[]
  And then, if ~c[summary] output was not inhibited at the top level, we get
  the rest of this output:
  ~bv[]
  Summary
  Form:  ( DEFUN F2 ...)
  Rules: NIL
  Warnings:  None
  Time:  0.00 seconds (prove: 0.00, print: 0.00, other: 0.00)

  Summary
  Form:  ( IN-THEORY NIL)
  Rules: NIL
  Warnings:  None
  Time:  0.00 seconds (prove: 0.00, print: 0.00, other: 0.00)
  ~ev[]
  Note that the use of ~c[:off warning] supresses a ~c[\"Theory\"] warning for
  the ~c[(in-theory nil)] event, and that in no case will output be printed for
  definitions of ~c[f1], ~c[f3], or ~c[f4], or for the ~ilc[encapsulate] event
  itself.

  The following more detailed explanation of ~c[:stack] is intended only for
  advanced users.  After ~c[:gag-mode] is handled (if present) but before
  ~c[:on] or ~c[:off] is handled, the value of ~c[:stack] is handled as
  follows.  If the value is ~c[:push], then ~il[state] global
  ~c[inhibit-output-lst-stack] is modified by pushing the value of ~il[state]
  global ~c[inhibit-output-lst] onto the value of ~il[state] global
  ~c[inhibit-output-lst-stack], which is ~c[nil] at the top level.  If the
  value is ~c[:pop], then ~il[state] global ~c[inhibit-output-lst-stack] is
  modified only if non-~c[nil], in which case its top element is popped and
  becomes the value of of ~il[state] global ~c[inhibit-output-lst].

  Warning: ~c[With-output] has no effect in raw Lisp, and hence is disallowed
  in function bodies.  However, you can probably get the effect you want as
  illustrated below, where ~c[<form>] must return an error triple
  ~c[(mv erp val state)]; ~pl[ld] and ~pl[error-triples].
  ~bv[]
  Examples avoiding with-output, for use in function definitions:

  ; Inhibit all output:
  (state-global-let*
   ((inhibit-output-lst *valid-output-names*))
   <form>)

  ; Inhibit all warning output:
  (state-global-let*
   ((inhibit-output-lst
     (union-eq (f-get-global 'inhibit-output-lst state)
               '(warning warning!))))
   <form>)
  ~ev[]

  Note that ~c[with-output] is allowed in books.  ~l[embedded-event-form]."

  (let ((val
         (with-output-fn 'with-output args nil nil nil nil nil nil nil nil)))
    (or val
        (illegal 'with-output
                 "Macroexpansion of ~q0 failed."
                 (list (cons #\0 (cons 'with-output args)))))))

; Mutual Recursion

; We are about to need mutual recursion for the first time in axioms.lisp.
; We now define the mutual-recursion macro for the logic.

(defun mutual-recursion-guardp (rst)
  (declare (xargs :guard t))
  (cond ((atom rst) (equal rst nil))
        (t (and (consp (car rst))
                (true-listp (car rst))
                (true-listp (caddr (car rst))) ; formals
                (member-eq (car (car rst)) '(defun defund defun-nx defund-nx))
                (mutual-recursion-guardp (cdr rst))))))

(defun collect-cadrs-when-car-eq (x alist)
  (declare (xargs :guard (assoc-eq-equal-alistp alist)))
  (cond ((endp alist) nil)
        ((eq x (car (car alist)))
         (cons (cadr (car alist))
               (collect-cadrs-when-car-eq x (cdr alist))))
        (t (collect-cadrs-when-car-eq x (cdr alist)))))

(defmacro value (x)

; Keep in sync with value@par.

  `(mv nil ,x state))

(defun value-triple-fn (form on-skip-proofs check)
  (declare (xargs :guard t))
  `(cond ((and ,(not on-skip-proofs)
               (f-get-global 'ld-skip-proofsp state))
          (value :skipped))
         (t ,(let ((form
                    `(let ((check ,check))
                       (cond (check
                              (cond
                               ((check-vars-not-free
                                 (check)
                                 ,form)
                                :passed)
                               ((tilde-@p check)
                                (er hard 'value-triple
                                    "Assertion failed:~%~@0~|"
                                    check))
                               (t
                                (er hard 'value-triple
                                    "Assertion failed on form:~%~x0~|"
                                    ',form))))
                             (t ,form)))))
               `(state-global-let*
                 ((safe-mode (not (global-val 'boot-strap-flg (w state)))))
                 (value ,form))))))

#+acl2-loop-only
(defmacro value-triple (form &key on-skip-proofs check)

  ":Doc-Section Events

  compute a value, optionally checking that it is not ~c[nil]~/
  ~bv[]
  Examples:
  (value-triple (+ 3 4))
  (value-triple (cw \"hi\") :on-skip-proofs t)
  (value-triple (@ ld-pre-eval-print))
  (value-triple (@ ld-pre-eval-print) :check t)~/

  General Form:
  (value-triple form
                :on-skip-proofs sp ; optional; nil by default
                :check chk         ; optional; nil by default
                )
  ~ev[]

  ~c[Value-triple] provides a convenient way to evaluate a form in an event
  context, including ~ilc[progn] and ~ilc[encapsulate] and in ~il[books];
  ~pl[events].  The form should evaluate to a single, non-~il[stobj] value.

  Calls of ~c[value-triple] are generally skipped when proofs are being
  skipped, in particular when ACL2 is performing the second pass through the
  ~il[events] of an ~ilc[encapsulate] form or during an ~ilc[include-book], or
  indeed any time ~ilc[ld-skip-proofsp] is non-~c[nil].  If you want the call
  evaluated during those times as well, use a non-~c[nil] value for
  ~c[:on-skip-proofs].  Note that the argument to ~c[:on-skip-proofs] is not
  evaluated.

  If you expect the form to evaluate to a non-~c[nil] value and you want an
  error to occur when that is not the case, you can use ~c[:check t].  More
  generally, the argument of ~c[:check] can be a form that evaluates to a
  single, non-~il[stobj] value.  If this value is not ~c[nil], then the
  aforementioned test is made (that the given form is not ~c[nil]).  If an
  error occurs and the value of ~c[:check] is a string or indeed any
  ``message'' suitable for printing by ~ilc[fmt] when supplied as a value for
  tilde-directive ~c[~~@], then that string or message is printed."

  (value-triple-fn form on-skip-proofs check))

(defmacro assert-event (form &key on-skip-proofs msg)

  ":Doc-Section Events

  assert that a given form returns a non-~c[nil] value~/
  ~bv[]
  Examples:
  (assert-event (equal (+ 3 4) 7))
  (assert-event (equal (+ 3 4) 7) :msg (msg \"Error: ~~x0\" 'equal-check))
  (assert-event (equal (+ 3 4) 7) :on-skip-proofs t)~/

  General Forms:
  (assert-event form)
  (assert-event form :on-skip-proofs t)
  ~ev[]

  ~c[Assert-event] takes a ground form, i.e., one with no free variables;
  ~ilc[stobj]s are allowed but only a single non-~ilc[stobj] value can be
  returned.  The form is then evaluated and if the result is ~c[nil], then a
  so-called hard error (~pl[er]) results.  This evaluation is however not done
  if proofs are being skipped, as during ~ilc[include-book] (also
  ~pl[skip-proofs] and ~pl[ld-skip-proofsp]), unless ~c[:on-skip-proofs t] is
  supplied.

  Normally, if an ~c[assert-event] call fails then a generic failure message is
  printed, showing the offending form.  However, if keyword argument ~c[:msg]
  is supplied, then the failure message is printed as with ~ilc[fmt] argument
  ~c[~~@0]; ~pl[fmt].  In particular, ~c[:msg] is typically a string or a call
  ~c[(msg str arg-0 arg-1 ... arg-k)], where ~c[str] is a string and each
  ~c[arg-i] is the value to be associated with ~c[#\\i] upon formatted printing
  (as with ~ilc[fmt]) of the string ~c[str].

  This form may be put into a book to be certified (~pl[books]), because
  ~c[assert-event] is a macro whose calls expand to calls of ~c[value-triple]
  (~pl[embedded-event-form]).  When certifying a book, guard-checking is off,
  as though ~c[(set-guard-checking nil)] has been evaluated;
  ~pl[set-guard-checking].  That, together with a ``safe mode,'' guarantees
  that ~c[assert-event] forms are evaluated in the logic without guard
  violations while certifying a book.~/"

  (declare (xargs :guard (booleanp on-skip-proofs)))
  `(value-triple ,form
                 :on-skip-proofs ,on-skip-proofs
                 :check ,(or msg t)))

(defun xd-name (event-type name)
  (declare (xargs :guard (member-eq event-type '(defund defthmd))))
  (cond
   ((eq event-type 'defund)
    (list :defund  name))
   ((eq event-type 'defthmd)
    (list :defthmd name))
   (t (illegal 'xd-name
               "Unexpected event-type for xd-name, ~x0"
               (list (cons #\0 event-type))))))

(defun defund-name-list (defuns acc)
  (declare (xargs :guard (and (mutual-recursion-guardp defuns)
                              (true-listp acc))))
  (cond ((endp defuns) (reverse acc))
        (t (defund-name-list
             (cdr defuns)
             (cons (if (eq (caar defuns) 'defund)
                       (xd-name 'defund (cadar defuns))
                     (cadar defuns))
                   acc)))))

; Begin support for defun-nx.

(defun throw-nonexec-error (fn actuals)
  (declare (xargs :guard

; An appropriate guard would seem to be the following.

;                 (if (keywordp fn)
;                     (eq fn :non-exec)
;                   (and (symbolp fn)
;                        (true-listp actuals)))

; However, we want to be sure that the raw Lisp code is evaluated even if
; guard-checking has been set to :none.  A simple fix is to replace the actuals
; if they are ill-formed, and that is what we do.

                  t
                  :verify-guards nil)
           #+acl2-loop-only
           (ignore fn actuals))
  #-acl2-loop-only
  (progn
    (throw-raw-ev-fncall
     (list* 'ev-fncall-null-body-er

; The following nil means that we never blame non-executability on aokp.  Note
; that defproxy is not relevant here, since that macro generates a call of
; install-event-defuns, which calls intro-udf-lst2, which calls null-body-er
; to lay down a call of throw-or-attach.  So in the defproxy case,
; throw-nonexec-error doesn't get called!

            nil
            fn
            (if (eq fn :non-exec)
                actuals
              (print-list-without-stobj-arrays
               (if (true-listp actuals)
                   actuals
                 (error "Unexpected case: Ill-formed actuals for ~
                         throw-nonexec-error!"))))))

; Just in case throw-raw-ev-fncall doesn't throw -- though it always should.

    (error "This error is caused by what should be dead code!"))
  nil)

(defun defun-nx-fn (form disabledp)
  (declare (xargs :guard (and (true-listp form)
                              (true-listp (caddr form)))
                  :verify-guards nil))
  (let ((name (cadr form))
        (formals (caddr form))
        (rest (cdddr form))
        (defunx (if disabledp 'defund 'defun)))
    `(,defunx ,name ,formals
       (declare (xargs :non-executable t :mode :logic))
       ,@(butlast rest 1)
       (prog2$ (throw-nonexec-error ',name (list ,@formals))
               ,@(last rest)))))

(defmacro defun-nx (&whole form &rest rest)

  ":Doc-Section acl2::Events

  define a non-executable function symbol~/

  ~bv[]
  Example:

  (set-state-ok t)
  (defun-nx foo (x state)
    (mv-let (a b c)
            (cons x state)
            (list a b c b a)))
  ; Note ``ill-formed'' call of foo just below.
  (defun bar (state y)
    (foo state y))
  ~ev[]

  The macro ~c[defun-nx] introduces definitions using the ~ilc[defun] macro,
  always in ~c[:]~ilc[logic] mode, such that the calls of the resulting
  function cannot be evaluated.  Such a definition is admitted without
  enforcing syntactic restrictions for executability, in particular for
  single-threadedness (~pl[stobj]) and multiple-values passing (~pl[mv] and
  ~pl[mv-let]).  After such a definition is admitted, the usual syntactic rules
  for ~ilc[state] and user-defined ~il[stobj]s are relaxed for calls of the
  function it defines.  Also ~pl[non-exec] for a way to designate subterms of
  function bodies, or subterms of code to be executed at the top level, as
  non-executable.

  The syntax of ~c[defun-nx] is identical to that of ~ilc[defun].  A form
  ~bv[]
  (defun-nx name (x1 ... xk) ... body)
  ~ev[]
  expands to the following form.
  ~bv[]
  (defun name (x1 ... xk)
    (declare (xargs :non-executable t :mode :logic))
    ...
    (prog2$ (throw-nonexec-error 'name (list x1 ... xk))
            body))
  ~ev[]
  Note that because of the insertion of the above call of
  ~c[throw-nonexec-error], no formal is ignored when using ~c[defun-nx].~/

  During proofs, the error is silent; it is ``caught'' by the proof mechanism
  and generally results in the introduction of a call of ~ilc[hide] during a
  proof.  If an error message is produced by evaluating a call of the function
  on a list of arguments that includes ~c[state] or user-defined ~ilc[stobj]s,
  these arguments will be shown as symbols such as ~c[|<state>|] in the error
  message.  In the case of a user-defined stobj bound by ~ilc[with-local-stobj]
  or ~ilc[stobj-let], the symbol printed will include the suffix
  ~c[{instance}], for example, ~c[|<st>{instance}|].

  It is harmless to include ~c[:non-executable t] in your own ~ilc[xargs]
  ~ilc[declare] form; ~c[defun-nx] will still lay down its own such
  declaration, but ACL2 can tolerate the duplication.

  Note that ~c[defund-nx] is also available.  It has an effect identical to
  that of ~c[defun-nx] except that as with ~ilc[defund], it leaves the function
  disabled.

  If you use guards (~pl[guard]), please be aware that even though syntactic
  restrictions are relaxed for ~c[defun-nx], guard verification proceeds
  exactly as for ~ilc[defun].  If you want ACL2 to skip a form for purposes of
  generating guard proof obligations, use the macro ~ilc[non-exec], which
  generates a call of ~c[throw-nonexec-error] that differs somewhat from the
  one displayed above.  ~l[non-exec].

  ~l[defun] for documentation of ~c[defun]."

  (declare (xargs :guard (and (true-listp form)
                              (true-listp (caddr form))))
           (ignore rest))
  (defun-nx-fn form nil))

(defmacro defund-nx (&whole form &rest rest)
  (declare (xargs :guard (and (true-listp form)
                              (true-listp (caddr form))))
           (ignore rest))
  (defun-nx-fn form t))

(defun update-mutual-recursion-for-defun-nx-1 (defs)
  (declare (xargs :guard (mutual-recursion-guardp defs)
                  :verify-guards nil))
  (cond ((endp defs)
         nil)
        ((eq (caar defs) 'defun-nx)
         (cons (defun-nx-fn (car defs) nil)
               (update-mutual-recursion-for-defun-nx-1 (cdr defs))))
        ((eq (caar defs) 'defund-nx)
         (cons (defun-nx-fn (car defs) t)
               (update-mutual-recursion-for-defun-nx-1 (cdr defs))))
        (t
         (cons (car defs)
               (update-mutual-recursion-for-defun-nx-1 (cdr defs))))))

(defun update-mutual-recursion-for-defun-nx (defs)
  (declare (xargs :guard (mutual-recursion-guardp defs)
                  :verify-guards nil))
  (cond ((or (assoc-eq 'defun-nx defs)
             (assoc-eq 'defund-nx defs))
         (update-mutual-recursion-for-defun-nx-1 defs))
        (t defs)))

#+acl2-loop-only
(defmacro mutual-recursion (&whole event-form &rest rst)

  ":Doc-Section Events

  define some mutually recursive functions~/
  ~bv[]
  Example:
  (mutual-recursion
   (defun evenlp (x)
     (if (consp x) (oddlp (cdr x)) t))
   (defun oddlp (x)
     (if (consp x) (evenlp (cdr x)) nil)))~/

  General Form:
  (mutual-recursion def1 ... defn)
  where each ~c[defi] is a call of ~ilc[defun], ~ilc[defund], ~ilc[defun-nx],
  or ~c[defund-nx].
  ~ev[]
  When mutually recursive functions are introduced it is necessary
  to do the termination analysis on the entire clique of definitions.
  Each ~ilc[defun] form specifies its own measure, either with the ~c[:measure]
  keyword ~c[xarg] (~pl[xargs]) or by default to ~ilc[acl2-count].  When a
  function in the clique calls a function in the clique, the measure
  of the callee's actuals must be smaller than the measure of the
  caller's formals ~-[] just as in the case of a simply recursive
  function.  But with mutual recursion, the callee's actuals are
  measured as specified by the callee's ~ilc[defun] while the caller's
  formals are measured as specified by the caller's ~ilc[defun].  These two
  measures may be different but must be comparable in the sense that
  ~ilc[o<] decreases through calls.

  If you want to specify ~c[:]~ilc[hints] or ~c[:guard-hints] (~pl[xargs]), you
  can put them in the ~ilc[xargs] declaration of any of the ~ilc[defun] forms,
  as the ~c[:]~ilc[hints] from each form will be appended together, as will the
  ~ilc[guard-hints] from each form.

  You may find it helpful to use a lexicographic order, the idea being to have
  a measure that returns a list of two arguments, where the first takes
  priority over the second.  Here is an example.
  ~bv[]
  (include-book \"ordinals/lexicographic-ordering\" :dir :system)

  (encapsulate
   ()
   (set-well-founded-relation l<) ; will be treated as LOCAL

   (mutual-recursion
    (defun foo (x)
      (declare (xargs :measure (list (acl2-count x) 1)))
      (bar x))
    (defun bar (y)
      (declare (xargs :measure (list (acl2-count y) 0)))
      (if (zp y) y (foo (1- y))))))
  ~ev[]

  The ~ilc[guard] analysis must also be done for all of the functions at the
  same time.  If any one of the ~ilc[defun]s specifies the
  ~c[:]~ilc[verify-guards] ~c[xarg] to be ~c[nil], then ~il[guard] verification
  is omitted for all of the functions.  Similarly, if any one of the
  ~ilc[defun]s specifies the ~c[:non-executable] ~c[xarg] to be ~c[t], or if
  any of the definitions uses ~ilc[defun-nx] or ~c[defund-nx], then every one
  of the definitions will be treated as though it specifies a
  ~c[:non-executable] ~c[xarg] of ~c[t].

  Technical Note: Each ~c[defi] above must be a call of ~ilc[defun],
  ~ilc[defund], ~ilc[defun-nx], or ~c[defund-nx].  In particular, it is not
  permitted for a ~c[defi] to be an arbitrary form that macroexpands into a
  ~ilc[defun] form.  This is because ~c[mutual-recursion] is itself a macro,
  and since macroexpansion occurs from the outside in, at the time
  ~c[(mutual-recursion def1 ... defk)] is expanded the ~c[defi] have not yet
  been macroexpanded.

  Suppose you have defined your own ~ilc[defun]-like macro and wish to use
  it in a ~c[mutual-recursion] expression.  Well, you can't.  (!)  But you
  can define your own version of ~c[mutual-recursion] that allows your
  ~ilc[defun]-like form.  Here is an example.  Suppose you define
  ~bv[]
  (defmacro my-defun (&rest args) (my-defun-fn args))
  ~ev[]
  where ~c[my-defun-fn] takes the arguments of the ~c[my-defun] form and
  produces from them a ~ilc[defun] form.  As noted above, you are not
  allowed to write ~c[(mutual-recursion (my-defun ...) ...)].  But you can
  define the macro ~c[my-mutual-recursion] so that
  ~bv[]
  (my-mutual-recursion (my-defun ...) ... (my-defun ...))
  ~ev[]
  expands into ~c[(mutual-recursion (defun ...) ... (defun ...))] by
  applying ~c[my-defun-fn] to each of the arguments of
  ~c[my-mutual-recursion].
  ~bv[]
  (defun my-mutual-recursion-fn (lst)
    (declare (xargs :guard (alistp lst)))

  ; Each element of lst must be a consp (whose car, we assume, is always
  ; MY-DEFUN).  We apply my-defun-fn to the arguments of each element and
  ; collect the resulting list of DEFUNs.

    (cond ((atom lst) nil)
          (t (cons (my-defun-fn (cdr (car lst)))
                   (my-mutual-recursion-fn (cdr lst))))))

  (defmacro my-mutual-recursion (&rest lst)

  ; Each element of lst must be a consp (whose car, we assume, is always
  ; MY-DEFUN).  We obtain the DEFUN corresponding to each and list them
  ; all inside a MUTUAL-RECURSION form.

    (declare (xargs :guard (alistp lst)))
    (cons 'mutual-recursion (my-mutual-recursion-fn lst))).
  ~ev[]~/

  :cited-by Programming"

  (declare (xargs :guard (mutual-recursion-guardp rst)))
  (let ((rst (update-mutual-recursion-for-defun-nx rst)))
    (let ((form (list 'defuns-fn
                      (list 'quote (strip-cdrs rst))
                      'state
                      (list 'quote event-form)
                      #+:non-standard-analysis ; std-p
                      nil)))
      (cond
       ((assoc-eq 'defund rst)
        (list 'er-progn
              form
              (list
               'with-output
               :off 'summary
               (list 'in-theory
                     (cons 'disable
                           (collect-cadrs-when-car-eq 'defund rst))))
              (list 'value-triple (list 'quote (defund-name-list rst nil)))))
       (t
        form)))))

; Now we define the weak notion of term that guards metafunctions.

(mutual-recursion

(defun pseudo-termp (x)

  ":Doc-Section ACL2::ACL2-built-ins

  a predicate for recognizing term-like s-expressions~/
  ~bv[]
  Example Forms:
  (pseudo-termp '(car (cons x 'nil)))      ; has value t
  (pseudo-termp '(car x y z))              ; also has value t!
  (pseudo-termp '(delta (h x)))            ; has value t
  (pseudo-termp '(delta (h x) . 7))        ; has value nil (not a true-listp)
  (pseudo-termp '((lambda (x) (car x)) b)) ; has value t
  (pseudo-termp '(if x y 123))             ; has value nil (123 is not quoted)
  (pseudo-termp '(if x y '123))            ; has value t
  ~ev[]
  If ~c[x] is the quotation of a term, then ~c[(pseudo-termp x)] is ~c[t].
  However, if ~c[x] is not the quotation of a term it is not necessarily
  the case that ~c[(pseudo-termp x)] is ~c[nil].~/

  ~l[term] for a discussion of the various meanings of the word
  ``term'' in ACL2.  In its most strict sense, a term is either a
  legal variable symbol, a quoted constant, or the application of an
  ~c[n]-ary function symbol or closed ~c[lambda]-expression to ~c[n] terms.  By
  ``legal variable symbol'' we exclude constant symbols, such as ~c[t],
  ~c[nil], and ~c[*ts-rational*].  By ``quoted constants'' we include ~c['t] (aka
  ~c[(quote t)]), ~c['nil], ~c['31], etc., and exclude constant names such as ~c[t],
  ~c[nil] and ~c[*ts-rational*], unquoted constants such as ~c[31] or ~c[1/2], and
  ill-formed ~c[quote] expressions such as ~c[(quote 3 4)].  By ``closed
  lambda expression'' we exclude expressions, such as
  ~c[(lambda (x) (cons x y))], containing free variables in their bodies.
  Terms typed by the user are translated into strict terms for
  internal use in ACL2.

  The predicate ~c[termp] checks this strict sense of ``term'' with
  respect to a given ACL2 logical world; ~l[world].  Many ACL2
  functions, such as the rewriter, require certain of their arguments
  to satisfy ~c[termp].  However, as of this writing, ~c[termp] is in ~c[:]~ilc[program]
  mode and thus cannot be used effectively in conjectures to be
  proved.  Furthermore, if regarded simply from the perspective of an
  effective ~il[guard] for a term-processing function, ~c[termp] checks many
  irrelevant things.  (Does it really matter that the variable symbols
  encountered never start and end with an asterisk?)  For these
  reasons, we have introduced the notion of a ``pseudo-term'' and
  embodied it in the predicate ~c[pseudo-termp], which is easier to
  check, does not require the logical ~il[world] as input, has ~c[:]~ilc[logic]
  mode, and is often perfectly suitable as a ~il[guard] on term-processing
  functions.

  A ~c[pseudo-termp] is either a symbol, a true list of length 2
  beginning with the word ~c[quote], the application of an ~c[n]-ary
  pseudo-~c[lambda] expression to a true list of ~c[n] pseudo-terms, or
  the application of a symbol to a true list of ~c[n] ~c[pseudo-termp]s.
  By an ``~c[n]-ary pseudo-~c[lambda] expression'' we mean an expression
  of the form ~c[(lambda (v1 ... vn) pterm)], where the ~c[vi] are
  symbols (but not necessarily distinct legal variable symbols) and
  ~c[pterm] is a ~c[pseudo-termp].

  Metafunctions may use ~c[pseudo-termp] as a ~il[guard]."

  (declare (xargs :guard t :mode :logic))
  (cond ((atom x) (symbolp x))
        ((eq (car x) 'quote)
         (and (consp (cdr x))
              (null (cdr (cdr x)))))
        ((not (true-listp x)) nil)
        ((not (pseudo-term-listp (cdr x))) nil)
        (t (or (symbolp (car x))

; For most function applications we do not check that the number of
; arguments matches the number of formals.  However, for lambda
; applications we do make that check.  The reason is that the
; constraint on an evaluator dealing with lambda applications must use
; pairlis$ to pair the formals with the actuals and pairlis$ insists on
; the checks below.

               (and (true-listp (car x))
                    (equal (length (car x)) 3)
                    (eq (car (car x)) 'lambda)
                    (symbol-listp (cadr (car x)))
                    (pseudo-termp (caddr (car x)))
                    (equal (length (cadr (car x)))
                           (length (cdr x))))))))

(defun pseudo-term-listp (lst)
  (declare (xargs :guard t))
  (cond ((atom lst) (equal lst nil))
        (t (and (pseudo-termp (car lst))
                (pseudo-term-listp (cdr lst))))))

)

(defthm pseudo-term-listp-forward-to-true-listp
  (implies (pseudo-term-listp x)
           (true-listp x))
  :rule-classes :forward-chaining)

; For the encapsulate of too-many-ifs-post-rewrite
(encapsulate
 ()
 (table acl2-defaults-table :defun-mode :logic)
 (verify-guards pseudo-termp))

(defun pseudo-term-list-listp (l)
  (declare (xargs :guard t))
  (if (atom l)
      (equal l nil)
    (and (pseudo-term-listp (car l))
         (pseudo-term-list-listp (cdr l)))))

(verify-guards pseudo-term-list-listp)

; Add-to-set

(defun add-to-set-eq-exec (x lst)
  (declare (xargs :guard (if (symbolp x)
                             (true-listp lst)
                           (symbol-listp lst))))
  (cond ((member-eq x lst) lst)
        (t (cons x lst))))

(defun add-to-set-eql-exec (x lst)
  (declare (xargs :guard (if (eqlablep x)
                             (true-listp lst)
                           (eqlable-listp lst))))
  (cond ((member x lst) lst)
        (t (cons x lst))))

(defun add-to-set-equal (x l)
  (declare (xargs :guard (true-listp l)))

; Warning: This function is used by include-book-fn to add a
; certification tuple to the include-book-alist.  We exploit the fact
; that if the tuple, x, isn't already in the list, l, then this
; function adds it at the front!  So don't change this function
; without recoding include-book-fn.

  (cond ((member-equal x l)
         l)
        (t (cons x l))))

(defmacro add-to-set-eq (x lst)
  `(add-to-set ,x ,lst :test 'eq))

; Added for backward compatibility (add-to-set-eql was present through
; Version_4.2):
(defmacro add-to-set-eql (x lst)
  `(add-to-set ,x ,lst :test 'eql))

(defthm add-to-set-eq-exec-is-add-to-set-equal
  (equal (add-to-set-eq-exec x lst)
         (add-to-set-equal x lst)))

(defthm add-to-set-eql-exec-is-add-to-set-equal
  (equal (add-to-set-eql-exec x lst)
         (add-to-set-equal x lst)))

; Disable non-recursive functions to assist in discharging mbe guard proof
; obligations.
(in-theory (disable add-to-set-eq-exec add-to-set-eql-exec))

(defmacro add-to-set (x lst &key (test ''eql))

  ":Doc-Section ACL2::ACL2-built-ins

  add a symbol to a list~/
  ~bv[]
  General Forms:
  (add-to-set x lst)
  (add-to-set x lst :test 'eql)   ; same as above (eql as equality test)
  (add-to-set x lst :test 'eq)    ; same, but eq is equality test
  (add-to-set x lst :test 'equal) ; same, but equal is equality test
  ~ev[]

  For a symbol ~c[x] and an object ~c[lst], ~c[(add-to-set-eq x lst)] is the
  result of ~ilc[cons]ing ~c[x] on to the front of ~c[lst], unless ~c[x] is
  already a ~ilc[member] of ~c[lst], in which case the result is ~c[lst]. The
  optional keyword, ~c[:TEST], has no effect logically, but provides the
  test (default ~ilc[eql]) used for comparing ~c[x] with successive elements of
  ~c[lst].~/

  The ~il[guard] for a call of ~c[add-to-set] depends on the test.  In all
  cases, the second argument must satisfy ~ilc[true-listp].  If the test is
  ~ilc[eql], then either the first argument must be suitable for ~ilc[eql]
  (~pl[eqlablep]) or the second argument must satisfy ~ilc[eqlable-listp].  If
  the test is ~ilc[eq], then either the first argument must be a symbol or the
  second argument must satisfy ~ilc[symbol-listp].

  ~l[equality-variants] for a discussion of the relation between ~c[add-to-set] and
  its variants:
  ~bq[]
  ~c[(add-to-set-eq x lst)] is equivalent to ~c[(add-to-set x lst :test 'eq)];

  ~c[(add-to-set-equal x lst)] is equivalent to ~c[(add-to-set x lst :test 'equal)].
  ~eq[]
  In particular, reasoning about any of these primitives reduces to reasoning
  about the function ~c[add-to-set-equal].~/"

  (declare (xargs :guard (or (equal test ''eq)
                             (equal test ''eql)
                             (equal test ''equal))))
  (cond
   ((equal test ''eq)
    `(let-mbe ((x ,x) (lst ,lst))
              :logic (add-to-set-equal x lst)
              :exec  (add-to-set-eq-exec x lst)))
   ((equal test ''eql)
    `(let-mbe ((x ,x) (lst ,lst))
              :logic (add-to-set-equal x lst)
              :exec  (add-to-set-eql-exec x lst)))
   (t ; (equal test 'equal)
    `(add-to-set-equal ,x ,lst))))

(defmacro variablep (x) (list 'atom x))

(defmacro nvariablep (x) (list 'consp x))

(defmacro fquotep (x) (list 'eq ''quote (list 'car x)))

(defun quotep (x)
  (declare (xargs :guard t))
  (and (consp x)
       (eq (car x) 'quote)))

(defconst *t* (quote (quote t)))
(defconst *nil* (quote (quote nil)))
(defconst *0* (quote (quote 0)))
(defconst *1* (quote (quote 1)))
(defconst *-1* (quote (quote -1)))

(defun kwote (x)

  ":Doc-Section ACL2::ACL2-built-ins

  quote an arbitrary object~/

  For any object ~c[x], ~c[(kwote x)] returns the two-element list whose
  elements are the symbol ~c[quote] and the given ~c[x], respectively.
  The guard of ~c[(kwote x)] is ~c[t].

  To see the ACL2 definition of this function, ~pl[pf].~/~/"

  (declare (xargs :guard t))
  (mbe :logic

; Theorem ev-lambda-clause-correct in community book
; books/centaur/misc/evaluator-metatheorems.lisp goes out to lunch if we use
; the :exec term below as the definition.  So we keep the :logic definition
; simple.

       (list 'quote x)
       :exec ; save conses
       (cond ((eq x nil) *nil*)
             ((eq x t) *t*)
             ((eql x 0) *0*)
             ((eql x 1) *1*)
             ((eql x -1) *-1*)
             (t (list 'quote x)))))

(defun kwote-lst (lst)

  ":Doc-Section ACL2::ACL2-built-ins

  quote an arbitrary true list of objects~/

  The function ~c[kwote-lst] applies the function ~c[kwote] to each element of
  a given list.  The guard of ~c[(kwote-lst lst)] is ~c[(true-listp lst)].

  To see the ACL2 definition of this function, ~pl[pf].~/~/"

  (declare (xargs :guard (true-listp lst)))
  (cond ((endp lst) nil)
        (t (cons (kwote (car lst)) (kwote-lst (cdr lst))))))

(defmacro unquote (x) (list 'cadr x))

(defmacro ffn-symb (x) (list 'car x))

(defun fn-symb (x)
  (declare (xargs :guard t))
  (if (and (nvariablep x)
           (not (fquotep x)))
      (car x)
    nil))

(defmacro fargs (x) (list 'cdr x))

(mutual-recursion

(defun all-vars1 (term ans)
  (declare (xargs :guard (and (pseudo-termp term)
                              (symbol-listp ans))
                  :mode :program))
  (cond ((variablep term)
         (add-to-set-eq term ans))
        ((fquotep term) ans)
        (t (all-vars1-lst (fargs term) ans))))

(defun all-vars1-lst (lst ans)
  (declare (xargs :guard (and (pseudo-term-listp lst)
                              (symbol-listp ans))
                  :mode :program))
  (cond ((endp lst) ans)
        (t (all-vars1-lst (cdr lst)
                          (all-vars1 (car lst) ans)))))

)

(verify-termination-boot-strap
 (all-vars1 (declare (xargs :mode :logic :verify-guards nil)))
 (all-vars1-lst (declare (xargs :mode :logic))))

(defun all-vars (term)

; This function collects the variables in term in reverse print order of
; first occurrence.  E.g., all-vars of '(f (g a b) c) is '(c b a).
; This ordering is exploited by, at least, loop-stopper and bad-synp-hyp.

  (declare (xargs :guard (pseudo-termp term)
                  :verify-guards nil))
  (all-vars1 term nil))

; Progn.

; The definition of er-progn-fn below exposes a deficiency in ACL2 not
; present in full Common Lisp, namely ACL2's inability to generate a
; really ``new'' variable the way one can in a Common Lisp macro via
; gensym.  One would like to be sure that in binding the two variables
; er-progn-not-to-be-used-elsewhere-erp
; er-progn-not-to-be-used-elsewhere-val that they were not used
; anywhere in the subsequent macro expansion of lst.  If one had the
; macro expansion of lst at hand, one could manufacture a variable
; that was not free in the expansion with genvars, and that would do.

; As a less than elegant rememdy to the situation, we introduce below
; the macro check-vars-not-free, which takes two arguments, the first
; a not-to-be-evaluated list of variable names and the second an
; expression.  We arrange to return the translation of the expression
; provided none of the variables occur freely in it.  Otherwise, an error
; is caused.  The situation is subtle because we cannot even obtain
; the free vars in an expression until it has been translated.  For
; example, (value x) has the free var STATE in it, thanks to the macro
; expansion of value.  But a macro can't call translate because macros
; can't get their hands on state.

; In an earlier version of this we built check-vars-not-free into
; translate itself.  We defined it with a defmacro that expanded to
; its second arg, but translate did not actually look at the macro
; (raw lisp did) and instead implemented the semantics described
; above.  Of course, if no error was caused the semantics agreed with
; the treatment and if an error was caused, all bets are off anyway.
; The trouble with that approach was that it worked fine as long as
; check-vars-not-free was the only such example we had of needing to
; look at the translated form of something in a macro.  Unfortunately,
; others came along.  So we invented the more general
; translate-and-test and now use it to define check-vars-not-free.

(defmacro translate-and-test (test-fn form)

; Test-fn should be a LAMBDA expression (or function or macro symbol)
; of one non-STATE argument, and form is an arbitrary form.  Logically
; we ignore test-fn and return form.  However, an error is caused by
; TRANSLATE if the translation of form is not "approved" by test-fn.
; By "approved" we mean that when (test-fn 'term) is evaluated, where
; term is the translation of form, (a) the evaluation completes
; without an error and (b) the result is T.  Otherwise, the result is
; treated as an error msg and displayed.  (Actually, test-fn's answer
; is treated as an error msg if it is a stringp or a consp.  Any other
; result, e.g., T or NIL (!), is treated as "approved.")  If test-fn
; approves then the result of translation is the translation of form.

; For example,
; (translate-and-test
;  (lambda (term)
;   (or (subsetp (all-vars term) '(x y z))
;       (msg "~x0 uses variables other than x, y, and z."
;            term)))
;  <form>)
; is just the translation of <form> provided that translation
; only involves the free vars x, y, and z; otherwise an error is
; caused.  By generating calls of this macro other macros can
; ensure that the <form>s they generate satisfy certain tests
; after those <forms>s are translated.

; This macro is actually implemented in translate.  It can't be
; implemented here because translate isn't defined yet.  However the
; semantics is consistent with the definition below, namely, it just
; expands to its second argument (which is, of course, translated).
; It is just that sometimes errors are caused.

; There are two tempting generalizations of this function.  The first
; is that test-fn should be passed STATE so that it can make more
; "semantic" checks on the translation of form and perhaps so that it
; can signal the error itself.  There is, as far as I know,
; nothing wrong with this generalization except that it is hard to
; implement.  In order for TRANSLATE to determine whether test-fn
; approves of the term it must ev an expression.  If that expression
; involved STATE then translated must pass in its STATE in that
; position.  This requires coercing the state to an object, an act
; which is done with some trepidation in trans-eval and which could,
; presumably, be allowed earlier in translate.

; The second tempting generalization is that test-fn should have the
; power to massage the translation and return a new form which should,
; in turn, be translated.  For example, then one could imagine, say, a
; macro that would permit a form to be turned into the quoted constant
; listing the variables that occur freely in the translated form.  If
; the first generalization above has been carried out, then this would
; permit the translation of a form to be state dependent, which is
; illegal.  But this second generalization is problematic anyway.  In
; particular, what is the raw lisp counterpart of the generalized
; macro?  Note that in its current incarnation, the raw lisp
; counterpart of translate-and-test is the same as its logical
; meaning: it just expands to its second arg.  But if the desired
; expansion is computed from the translation of its second arg, then
; raw lisp would have to translate that argument.  But we can't do
; that for a variety of reasons: (a) CLTL macros shouldn't be state
; dependent, (b) we can't call translate during compilation because in
; general the ACL2 world isn't present, etc.

  (declare (ignore test-fn))
  form)

; Intersectp

(defun intersectp-eq-exec (x y)
  (declare (xargs :guard (and (true-listp x)
                              (true-listp y)
                              (or (symbol-listp x)
                                  (symbol-listp y)))))
  (cond ((endp x) nil)
        ((member-eq (car x) y) t)
        (t (intersectp-eq-exec (cdr x) y))))

(defun intersectp-eql-exec (x y)
  (declare (xargs :guard (and (true-listp x)
                              (true-listp y)
                              (or (eqlable-listp x)
                                  (eqlable-listp y)))))
  (cond ((endp x) nil)
        ((member (car x) y) t)
        (t (intersectp-eql-exec (cdr x) y))))

(defun intersectp-equal (x y)
  (declare (xargs :guard (and (true-listp x)
                              (true-listp y))))
  (cond ((endp x) nil)
        ((member-equal (car x) y) t)
        (t (intersectp-equal (cdr x) y))))

(defmacro intersectp-eq (x y)
  `(intersectp ,x ,y :test 'eq))

(defthm intersectp-eq-exec-is-intersectp-equal
  (equal (intersectp-eq-exec x y)
         (intersectp-equal x y)))

(defthm intersectp-eql-exec-is-intersectp-equal
  (equal (intersectp-eql-exec x y)
         (intersectp-equal x y)))

(defmacro intersectp (x y &key (test ''eql))

  ":Doc-Section ACL2::ACL2-built-ins

  test whether two lists intersect~/
  ~bv[]
  General Forms:
  (set-difference$ l1 l2)
  (set-difference$ l1 l2 :test 'eql)   ; same as above (eql as equality test)
  (set-difference$ l1 l2 :test 'eq)    ; same, but eq is equality test
  (set-difference$ l1 l2 :test 'equal) ; same, but equal is equality test
  ~ev[]

  ~c[(Intersectp l1 l2)] returns ~c[t] if ~c[l1] and ~c[l2] have a ~ilc[member]
  in common, else it returns ~c[nil].  The optional keyword, ~c[:TEST], has no
  effect logically, but provides the test (default ~ilc[eql]) used for
  comparing members of the two lists.~/

  The ~il[guard] for a call of ~c[intersectp] depends on the test.  In all
  cases, both arguments must satisfy ~ilc[true-listp].  If the test is
  ~ilc[eql], then one of the arguments must satisfy ~ilc[eqlable-listp].  If
  the test is ~ilc[eq], then one of the arguments must satisfy
  ~ilc[symbol-listp].

  ~l[equality-variants] for a discussion of the relation between
  ~c[intersectp] and its variants:
  ~bq[]
  ~c[(intersectp-eq x lst)] is equivalent to ~c[(intersectp x lst :test 'eq)];

  ~c[(intersectp-equal x lst)] is equivalent to
  ~c[(intersectp x lst :test 'equal)].
  ~eq[]
  In particular, reasoning about any of these primitives reduces to reasoning
  about the function ~c[intersectp-equal].~/"

  (declare (xargs :guard (or (equal test ''eq)
                             (equal test ''eql)
                             (equal test ''equal))))
  (cond
   ((equal test ''eq)
    `(let-mbe ((x ,x) (y ,y))
              :logic (intersectp-equal x y)
              :exec  (intersectp-eq-exec x y)))
   ((equal test ''eql)
    `(let-mbe ((x ,x) (y ,y))
              :logic (intersectp-equal x y)
              :exec  (intersectp-eql-exec x y)))
   (t ; (equal test 'equal)
    `(intersectp-equal ,x ,y))))

(defun make-fmt-bindings (chars forms)
  (declare (xargs :guard (and (true-listp chars)
                              (true-listp forms)
                              (<= (length forms) (length chars)))))
  (cond ((endp forms) nil)
        (t (list 'cons
                 (list 'cons (car chars) (car forms))
                 (make-fmt-bindings (cdr chars) (cdr forms))))))

(defmacro msg (str &rest args)

; Fmt is defined much later.  But we need msg now because several of our macros
; generate calls of msg and thus msg must be a function when terms using those
; macros are translated.

  ":Doc-Section ACL2::ACL2-built-ins

  construct a ``message'' suitable for the ~c[~~@] directive of ~ilc[fmt]~/

  ~l[fmt] for background on formatted printing with ACL2.

  We document ~c[msg] precisely below, but first, we give an informal
  introduction and illustrate with an example.  Suppose you are writing a
  program that is to do some printing.  Typically, you will either pass the
  ACL2 state around (~pl[programming-with-state]) and use formatted printing
  functions that take the state as an argument (~pl[fmt])), or else you might
  avoid using state by calling the utility, ~ilc[cw], to do you printing.
  Alternatively, you might print error messages upon encountering illegal
  situations; ~pl[er].  But there are times where instead of printing
  immediately, you may prefer to pass messages around, for example to
  accumulate them before printing a final message.  In such cases, it may be
  desirable to construct ``message'' objects to pass around.

  For example, consider the following pair of little programs.  The first
  either performs a computation or prints an error, and the second calls the
  first on two inputs.
  ~bv[]

  (defun invert1 (x)
    (if (consp x)
        (cons (cdr x) (car x))
      (prog2$ (cw \"ERROR: ~~x0 expected a cons, but was given ~~x1.~~|\"
                  'invert1 x)
              nil)))

  (defun invert2 (x1 x2)
    (list (invert1 x1) (invert1 x2)))

  ~ev[]
  For example:
  ~bv[]

    ACL2 !>(invert1 '(3 . 4))
    (4 . 3)
    ACL2 !>(invert1 'a)
    ERROR: INVERT1 expected a cons, but was given A.
    NIL
    ACL2 !>(invert2 '(3 . 4) '(5 . 6))
    ((4 . 3) (6 . 5))
    ACL2 !>(invert2 'a 'b)
    ERROR: INVERT1 expected a cons, but was given A.
    ERROR: INVERT1 expected a cons, but was given B.
    (NIL NIL)
    ACL2 !>

  ~ev[]
  Notice that when there are errors, there is no attempt to explain that these
  are due to a call of ~c[invert2].  That could be fixed, of course, by
  arranging for ~c[invert2] to print its own error; but for complicated
  programs it can be awkward to coordinate printing from many sources.  So
  let's try a different approach.  This time, the first function returns two
  results.  The first result is an ``error indicator'' ~-[] either a message
  object or ~c[nil] ~-[] while the second is the computed value (only of
  interest when the first result is ~c[nil]).  Then the higher-level function
  can print a single error message that includes the error message(s) from the
  lower-level function, as shown below.
  ~bv[]

  (defun invert1a (x)
    (if (consp x)
        (mv nil
            (cons (cdr x) (car x)))
      (mv (msg \"ERROR: ~~x0 expected a cons, but was given ~~x1.~~|\"
               'invert1a x)
          nil)))

  (defun invert2a (x1 x2)
    (mv-let (erp1 y1)
            (invert1a x1)
            (mv-let (erp2 y2)
                    (invert1a x2)
                    (if erp1
                        (if erp2
                            (cw \"~~x0 failed with two errors:~~|  ~~@1  ~~@2\"
                                'invert2a erp1 erp2)
                          (cw \"~~x0 failed with one error:~~|  ~~@1\"
                              'invert2a erp1))
                      (if erp2
                          (cw \"~~x0 failed with one error:~~|  ~~@1\"
                              'invert2a erp2)
                        (list y1 y2))))))
  ~ev[]
  For example:
  ~bv[]
    ACL2 !>(invert2a '(3 . 4) '(5 . 6))
    ((4 . 3) (6 . 5))
    ACL2 !>(invert2a '(3 . 4) 'b)
    INVERT2A failed with one error:
      ERROR: INVERT1A expected a cons, but was given B.
    NIL
    ACL2 !>(invert2a 'a 'b)
    INVERT2A failed with two errors:
      ERROR: INVERT1A expected a cons, but was given A.
      ERROR: INVERT1A expected a cons, but was given B.
    NIL
    ACL2 !>
  ~ev[]

  If you study the example above, you might well understand ~c[msg].  But we
  conclude with precise documentation.~/

  ~bv[]
  General Form:
  (msg str arg1 ... argk)
  ~ev[]
  where ~c[str] is a string and ~c[k] is at most 9.

  This macro returns a pair suitable for giving to the ~c[fmt] directive
  ~c[~~@].  Thus, suppose that ~c[#\\c] is bound to the value of
  ~c[(msg str arg1 ... argk)], where ~c[c] is a character and ~c[k] is at most
  9.  Then the ~c[fmt] directive ~c[~~@c] will print out the string, ~c[str],
  in the context of the alist in which the successive ~c[fmt] variables
  ~c[#\\0], ~c[#\\1], ..., ~c[#\\k] are bound to the successive elements of
  ~c[(arg1 ... argk)].~/"

  (declare (xargs :guard (<= (length args) 10)))

  `(cons ,str ,(make-fmt-bindings '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) args)))

(defun check-vars-not-free-test (vars term)
  (declare (xargs :guard (and (symbol-listp vars)
                              (pseudo-termp term))
                  :verify-guards nil))
  (or (not (intersectp-eq vars (all-vars term)))
      (msg "It is forbidden to use ~v0 in ~x1."
           vars term)))

(defmacro check-vars-not-free (vars form)

; A typical use of this macro is (check-vars-not-free (my-erp my-val) ...)
; which just expands to the translation of ... provided my-erp and my-val do
; not occur freely in it.

; We wrap the body of the lambda into a simple function call, because
; translate11 calls ev-w on it and we want to avoid having lots of ev-rec
; calls, especially since intersectp-eq expands to an mbe call.

  (declare (xargs :guard (symbol-listp vars)))
  `(translate-and-test
    (lambda (term)
      (check-vars-not-free-test ',vars term))
    ,form))

(defun er-progn-fn (lst)

; Keep in sync with er-progn-fn@par.

  (declare (xargs :guard (true-listp lst)))
  (cond ((endp lst) nil)
        ((endp (cdr lst)) (car lst))
        (t (list 'mv-let
                 '(er-progn-not-to-be-used-elsewhere-erp
                   er-progn-not-to-be-used-elsewhere-val
                   state)
                 (car lst)
; Avoid possible warning after optimized compilation:
                 '(declare (ignorable er-progn-not-to-be-used-elsewhere-val))
                 (list 'if
                       'er-progn-not-to-be-used-elsewhere-erp
                       '(mv er-progn-not-to-be-used-elsewhere-erp
                            er-progn-not-to-be-used-elsewhere-val
                            state)
                       (list 'check-vars-not-free
                             '(er-progn-not-to-be-used-elsewhere-erp
                               er-progn-not-to-be-used-elsewhere-val)
                             (er-progn-fn (cdr lst))))))))

(defmacro er-progn (&rest lst)

; Keep in sync with er-progn@par.

  ":Doc-Section ACL2::ACL2-built-ins

  perform a sequence of state-changing ``error triples''~/

  ~bv[]
  Example:
  (er-progn (check-good-foo-p (f-get-global 'my-foo state) state)
            (value (* (f-get-global 'my-foo state)
                      (f-get-global 'bar state))))
  ~ev[]

  This sequencing primitive is only useful when programming with
  ~il[state], something that very few users will probably want to do.
  ~l[state].~/

  ~c[Er-progn] is used much the way that ~ilc[progn] is used in Common Lisp,
  except that it expects each form within it to evaluate to an ``error triple''
  of the form ~c[(mv erp val state)]; ~pl[error-triples].  The first such form,
  if any, that evaluates to such a triple where ~c[erp] is not ~c[nil] yields
  the error triple returned by the ~c[er-progn].  If there is no such form,
  then the last form returns the value of the ~c[er-progn] form.

  ~bv[]
  General Form:
  (er-progn <expr1> ... <exprk>)
  ~ev[]
  where each ~c[<expri>] is an expression that evaluates to an error triple
  (~pl[programming-with-state]).  The above form is essentially equivalent to
  the following (``essentially'' because in fact, care is taken to avoid
  variable capture).
  ~bv[]
  (mv-let (erp val state)
          <expr1>
          (cond (erp (mv erp val state))
                (t (mv-let (erp val state)
                           <expr2>
                           (cond (erp (mv erp val state))
                                 (t ...
                                        (mv-let (erp val state)
                                                <expr{k-1}>
                                                (cond (erp (mv erp val state))
                                                      (t <exprk>)))))))))
  ~ev[]~/"

  (declare (xargs :guard (and (true-listp lst)
                              lst)))
  (er-progn-fn lst))

#+acl2-par
(defun er-progn-fn@par (lst)

; Keep in sync with er-progn-fn.

  (declare (xargs :guard (true-listp lst)))
  (cond ((endp lst) nil)
        ((endp (cdr lst)) (car lst))
        (t (list 'mv-let
                 '(er-progn-not-to-be-used-elsewhere-erp
                   er-progn-not-to-be-used-elsewhere-val)
                 (car lst)
; Avoid possible warning after optimized compilation:
                 '(declare (ignorable er-progn-not-to-be-used-elsewhere-val))
                 (list 'if
                       'er-progn-not-to-be-used-elsewhere-erp
                       '(mv er-progn-not-to-be-used-elsewhere-erp
                            er-progn-not-to-be-used-elsewhere-val)
                       (list 'check-vars-not-free
                             '(er-progn-not-to-be-used-elsewhere-erp
                               er-progn-not-to-be-used-elsewhere-val)
                             (er-progn-fn@par (cdr lst))))))))

#+acl2-par
(defmacro er-progn@par (&rest lst)

; Keep in sync with er-progn.

  ":Doc-Section ACL2::ACL2-built-ins

  State-free version of ~ilc[er-progn].~/

  ~/~/"

  (declare (xargs :guard (and (true-listp lst)
                              lst)))
  (er-progn-fn@par lst))

(defun legal-case-clausesp (tl)
  (declare (xargs :guard t))
  (cond ((atom tl)
         (eq tl nil))
        ((and (consp (car tl))
              (or (eqlablep (car (car tl)))
                  (eqlable-listp (car (car tl))))
              (consp (cdr (car tl)))
              (null (cdr (cdr (car tl))))
              (if (or (eq t (car (car tl)))
                      (eq 'otherwise (car (car tl))))
                  (null (cdr tl))
                t))
         (legal-case-clausesp (cdr tl)))
        (t nil)))

(defun case-test (x pat)
  (declare (xargs :guard t))
  (cond ((atom pat) (list 'eql x (list 'quote pat)))
        (t (list 'member x (list 'quote pat)))))

(defun case-list (x l)
  (declare (xargs :guard (legal-case-clausesp l)))
  (cond ((endp l) nil)
        ((or (eq t (car (car l)))
             (eq 'otherwise (car (car l))))
         (list (list 't (car (cdr (car l))))))
        ((null (car (car l)))
         (case-list x (cdr l)))
        (t (cons (list (case-test x (car (car l)))
                       (car (cdr (car l))))
                 (case-list x (cdr l))))))

(defun case-list-check (l)
  (declare (xargs :guard (legal-case-clausesp l)))
  (cond ((endp l) nil)
        ((or (eq t (car (car l)))
             (eq 'otherwise (car (car l))))
         (list (list 't (list 'check-vars-not-free
                              '(case-do-not-use-elsewhere)
                              (car (cdr (car l)))))))
        ((null (car (car l)))
         (case-list-check (cdr l)))
        (t (cons (list (case-test 'case-do-not-use-elsewhere (car (car l)))
                       (list 'check-vars-not-free
                             '(case-do-not-use-elsewhere)
                             (car (cdr (car l)))))
                 (case-list-check (cdr l))))))

#+acl2-loop-only
(defmacro case (&rest l)

  ":Doc-Section ACL2::ACL2-built-ins

  conditional based on if-then-else using ~ilc[eql]~/
  ~bv[]
  Example Form:
  (case typ
    ((:character foo)
     (open file-name :direction :output))
    (bar (open-for-bar file-name))
    (otherwise
     (my-error \"Illegal.\")))
  ~ev[]
  is the same as
  ~bv[]
  (cond ((member typ '(:character foo))
         (open file-name :direction :output))
        ((eql typ 'bar)
         (open-for-bar file-name))
        (t (my-error \"Illegal.\")))
  ~ev[]
  which in turn is the same as
  ~bv[]
  (if (member typ '(:character foo))
      (open file-name :direction :output)
      (if (eql typ 'bar)
          (open-for-bar file-name)
          (my-error \"Illegal.\")))~/
  ~ev[]
  Notice the quotations that appear in the example above:
  ~c['(:character foo)] and ~c['bar].

  ~bv[]
  General Forms:
  (case expr
    (x1 val-1)
    ...
    (xk val-k)
    (otherwise val-k+1))

  (case expr
    (x1 val-1)
    ...
    (xk val-k)
    (t val-k+1))

  (case expr
    (x1 val-1)
    ...
    (xk val-k))
  ~ev[]
  where each ~c[xi] is either ~ilc[eqlablep] or a true list of ~ilc[eqlablep]
  objects.  The final ~c[otherwise] or ~c[t] case is optional.

  ~c[Case] is defined in Common Lisp.  See any Common Lisp
  documentation for more information.~/"

  (declare (xargs :guard (and (consp l)
                              (legal-case-clausesp (cdr l)))))
  (cond ((atom (car l))
         (cons 'cond (case-list (car l) (cdr l))))
        (t `(let ((case-do-not-use-elsewhere ,(car l)))
              (cond ,@(case-list-check (cdr l)))))))

; Position-ac

(defun position-ac-eq-exec (item lst acc)
  (declare (xargs :guard (and (true-listp lst)
                              (or (symbolp item)
                                  (symbol-listp lst))
                              (acl2-numberp acc))))
  (cond
   ((endp lst) nil)
   ((eq item (car lst))
    acc)
   (t (position-ac-eq-exec item (cdr lst) (1+ acc)))))

(defun position-ac-eql-exec (item lst acc)
  (declare (xargs :guard (and (true-listp lst)
                              (or (eqlablep item)
                                  (eqlable-listp lst))
                              (acl2-numberp acc))))
  (cond
   ((endp lst) nil)
   ((eql item (car lst))
    acc)
   (t (position-ac-eql-exec item (cdr lst) (1+ acc)))))

(defun position-equal-ac (item lst acc)

; This function should perhaps be called position-ac-equal, but we name it
; position-equal-ac since that has been its name historically before the new
; handling of member etc. after Version_4.2.

  (declare (xargs :guard (and (true-listp lst)
                              (acl2-numberp acc))))
  (cond
   ((endp lst) nil)
   ((equal item (car lst))
    acc)
   (t (position-equal-ac item (cdr lst) (1+ acc)))))

(defmacro position-ac-equal (item lst acc)
; See comment about naming in position-equal-ac.
  `(position-equal-ac ,item ,lst ,acc))

(defmacro position-eq-ac (item lst acc)

; This macro may be oddly named; see the comment about naming in
; position-equal-ac.  We also define position-ac-eq, which may be a more
; appropriate name.

  `(position-ac ,item ,lst ,acc :test 'eq))

(defmacro position-ac-eq (item lst acc)
  `(position-ac ,item ,lst ,acc :test 'eq))

(defthm position-ac-eq-exec-is-position-equal-ac
  (equal (position-ac-eq-exec item lst acc)
         (position-equal-ac item lst acc)))

(defthm position-ac-eql-exec-is-position-equal-ac
  (equal (position-ac-eql-exec item lst acc)
         (position-equal-ac item lst acc)))

(defmacro position-ac (item lst acc &key (test ''eql))
  (declare (xargs :guard (or (equal test ''eq)
                             (equal test ''eql)
                             (equal test ''equal))))
  (cond
   ((equal test ''eq)
    `(let-mbe ((item ,item) (lst ,lst) (acc ,acc))
              :logic (position-equal-ac item lst)
              :exec  (position-ac-eq-exec item lst)))
   ((equal test ''eql)
    `(let-mbe ((item ,item) (lst ,lst) (acc ,acc))
              :logic (position-equal-ac item lst acc)
              :exec  (position-ac-eql-exec item lst acc)))
   (t ; (equal test 'equal)
    `(position-equal-ac ,item ,lst))))

; Position

(defun position-eq-exec (item lst)
  (declare (xargs :guard (and (true-listp lst)
                              (or (symbolp item)
                                  (symbol-listp lst)))))
  (position-ac-eq-exec item lst 0))

(defun position-eql-exec (item lst)
  (declare (xargs :guard (or (stringp lst)
                             (and (true-listp lst)
                                  (or (eqlablep item)
                                      (eqlable-listp lst))))))
  (if (stringp lst)
      (position-ac item (coerce lst 'list) 0)
    (position-ac item lst 0)))

(defun position-equal (item lst)
  (declare (xargs :guard (or (stringp lst) (true-listp lst))))
  #-acl2-loop-only ; for assoc-eq, Jared Davis found native assoc efficient
  (position item lst :test #'equal)
  #+acl2-loop-only
  (if (stringp lst)
      (position-ac item (coerce lst 'list) 0)
    (position-equal-ac item lst 0)))

(defmacro position-eq (item lst)
  `(position ,item ,lst :test 'eq))

(defthm position-eq-exec-is-position-equal
  (implies (not (stringp lst))
           (equal (position-eq-exec item lst)
                  (position-equal item lst))))

(defthm position-eql-exec-is-position-equal
  (equal (position-eql-exec item lst)
         (position-equal item lst)))

#+acl2-loop-only
(defmacro position (x seq &key (test ''eql))

  ":Doc-Section ACL2::ACL2-built-ins

  position of an item in a string or a list~/
  ~bv[]
  General Forms:
  (position x seq)
  (position x seq :test 'eql)   ; same as above (eql as equality test)
  (position x seq :test 'eq)    ; same, but eq is equality test
  (position x seq :test 'equal) ; same, but equal is equality test
  ~ev[]

  ~c[(Position x seq)] is the least index (zero-based) of the element ~c[x] in
  the string or list ~c[seq], if ~c[x] is an element of ~c[seq].  Otherwise
  ~c[(position x seq)] is ~c[nil].  The optional keyword, ~c[:TEST], has no
  effect logically, but provides the test (default ~ilc[eql]) used for
  comparing ~c[x] with items of ~c[seq].~/

  The ~il[guard] for a call of ~c[position] depends on the test.  In all cases,
  the second argument must satisfy ~ilc[stringp] or ~ilc[true-listp].  If the
  test is ~ilc[eql], then either the first argument must be suitable for
  ~ilc[eql] (~pl[eqlablep]) or the second argument must satisfy
  ~ilc[eqlable-listp].  If the test is ~ilc[eq], then either the first argument
  must be a symbol or the second argument must satisfy ~ilc[symbol-listp].

  ~l[equality-variants] for a discussion of the relation between ~c[position] and
  its variants:
  ~bq[]
  ~c[(position-eq x seq)] is equivalent to ~c[(position x seq :test 'eq)];

  ~c[(position-equal x seq)] is equivalent to ~c[(position x seq :test 'equal)].
  ~eq[]
  In particular, reasoning about any of these primitives reduces to reasoning
  about the function ~c[position-equal].

  ~c[Position] is defined by Common Lisp.  See any Common Lisp documentation for
  more information.~/"

  (declare (xargs :guard (or (equal test ''eq)
                             (equal test ''eql)
                             (equal test ''equal))))
  (cond
   ((equal test ''eq)
    `(let-mbe ((x ,x) (seq ,seq))
              :logic (position-equal x seq)
              :exec  (position-eq-exec x seq)))
   ((equal test ''eql)
    `(let-mbe ((x ,x) (seq ,seq))
              :logic (position-equal x seq)
              :exec  (position-eql-exec x seq)))
   (t ; (equal test 'equal)
    `(position-equal ,x ,seq))))

(defun nonnegative-integer-quotient (i j)

  ":Doc-Section ACL2::ACL2-built-ins

  natural number division function~/
  ~bv[]
  Example Forms:
  (nonnegative-integer-quotient 14 3) ; equals 4
  (nonnegative-integer-quotient 15 3) ; equals 5
  ~ev[]
  ~c[(nonnegative-integer-quotient i j)] returns the integer quotient
  of the integers ~c[i] and (non-zero) ~c[j], i.e., the largest ~c[k]
  such that ~c[(* j k)] is less than or equal to ~c[i].  Also
  ~pl[floor], ~pl[ceiling] and ~pl[truncate], which are
  derived from this function and apply to rational numbers.~/

  The ~il[guard] of ~c[(nonnegative-integer-quotient i j)] requires that
  ~c[i] is a nonnegative integer and ~c[j] is a positive integer.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (integerp i)
                              (not (< i 0))
                              (integerp j)
                              (< 0 j))))
  #-acl2-loop-only
; See community book books/misc/misc2/misc.lisp for justification.
  (values (floor i j))
  #+acl2-loop-only
  (if (or (= (nfix j) 0)
          (< (ifix i) j))
      0
    (+ 1 (nonnegative-integer-quotient (- i j) j))))

; Next we develop let* in the logic.

(defun true-list-listp (x)

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for true (proper) lists of true lists~/

  ~c[True-list-listp] is the function that checks whether its argument
  is a list that ends in, or equals, ~c[nil], and furthermore, all of
  its elements have that property.  Also ~pl[true-listp].

  To see the ACL2 definition of this function, ~pl[pf].~/~/"

  (declare (xargs :guard t))
  (cond ((atom x) (eq x nil))
        (t (and (true-listp (car x))
                (true-list-listp (cdr x))))))

(defthm true-list-listp-forward-to-true-listp
  (implies (true-list-listp x)
           (true-listp x))
  :rule-classes :forward-chaining)

(defun legal-let*-p (bindings ignore-vars ignored-seen top-form)

; We check that no variable declared ignored or ignorable is bound twice.  We
; also check that all ignored-vars are bound.  We could leave it to translate
; to check the resulting LET form instead, but we prefer to do the check here,
; both in order to clarify the problem for the user (the blame will be put on
; the LET* form) and because we are not sure of the Common Lisp treatment of
; such a LET* and could thus be in unknown territory were we ever to relax the
; corresponding restriction on LET.

; Ignored-seen should be nil at the top level.

  (declare (xargs :guard (and top-form ; to avoid irrelevance
                              (symbol-alistp bindings)
                              (symbol-listp ignore-vars)
                              (symbol-listp ignored-seen))))
  (cond ((endp bindings)
         (or (eq ignore-vars nil)
             (hard-error 'let*
                         "All variables declared IGNOREd or IGNORABLE in a ~
                          LET* form must be bound, but ~&0 ~#0~[is~/are~] not ~
                          bound in the form ~x1."
                         (list (cons #\0 ignore-vars)
                               (cons #\1 top-form)))))
        ((member-eq (caar bindings) ignored-seen)
         (hard-error 'let*
                     "A variable bound more than once in a LET* form may not ~
                      be declared IGNOREd or IGNORABLE, but the variable ~x0 ~
                      is bound more than once in form ~x1 and yet is so ~
                      declared."
                     (list (cons #\0 (caar bindings))
                           (cons #\1 top-form))))
        ((member-eq (caar bindings) ignore-vars)
         (legal-let*-p (cdr bindings)
                       (remove (caar bindings) ignore-vars)
                       (cons (caar bindings) ignored-seen)
                       top-form))
        (t (legal-let*-p (cdr bindings) ignore-vars ignored-seen top-form))))

(defun well-formed-type-decls-p (decls vars)

; Decls is a true list of declarations (type tp var1 ... vark).  We check that
; each vari is bound in vars.

  (declare (xargs :guard (and (true-list-listp decls)
                              (symbol-listp vars))))
  (cond ((endp decls) t)
        ((subsetp-eq (cddr (car decls)) vars)
         (well-formed-type-decls-p (cdr decls) vars))
        (t nil)))

(defun symbol-list-listp (x)
  (declare (xargs :guard t))
  (cond ((atom x) (eq x nil))
        (t (and (symbol-listp (car x))
                (symbol-list-listp (cdr x))))))

(defun get-type-decls (var type-decls)
  (declare (xargs :guard (and (symbolp var)
                              (true-list-listp type-decls)
                              (alistp type-decls)
                              (symbol-list-listp (strip-cdrs type-decls)))))
  (cond ((endp type-decls) nil)
        ((member-eq var (cdr (car type-decls)))
         (cons (list 'type (car (car type-decls)) var)
               (get-type-decls var (cdr type-decls))))
        (t (get-type-decls var (cdr type-decls)))))

(defun let*-macro (bindings ignore-vars ignorable-vars type-decls body)
  (declare (xargs :guard (and (symbol-alistp bindings)
                              (symbol-listp ignore-vars)
                              (symbol-listp ignorable-vars)
                              (true-list-listp type-decls)
                              (alistp type-decls)
                              (symbol-list-listp (strip-cdrs type-decls)))))
  (cond ((endp bindings)
         (prog2$ (or (null ignore-vars)
                     (hard-error 'let*-macro
                                 "Implementation error: Ignored variables ~x0 ~
                                  must be bound in superior LET* form!"
                                 ignore-vars))
                 (prog2$ (or (null ignorable-vars)
                             (hard-error 'let*-macro
                                         "Implementation error: Ignorable ~
                                          variables ~x0 must be bound in ~
                                          superior LET* form!"
                                         ignorable-vars))
                         body)))
        (t ; (consp bindings)
         (cons 'let
               (cons (list (car bindings))
                     (let ((rest (let*-macro (cdr bindings)
                                             (remove (caar bindings)
                                                     ignore-vars)
                                             (remove (caar bindings)
                                                     ignorable-vars)
                                             type-decls
                                             body)))
                       (append
                        (and (member-eq (caar bindings) ignore-vars)
                             (list (list 'declare
                                         (list 'ignore (caar bindings)))))
                        (and (member-eq (caar bindings) ignorable-vars)
                             (list (list 'declare
                                         (list 'ignorable (caar bindings)))))
                        (let ((var-type-decls
                               (get-type-decls (caar bindings) type-decls)))
                          (and var-type-decls
                               (list (cons 'declare var-type-decls))))
                        (list rest))))))))

(defun collect-cdrs-when-car-eq (x alist)
  (declare (xargs :guard (and (symbolp x)
                              (true-list-listp alist))))
  (cond ((endp alist) nil)
        ((eq x (car (car alist)))
         (append (cdr (car alist))
                 (collect-cdrs-when-car-eq x (cdr alist))))
        (t (collect-cdrs-when-car-eq x (cdr alist)))))

(defun append-lst (lst)
  (declare (xargs :guard (true-list-listp lst)))
  (cond ((endp lst) nil)
        (t (append (car lst) (append-lst (cdr lst))))))

(defun restrict-alist (keys alist)

; Returns the subsequence of alist whose cars are among keys (without any
; reordering).

  (declare (xargs :guard (and (symbol-listp keys)
                              (alistp alist))))
  (cond
   ((endp alist)
    nil)
   ((member-eq (caar alist) keys)
    (cons (car alist)
          (restrict-alist keys (cdr alist))))
   (t (restrict-alist keys (cdr alist)))))

#+acl2-loop-only
(defmacro let* (&whole form bindings &rest decl-body)

  ":Doc-Section ACL2::ACL2-built-ins

  binding of lexically scoped (local) variables~/
  ~bv[]
  Example LET* Forms:
  (let* ((x (* x x))
         (y (* 2 x)))
   (list x y))

  (let* ((x (* x x))
         (y (* 2 x))
         (x (* x y))
         (a (* x x)))
   (declare (ignore a))
   (list x y))
  ~ev[]
  If the forms above are executed in an environment in which ~c[x] has the
  value ~c[-2], then the respective results are ~c['(4 8)] and ~c['(32 8)].
  ~l[let] for a discussion of both ~ilc[let] and ~c[let*], or read
  on for a briefer discussion.~/

  The difference between ~ilc[let] and ~c[let*] is that the former binds its
  local variables in parallel while the latter binds them
  sequentially.  Thus, in ~c[let*], the term evaluated to produce the
  local value of one of the locally bound variables is permitted to
  reference any locally bound variable occurring earlier in the
  binding list and the value so obtained is the newly computed local
  value of that variable.  ~l[let].

  In ACL2 the only ~ilc[declare] forms allowed for a ~c[let*] form are
  ~c[ignore], ~c[ignorable], and ~c[type].  ~l[declare].  Moreover, no variable
  declared ~c[ignore]d or ~c[ignorable] may be bound more than once.  A
  variable with a type declaration may be bound more than once, in which case
  the type declaration is treated by ACL2 as applying to each binding
  occurrence of that variable.  It seems unclear from the Common Lisp spec
  whether the underlying Lisp implementation is expected to apply such a
  declaration to more than one binding occurrence, however, so performance in
  such cases may depend on the underlying Lisp.

  ~c[Let*] is a Common Lisp macro.  See any Common Lisp
  documentation for more information.~/"

  (declare (xargs
            :guard

; We do not check that the variables declared ignored are not free in the body,
; nor do we check that variables bound in bindings that are used in the body
; are not declared ignored.  Those properties will be checked for the expanded
; LET form, as appropriate.

            (and (symbol-alistp bindings)
                 (true-listp decl-body)
                 decl-body
                 (let ((declare-forms (butlast decl-body 1)))
                   (and
                    (alistp declare-forms)
                    (subsetp-eq (strip-cars declare-forms)
                                '(declare))
                    (let ((decls (append-lst (strip-cdrs declare-forms))))
                      (let ((ign-decls (restrict-alist '(ignore ignorable)
                                                       decls))
                            (type-decls (restrict-alist '(type) decls)))
                        (and (symbol-alistp decls)
                             (symbol-list-listp ign-decls)
                             (subsetp-eq (strip-cars decls)
                                         '(ignore ignorable type))
                             (well-formed-type-decls-p type-decls
                                                       (strip-cars bindings))
                             (legal-let*-p
                              bindings
                              (append-lst (strip-cdrs ign-decls))
                              nil
                              form)))))))))
  (declare (ignore form))
  (let ((decls (append-lst (strip-cdrs (butlast decl-body 1))))
        (body (car (last decl-body))))
    (let ((ignore-vars (collect-cdrs-when-car-eq 'ignore decls))
          (ignorable-vars (collect-cdrs-when-car-eq 'ignorable decls))
          (type-decls (strip-cdrs (restrict-alist '(type) decls))))
      (let*-macro bindings ignore-vars ignorable-vars type-decls body))))

#+acl2-loop-only
(defmacro progn (&rest r)

; Warning: See the Important Boot-Strapping Invariants before modifying!

  ":Doc-Section ACL2::Events

  evaluate some ~il[events]~/
  ~bv[]
  Example Form:
  (progn (defun foo (x) x)
         (defmacro my-defun (&rest args)
           (cons 'defun args))
         (my-defun bar (x) (foo x)))

  General form:
  (progn event1 event2 ... eventk)
  ~ev[]
  where ~c[k] >= 0 and each ~c[eventi] is a legal embedded event form
  (~pl[embedded-event-form]).  These events are evaluated in sequence.  A
  utility is provided to assist in debugging failures of such execution;
  ~pl[redo-flat].

  NOTE: If the ~c[eventi] above are not all legal embedded event forms
  (~pl[embedded-event-form]), consider using ~ilc[er-progn] or (with great
  care!) ~ilc[progn!] instead.

  For a related event form that does allow introduction of ~il[constraint]s
  and ~ilc[local] ~il[events], ~pl[encapsulate].

  ACL2 does not allow the use of ~c[progn] in definitions.  Instead, the
  macro ~ilc[er-progn] can be used for sequencing ~il[state]-oriented
  operations; ~pl[er-progn] and ~pl[state].  If you are using single-threaded
  objects (~pl[stobj]) you may wish to define a version of ~ilc[er-progn] that
  cascades the object through successive changes.  ACL2's ~ilc[pprogn] is the
  ~c[state] analogue of such a macro.

  If your goal is simply to execute a sequence of top-level forms, for example
  a sequence of definitions, consider using ~c[ld] instead; ~pl[ld].~/~/"

; Like defun, defmacro, and in-package, progn does not have quite the same
; semantics as the Common Lisp function.  This is useful only for sequences at
; the top level.  It permits us to handle things like type sets and records.

  (list 'progn-fn
        (list 'quote r)
        'state))

#+(and :non-standard-analysis (not acl2-loop-only))
(defun floor1 (x)

; See "RAG" comment in the definition of floor for an explanation of why we
; need this function.

  (floor x 1))

#+acl2-loop-only
(progn

(defdoc real
  ":Doc-Section ACL2::Real

  ACL2(r) support for real numbers~/

  ACL2 supports rational numbers but not real numbers.  However, starting with
  Version 2.5, a variant of ACL2 called ``ACL2(r)'' supports the real numbers
  by way of non-standard analysis.  ACL2(r) was conceived and first implemented
  by Ruben Gamboa in his Ph.D.  dissertation work, supervised by Bob Boyer with
  active participation by Matt Kaufmann.

  ACL2(r) has the same source files as ACL2.  After you download ACL2, you can
  build ACL2(r) by executing the following command on the command line in your
  acl2-sources directory, replacing ~c[<your_lisp>] with a path to your Lisp
  executable:
  ~bv[]
  make large-acl2r LISP=<your_lisp>
  ~ev[]
  This will create an executable in your acl2-sources directory named
  ~c[saved_acl2r].

  Note that if you download community books as tarfiles, then you should be
  sure to download the `nonstd' books, from
  ~url[http://acl2-books.googlecode.com/files/nonstd-6.3.tar.gz].  Then certify
  them from your acl2-sources directory, shown here as
  ~c[<DIR>]:
  ~bv[]
  make regression-nonstd ACL2=<DIR>/saved_acl2r
  ~ev[]

  To check that you are running ACL2(r), see if the prompt includes the string
  ``~c[(r)]'',
  e.g.:
  ~bv[]
  ACL2(r) !>
  ~ev[]
  Or, look at ~c[(@ acl2-version)] and see if ``~c[(r)]'' is a substring.

  In ACL2 (as opposed to ACL2(r)), when we say ``real'' we mean
  ``rational.''~/

  Caution: ACL2(r) should be considered experimental: although we (Kaufmann and
  Moore) have carefully completed Gamboa's integration of the reals into the
  ACL2 source code, our primary concern has been to ensure unchanged behavior
  when ACL2 is compiled in the default manner, i.e., without the non-standard
  extensions.  As for every release of ACL2, at the time of a release we are
  unaware of soundness bugs in ACL2 or ACL2(r).

  There is only limited documentation on the non-standard features of ACL2(r).
  We hope to provide more documentation for such features in future releases.
  Please feel free to query the authors if you are interested in learning more
  about ACL2(r).  Gamboa's dissertation may also be helpful.~/")

(defun floor (i j)

;; RAG - This function had to be modified in a major way.  It was
;; originally defined only for rationals, and it used the fact that
;; the floor of "p/q" could be found by repeatedly subtracting "q"
;; from "p" (roughly speaking).  This same trick, sadly, does not work
;; for the reals.  Instead, we need something similar to the
;; archimedean axiom.  Our version thereof is the _undefined_ function
;; "floor1", which takes a single argument and returns an integer
;; equal to it or smaller to it by no more than 1.  Using this
;; function, we can define the more general floor function offered
;; below.

  ":Doc-Section ACL2::ACL2-built-ins

  division returning an integer by truncating toward negative infinity~/
  ~bv[]
  Example Forms:
  ACL2 !>(floor 14 3)
  4
  ACL2 !>(floor -14 3)
  -5
  ACL2 !>(floor 14 -3)
  -5
  ACL2 !>(floor -14 -3)
  4
  ACL2 !>(floor -15 -3)
  5
  ~ev[]
  ~c[(Floor i j)] returns the result of taking the quotient of ~c[i] and
  ~c[j] and returning the greatest integer not exceeding that quotient.
  For example, the quotient of ~c[-14] by ~c[3] is ~c[-4 2/3], and the largest
  integer not exceeding that rational number is ~c[-5].~/

  The ~il[guard] for ~c[(floor i j)] requires that ~c[i] and ~c[j] are
  rational (~il[real], in ACL2(r)) numbers and ~c[j] is non-zero.

  ~c[Floor] is a Common Lisp function.  See any Common Lisp
  documentation for more information.  However, note that unlike Common Lisp,
  the ACL2 ~c[floor] function returns only a single value,

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (real/rationalp i)
                              (real/rationalp j)
                              (not (eql j 0)))))
  #+:non-standard-analysis
  (let ((q (* i (/ j))))
    (cond ((integerp q) q)
          ((rationalp q)
           (if (>= q 0)
               (nonnegative-integer-quotient (numerator q) (denominator q))
             (+ (- (nonnegative-integer-quotient (- (numerator q))
                                                 (denominator q)))
                -1)))
          (t (floor1 q))))
  #-:non-standard-analysis
  (let* ((q (* i (/ j)))
         (n (numerator q))
         (d (denominator q)))
    (cond ((= d 1) n)
          ((>= n 0)
           (nonnegative-integer-quotient n d))
          (t (+ (- (nonnegative-integer-quotient (- n) d)) -1))))
  )

;; RAG - This function was also modified to fit in the reals.  It's
;; also defined in terms of the _undefined_ function floor1 (which
;; corresponds to the usual unary floor function).

(defun ceiling (i j)

  ":Doc-Section ACL2::ACL2-built-ins

  division returning an integer by truncating toward positive infinity~/
  ~bv[]
  Example Forms:
  ACL2 !>(ceiling 14 3)
  5
  ACL2 !>(ceiling -14 3)
  -4
  ACL2 !>(ceiling 14 -3)
  -4
  ACL2 !>(ceiling -14 -3)
  5
  ACL2 !>(ceiling -15 -3)
  5
  ~ev[]
  ~c[(Ceiling i j)] is the result of taking the quotient of ~c[i] and
  ~c[j] and returning the smallest integer that is at least as great as
  that quotient.  For example, the quotient of ~c[-14] by ~c[3] is ~c[-4 2/3], and
  the smallest integer at least that great is ~c[-4].~/

  The ~il[guard] for ~c[(ceiling i j)] requires that ~c[i] and ~c[j] are
  rational (~il[real], in ACL2(r)) numbers and ~c[j] is non-zero.

  ~c[Ceiling] is a Common Lisp function.  See any Common Lisp documentation for
  more information.  However, note that unlike Common Lisp, the ACL2
  ~c[ceiling] function returns only a single value,

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (real/rationalp i)
                              (real/rationalp j)
                              (not (eql j 0)))))
  #+:non-standard-analysis
  (let ((q (* i (/ j))))
    (cond ((integerp q) q)
          ((rationalp q)
           (if (>= q 0)
               (+ (nonnegative-integer-quotient (numerator q)
                                                (denominator q))
                  1)
             (- (nonnegative-integer-quotient (- (numerator q))
                                              (denominator q)))))
          ((realp q) (1+ (floor1 q)))
          (t 0)))
  #-:non-standard-analysis
  (let* ((q (* i (/ j)))
         (n (numerator q))
         (d (denominator q)))
    (cond ((= d 1) n)
          ((>= n 0)
           (+ (nonnegative-integer-quotient n d) 1))
          (t (- (nonnegative-integer-quotient (- n) d)))))
  )

;; RAG - Another function  modified to fit in the reals, using floor1.

(defun truncate (i j)

  ":Doc-Section ACL2::ACL2-built-ins

  division returning an integer by truncating toward 0~/
  ~bv[]
  Example Forms:
  ACL2 !>(truncate 14 3)
  4
  ACL2 !>(truncate -14 3)
  -4
  ACL2 !>(truncate 14 -3)
  -4
  ACL2 !>(truncate -14 -3)
  4
  ACL2 !>(truncate -15 -3)
  5
  ACL2 !>(truncate 10/4 3/4)
  3
  ~ev[]
  ~c[(Truncate i j)] is the result of taking the quotient of ~c[i] and
  ~c[j] and dropping the fraction.  For example, the quotient of ~c[-14] by
  ~c[3] is ~c[-4 2/3], so dropping the fraction ~c[2/3], we obtain a result for
  ~c[(truncate -14 3)] of ~c[-4].~/

  The ~il[guard] for ~c[(truncate i j)] requires that ~c[i] and ~c[j] are
  rational (~il[real], in ACL2(r)) numbers and ~c[j] is non-zero.

  ~c[Truncate] is a Common Lisp function.  However, note that unlike Common
  Lisp, the ACL2 ~c[truncate] function returns only a single value,  Also
  ~pl[nonnegative-integer-quotient], which is appropriate for integers and may
  simplify reasoning, unless a suitable arithmetic library is loaded, but be
  less efficient for evaluation on concrete objects.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (real/rationalp i)
                              (real/rationalp j)
                              (not (eql j 0)))))
  #+:non-standard-analysis
  (let ((q (* i (/ j))))
    (cond ((integerp q) q)
          ((rationalp q)
           (if (>= q 0)
               (nonnegative-integer-quotient (numerator q)
                                             (denominator q))
             (- (nonnegative-integer-quotient (- (numerator q))
                                              (denominator q)))))
          (t (if (>= q 0)
                 (floor1 q)
               (- (floor1 (- q)))))))
  #-:non-standard-analysis
  (let* ((q (* i (/ j)))
         (n (numerator q))
         (d (denominator q)))
    (cond ((= d 1) n)
          ((>= n 0)
           (nonnegative-integer-quotient n d))
          (t (- (nonnegative-integer-quotient (- n) d)))))
  )

;; RAG - Another function  modified to fit in the reals, using floor1.

(defun round (i j)

  ":Doc-Section ACL2::ACL2-built-ins

  division returning an integer by rounding off~/
  ~bv[]
  Example Forms:
  ACL2 !>(round 14 3)
  5
  ACL2 !>(round -14 3)
  -5
  ACL2 !>(round 14 -3)
  -5
  ACL2 !>(round -14 -3)
  5
  ACL2 !>(round 13 3)
  4
  ACL2 !>(round -13 3)
  -4
  ACL2 !>(round 13 -3)
  -4
  ACL2 !>(round -13 -3)
  4
  ACL2 !>(round -15 -3)
  5
  ACL2 !>(round 15 -2)
  -8
  ~ev[]
  ~c[(Round i j)] is the result of taking the quotient of ~c[i] and ~c[j]
  and rounding off to the nearest integer.  When the quotient is
  exactly halfway between consecutive integers, it rounds to the even
  one.~/

  The ~il[guard] for ~c[(round i j)] requires that ~c[i] and ~c[j] are
  rational (~il[real], in ACL2(r)) numbers and ~c[j] is non-zero.

  ~c[Round] is a Common Lisp function.  See any Common Lisp documentation for
  more information.  However, note that unlike Common Lisp, the ACL2 ~c[round]
  function returns only a single value,

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (real/rationalp i)
                              (real/rationalp j)
                              (not (eql j 0)))))
  (let ((q (* i (/ j))))
    (cond ((integerp q) q)
          ((>= q 0)
           (let* ((fl (floor q 1))
                  (remainder (- q fl)))
             (cond ((> remainder 1/2)
                    (+ fl 1))
                   ((< remainder 1/2)
                    fl)
                   (t (cond ((integerp (* fl (/ 2)))
                             fl)
                            (t (+ fl 1)))))))
          (t
           (let* ((cl (ceiling q 1))
                  (remainder (- q cl)))
             (cond ((< (- 1/2) remainder)
                    cl)
                   ((> (- 1/2) remainder)
                    (+ cl -1))
                   (t (cond ((integerp (* cl (/ 2)))
                             cl)
                            (t (+ cl -1)))))))))
  )

;; RAG - I only had to modify the guards here to allow the reals,
;; since this function is defined in terms of the previous ones.

(defun mod (x y)

  ":Doc-Section ACL2::ACL2-built-ins

  remainder using ~ilc[floor]~/
  ~bv[]
  ACL2 !>(mod 14 3)
  2
  ACL2 !>(mod -14 3)
  1
  ACL2 !>(mod 14 -3)
  -1
  ACL2 !>(mod -14 -3)
  -2
  ACL2 !>(mod -15 -3)
  0
  ACL2 !>
  ~ev[]
  ~c[(Mod i j)] is that number ~c[k] that ~c[(* j (floor i j))] added to
  ~c[k] equals ~c[i].~/

  The ~il[guard] for ~c[(mod i j)] requires that ~c[i] and ~c[j] are rational
  (~il[real], in ACL2(r)) numbers and ~c[j] is non-zero.

  ~c[Mod] is a Common Lisp function.  See any Common Lisp documentation
  for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (real/rationalp x)
                              (real/rationalp y)
                              (not (eql y 0)))))
  (- x (* (floor x y) y)))

(defun rem (x y)

  ":Doc-Section ACL2::ACL2-built-ins

  remainder using ~ilc[truncate]~/
  ~bv[]
  ACL2 !>(rem 14 3)
  2
  ACL2 !>(rem -14 3)
  -2
  ACL2 !>(rem 14 -3)
  2
  ACL2 !>(rem -14 -3)
  -2
  ACL2 !>(rem -15 -3)
  0
  ACL2 !>
  ~ev[]
  ~c[(Rem i j)] is that number ~c[k] for which ~c[(* j (truncate i j))] added
  to ~c[k] equals ~c[i].~/

  The ~il[guard] for ~c[(rem i j)] requires that ~c[i] and ~c[j] are rational
  (~il[real], in ACL2(r)) numbers and ~c[j] is non-zero.

  ~c[Rem] is a Common Lisp function.  See any Common Lisp documentation
  for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (real/rationalp x)
                              (real/rationalp y)
                              (not (eql y 0)))))
  (- x (* (truncate x y) y)))

(defun evenp (x)

  ":Doc-Section ACL2::ACL2-built-ins

  test whether an integer is even~/

  ~c[(evenp x)] is true if and only if the integer ~c[x] is even.
  Actually, in the ACL2 logic ~c[(evenp x)] is defined to be true when
  ~c[x/2] is an integer.~/

  The ~il[guard] for ~c[evenp] requires its argument to be an integer.

  ~c[Evenp] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (integerp x)))
  (integerp (* x (/ 2))))

(defun oddp (x)

  ":Doc-Section ACL2::ACL2-built-ins

  test whether an integer is odd~/

  ~c[(oddp x)] is true if and only if ~c[x] is odd, i.e., not even in
  the sense of ~ilc[evenp].~/

  The ~il[guard] for ~c[oddp] requires its argument to be an integer.

  ~c[Oddp] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (integerp x)))
  (not (evenp x)))

(defun zerop (x)
  (declare (xargs :mode :logic
                  :guard (acl2-numberp x)))

  ":Doc-Section ACL2::ACL2-built-ins

  test an acl2-number against 0~/

  ~c[(zerop x)] is ~c[t] if ~c[x] is ~c[0] and is ~c[nil] otherwise.  Thus,
  it is logically equivalent to ~c[(equal x 0)].~/

  ~c[(Zerop x)] has a ~il[guard] requiring ~c[x] to be numeric and can be
  expected to execute more efficiently than ~c[(equal x 0)] in properly
  ~il[guard]ed compiled code.

  In recursions down the natural numbers, ~c[(zp x)] is preferred over
  ~c[(zerop x)] because the former coerces ~c[x] to a natural and allows
  the termination proof.  In recursions through the integers,
  ~c[(zip x)] is preferred.  ~l[zero-test-idioms].

  ~c[Zerop] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (eql x 0))

;; RAG - Only the guard changed here.

(defun plusp (x)

  ":Doc-Section ACL2::ACL2-built-ins

  test whether a number is positive~/

  ~c[(Plusp x)] is true if and only if ~c[x > 0].~/

  The ~il[guard] of ~c[plusp] requires its argument to be a rational (~il[real], in
  ACL2(r)) number.

  ~c[Plusp] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :mode :logic
                  :guard (real/rationalp x)))
  (> x 0))

;; RAG - Only the guard changed here.

(defun minusp (x)

  ":Doc-Section ACL2::ACL2-built-ins

  test whether a number is negative~/

  ~c[(Minusp x)] is true if and only if ~c[x < 0].~/

  The ~il[guard] of ~c[minusp] requires its argument to be a rational (~il[real], in
  ACL2(r)) number.

  ~c[Minusp] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :mode :logic
                  :guard (real/rationalp x)))
  (< x 0))

;; RAG - Only the guard changed here.

(defun min (x y)

  ":Doc-Section ACL2::ACL2-built-ins

  the smaller of two numbers~/

  ~c[(Min x y)] is the smaller of the numbers ~c[x] and ~c[y].~/

  The ~il[guard] for ~c[min] requires its arguments to be rational (~il[real],
  in ACL2(r)) numbers.

  ~c[Min] is a Common Lisp function.  See any Common Lisp documentation
  for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (real/rationalp x)
                              (real/rationalp y))))
  (if (< x y)
      x
    y))

;; RAG - Only the guard changed here.

(defun max (x y)

  ":Doc-Section ACL2::ACL2-built-ins

  the larger of two numbers~/

  ~c[(Max x y)] is the larger of the numbers ~c[x] and ~c[y].~/

  The ~il[guard] for ~c[max] requires its arguments to be rational (~il[real],
  in ACL2(r)) numbers.

  ~c[Max] is a Common Lisp function.  See any Common Lisp documentation
  for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (real/rationalp x)
                              (real/rationalp y))))
  (if (> x y)
      x
    y))

;; RAG - Only the guard changed here.  The docstring below says that
;; abs must not be used on complex arguments, since that could result
;; in a non-ACL2 object.

(defun abs (x)

  ":Doc-Section ACL2::ACL2-built-ins

  the absolute value of a real number~/

  ~c[(Abs x)] is ~c[-x] if ~c[x] is negative and is ~c[x] otherwise.~/

  The ~il[guard] for ~c[abs] requires its argument to be a rational (~il[real],
  in ACL2(r)) number.

  ~c[Abs] is a Common Lisp function.  See any Common Lisp documentation
  for more information.

  From ``Common Lisp the Language'' page 205, we must not allow
  complex ~c[x] as an argument to ~c[abs] in ACL2, because if we did we
  would have to return a number that might be a floating point number
  and hence not an ACL2 object.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (real/rationalp x)))

  (if (minusp x) (- x) x))

(defun signum (x)

  ":Doc-Section ACL2::ACL2-built-ins

  indicator for positive, negative, or zero~/

  ~c[(Signum x)] is ~c[0] if ~c[x] is ~c[0], ~c[-1] if ~c[x] is negative,
  and is ~c[1] otherwise.~/

  The ~il[guard] for ~c[signum] requires its argument to be rational (~il[real], in
  ACL2(r)) number.

  ~c[Signum] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  From ``Common Lisp the Language'' page 206, we see a definition of
  ~c[signum] in terms of ~ilc[abs].  As explained elsewhere
  (~pl[abs]), the ~il[guard] for ~ilc[abs] requires its argument to be a
  rational (~il[real], in ACL2(r))  number; hence, we make the same
  restriction for ~c[signum].

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (real/rationalp x)))

; On CLTL p. 206 one sees the definition

; (if (zerop x) x (* x (/ (abs x)))).

; However, that suffers because it looks to type-set like it returns
; an arbitrary rational when in fact it returns -1, 0, or 1.  So we
; give a more explicit definition.  See the doc string in abs for a
; justification for disallowing complex arguments.

  (if (zerop x) 0
      (if (minusp x) -1 +1)))

(defun lognot (i)

  ":Doc-Section ACL2::ACL2-built-ins

  bitwise not of a two's complement number~/

  ~c[(lognot i)] is the two's complement bitwise ~c[`not'] of the integer ~c[i].~/

  ~c[Lognot] is actually defined by coercing its argument to an integer
  (~pl[ifix]), negating the result, and then subtracting ~c[1].

  The ~il[guard] for ~c[lognot] requires its argument to be an integer.

  ~c[Lognot] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (integerp i)))
  (+ (- (ifix i)) -1))

; This function is introduced now because we need it in the admission of
; logand.  The admission of o-p could be moved up to right
; after the introduction of the "and" macro.

)

(defthm standard-char-p-nth
  (implies (and (standard-char-listp chars)
                (<= 0 i)
                (< i (len chars)))
           (standard-char-p (nth i chars)))
  :hints (("Goal" :in-theory (enable standard-char-listp))))

(verify-termination-boot-strap (string-equal1
                     (declare (xargs :measure (nfix (- maximum (nfix i)))))))
(verify-termination-boot-strap string-equal)
(verify-termination-boot-strap assoc-string-equal)
(verify-termination-boot-strap xxxjoin)

(deflabel proof-of-well-foundedness
  :doc
  ":Doc-Section Miscellaneous

  a proof that ~ilc[o<] is well-founded on ~ilc[o-p]s~/

  The soundness of ACL2 rests in part on the well-foundedness of ~ilc[o<] on
  ~ilc[o-p]s.  This can be taken as obvious if one is willing to grant that
  those concepts are simply encodings of the standard mathematical notions of
  the ordinals below ~c[epsilon-0] and its natural ordering relation.  But it
  is possible to prove that ~ilc[o<] is well-founded on ~ilc[o-p]s without
  having to assert any connection to the ordinals and that is what we do here.
  The community book ~c[books/ordinals/proof-of-well-foundedness] carries out
  the proof outlined below in ACL2, using only that the natural numbers are
  well-founded.~/

  Before outlining the above mentioned proof, we note that in the analogous
  documentation page of ACL2 Version_2.7, there is a proof of the
  well-foundedness of ~c[e0-ord-<] on ~c[e0-ordinalp]s, the less-than relation
  and recognizer for the old ordinals (that is, for the ordinals appearing in
  ACL2 up through that version).  Manolios and Vroon have given a proof in ACL2
  Version_2.7 that the current ordinals (based on ~ilc[o<] and ~ilc[o-p]) are
  order-isomorphic to the old ordinals (based on ~c[e0-ord-<] and
  ~c[e0-ordinalp]).  Their proof establishes that switching from the old
  ordinals to the current ordinals preserves the soundness of ACL2.  For
  details see their paper:
  ~bf[]
  Manolios, Panagiotis & Vroon, Daron.
  Ordinal arithmetic in ACL2.
  Kaufmann, Matt, & Moore, J Strother (eds).
  Fourth International Workshop on the ACL2 Theorem
  Prover and Its Applications (ACL2-2003),
  July, 2003.
  See ~url[http://www.cs.utexas.edu/users/moore/acl2/workshop-2003/].
  ~ef[]

  We now give an outline of the above mentioned proof of well-foundedness.  We
  first observe three facts about ~ilc[o<] on ordinals that have been proved by
  ACL2 using only structural induction on lists.  These theorems can be proved
  by hand.
  ~bv[]
  (defthm transitivity-of-o<
    (implies (and (o< x y)
                  (o< y z))
             (o< x z))
    :rule-classes nil)

  (defthm non-circularity-of-o<
    (implies (o< x y)
             (not (o< y x)))
    :rule-classes nil)

  (defthm trichotomy-of-o<
    (implies (and (o-p x)
                  (o-p y))
             (or (equal x y)
                 (o< x y)
                 (o< y x)))
    :rule-classes nil)
  ~ev[]
  These three properties establish that ~ilc[o<] orders the
  ~ilc[o-p]s.  To put such a statement in the most standard
  mathematical nomenclature, we can define the macro:
  ~bv[]
  (defmacro o<= (x y)
    `(not (o< ,y ,x)))
  ~ev[]
  and then establish that ~c[o<=] is a relation that is a simple,
  complete (i.e., total) order on ordinals by the following three
  lemmas, which have been proved:
  ~bv[]
  (defthm antisymmetry-of-o<=
    (implies (and (o-p x)
                  (o-p y)
                  (o<= x y)
                  (o<= y x))
             (equal x y))
    :rule-classes nil
    :hints ((\"Goal\" :use non-circularity-of-o<)))

  (defthm transitivity-of-o<=
    (implies (and (o-p x)
                  (o-p y)
                  (o<= x y)
                  (o<= y z))
             (o<= x z))
    :rule-classes nil
    :hints ((\"Goal\" :use transitivity-of-o<)))

  (defthm trichotomy-of-o<=
    (implies (and (o-p x)
                  (o-p y))
             (or (o<= x y)
                 (o<= y x)))
    :rule-classes nil
    :hints ((\"Goal\" :use trichotomy-of-o<)))
  ~ev[]
  Crucially important to the proof of the well-foundedness of
  ~ilc[o<] on ~ilc[o-p]s is the concept of ordinal-depth,
  abbreviated ~c[od]:
  ~bv[]
  (defun od (l)
    (if (o-finp l)
        0
      (1+ (od (o-first-expt l)))))
  ~ev[]
  If the ~c[od] of an ~ilc[o-p] ~c[x] is smaller than that of an
  ~ilc[o-p] ~c[y], then ~c[x] is ~ilc[o<] ~c[y]:
  ~bv[]
  (defun od-1 (x y)
    (if (o-finp x)
        (list x y)
      (od-1 (o-first-expt x) (o-first-expt y))))

  (defthm od-implies-ordlessp
    (implies (and (o-p x)
                  (< (od x) (od y)))
             (o< x y))
    :hints ((\"Goal\"
             :induct (od-1 x y))))
  ~ev[]
  Remark.  A consequence of this lemma is the fact that if ~c[s = s(1)],
  ~c[s(2)], ... is an infinite, ~ilc[o<] descending sequence of ~ilc[o-p]s, then
  ~c[od(s(1))], ~c[od(s(2))], ... is a ``weakly'' descending sequence of
  non-negative integers: ~c[od(s(i))] is greater than or equal to
  ~c[od(s(i+1))].

  ~em[Lemma Main.]  For each non-negative integer ~c[n], ~ilc[o<] well-orders
  the set of ~ilc[o-p]s with ~c[od] less than or equal to ~c[n] .
  ~bv[]
   Base Case.  n = 0.  The o-ps with 0 od are the non-negative
   integers.  On the non-negative integers, o< is the same as <.

   Induction Step.  n > 0.  We assume that o< well-orders the
   o-ps with od less than n.

     If o< does not well-order the o-ps with od less than or equal to n,
     consider, D, the set of infinite, o< descending sequences of o-ps of od
     less than or equal to n.  The first element of a sequence in D has od n.
     Therefore, the o-first-expt of the first element of a sequence in D has od
     n-1.  Since o<, by IH, well-orders the o-ps with od less than n, the set
     of o-first-expts of first elements of the sequences in D has a minimal
     element, which we denote by B and which has od of n-1.

     Let k be the minimum integer such that for some infinite, o< descending
     sequence s of o-ps with od less than or equal to n, the first element of s
     has an o-first-expt of B and an o-first-coeff of k.  Notice that k is
     positive.

     Having fixed B and k, let s = s(1), s(2), ... be an infinite, o<
     descending sequence of o-ps with od less than or equal to n such that s(1)
     has a o-first-expt of B and an o-first-coeff of k.

     We show that each s(i) has a o-first-expt of B and an o-first-coeff of
     k. For suppose that s(j) is the first member of s either with o-first-expt
     B and o-first-coeff m (m neq k) or with o-first-expt B' and o-first-coeff
     B' (B' neq B). If (o-first-expt s(j)) = B', then B' has od n-1 (otherwise,
     by IH, s would not be infinite) and B' is o< B, contradicting the
     minimality of B. If 0 < m < k, then the fact that the sequence beginning
     at s(j) is infinitely descending contradicts the minimality of k. If m >
     k, then s(j) is greater than its predecessor; but this contradicts the
     fact that s is descending.

     Thus, by the definition of o<, for s to be a decreasing sequence of o-ps,
     (o-rst s(1)), (o-rst s(2)), ... must be a decreasing sequence. We end by
     showing this cannot be the case. Let t = t(1), t(2), ... be an infinite
     sequence of o-ps such that t(i) = (o-rst s(i)). Then t is infinitely
     descending. Furthermore, t(1) begins with an o-p B' that is o< B. Since t
     is in D, t(1) has od n, therefore, B' has od n-1. But this contradicts the
     minimality of B. Q.E.D.
  ~ev[]
  Theorem.  ~ilc[o<] well-orders the ~ilc[o-p]s.  Proof.  Every
  infinite,~c[ o<] descending sequence of ~ilc[o-p]s has the
  property that each member has ~c[od] less than or equal to the
  ~c[od], ~c[n], of the first member of the sequence.  This
  contradicts Lemma Main.
  Q.E.D.")

#+acl2-loop-only
(progn

(defun expt (r i)

  ":Doc-Section ACL2::ACL2-built-ins

  exponential function~/

  ~c[(Expt r i)] is the result of raising the number ~c[r] to the
  integer power ~c[i].~/

  The ~il[guard] for ~c[(expt r i)] is that ~c[r] is a number and ~c[i]
  is an integer, and furthermore, if ~c[r] is ~c[0] then ~c[i] is
  nonnegative.  When the type requirements of the ~il[guard] aren't
  met, ~c[(expt r i)] first coerces ~c[r] to a number and ~c[i] to an
  integer.

  ~c[Expt] is a Common Lisp function.  See any Common Lisp
  documentation for more information.  Note that ~c[r] can be a complex
  number; this is consistent with Common lisp.

  To see the ACL2 definition of this function, ~pl[pf].~/"

; CLtL2 (page 300) allows us to include complex rational arguments.

  (declare (xargs :guard (and (acl2-numberp r)
                              (integerp i)
                              (not (and (eql r 0) (< i 0))))
                  :measure (abs (ifix i))))
  (cond ((zip i) 1)
        ((= (fix r) 0) 0)
        ((> i 0) (* r (expt r (+ i -1))))
        (t (* (/ r) (expt r (+ i +1))))))

(defun logcount (x)

  ":Doc-Section ACL2::ACL2-built-ins

  number of ``on'' bits in a two's complement number~/

  ~c[(Logcount x)] is the number of ``on'' bits in the two's complement
  representation of ~c[x].~/

  ~c[(Logcount x)] has a ~il[guard] of ~c[(integerp x)].

  ~c[Logcount] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (integerp x)))
  (cond
   ((zip x)
    0)
   ((< x 0)
    (logcount (lognot x)))
   ((evenp x)
    (logcount (nonnegative-integer-quotient x 2)))
   (t
    (1+ (logcount (nonnegative-integer-quotient x 2))))))

(defun nthcdr (n l)

  ":Doc-Section ACL2::ACL2-built-ins

  final segment of a list~/

  ~c[(Nthcdr n l)] removes the first ~c[n] elements from the list ~c[l].~/

  The following is a theorem.
  ~bv[]
  (implies (and (integerp n)
                (<= 0 n)
                (true-listp l))
           (equal (length (nthcdr n l))
                  (if (<= n (length l))
                      (- (length l) n)
                    0)))
  ~ev[]
  For related functions, ~pl[take] and ~pl[butlast].

  The ~il[guard] of ~c[(nthcdr n l)] requires that ~c[n] is a nonnegative
  integer and ~c[l] is a true list.

  ~c[Nthcdr] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (integerp n)
                              (<= 0 n)
                              (true-listp l))))
  (if (zp n)
      l
    (nthcdr (+ n -1) (cdr l))))

(defun logbitp (i j)

  ":Doc-Section ACL2::ACL2-built-ins

  the ~c[i]th bit of an integer~/

  For a nonnegative integer ~c[i] and an integer ~c[j], ~c[(logbitp i j)] is a
  Boolean, which is ~c[t] if and only if the value of the ~c[i]th bit is ~c[1]
  in the two's complement representation of ~c[j].~/

  ~c[(Logbitp i j)] has a ~il[guard] that ~c[i] is a nonnegative integer and
  ~c[j] is an integer.

  ~c[Logbitp] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (integerp j)
                              (integerp i)
                              (>= i 0))
                  :mode :program))
  (oddp (floor (ifix j) (expt 2 (nfix i)))))

(defun ash (i c)

  ":Doc-Section ACL2::ACL2-built-ins

  arithmetic shift operation~/

  ~c[(ash i c)] is the result of taking the two's complement
  representation of the integer ~c[i] and shifting it by ~c[c] bits:  shifting
  left and padding with ~c[c] ~c[0] bits if ~c[c] is positive, shifting right and
  dropping ~c[(abs c)] bits if ~c[c] is negative, and simply returning ~c[i] if ~c[c]
  is ~c[0].~/

  The ~il[guard] for ~c[ash] requires that its arguments are integers.

  ~c[Ash] is a Common Lisp function.  See any Common Lisp documentation
  for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (integerp i)
                              (integerp c))
                  :mode :program))
  (floor (* (ifix i) (expt 2 c)) 1))

)

; John Cowles first suggested a version of the following lemma for rationals.

(defthm expt-type-prescription-non-zero-base
  (implies (and (acl2-numberp r)
                (not (equal r 0)))
           (not (equal (expt r i) 0)))
  :rule-classes :type-prescription)

;; RAG - I added the following lemma, similar to the rational case.

#+:non-standard-analysis
(defthm realp-expt-type-prescription
  (implies (realp r)
           (realp (expt r i)))
  :rule-classes :type-prescription)

(defthm rationalp-expt-type-prescription
  (implies (rationalp r)
           (rationalp (expt r i)))
  :rule-classes :type-prescription)

(verify-termination-boot-strap logbitp)

(verify-termination-boot-strap ash)

(deflabel characters
  :doc
  ":Doc-Section ACL2::ACL2-built-ins

  characters in ACL2~/

  ACL2 accepts 256 distinct characters, which are the characters
  obtained by applying the function ~ilc[code-char] to each integer from ~c[0]
  to ~c[255].  Among these, Common Lisp designates certain ones as
  ~em[standard characters], namely those of the form ~c[(code-char n)]
  where ~c[n] is from ~c[33] to ~c[126], together with ~c[#\\Newline] and ~c[#\\Space].  The
  actual standard characters may be viewed by evaluating the
  ~ilc[defconst] ~c[*standard-chars*].~/

  To be more precise, Common Lisp does not specify the precise
  relationship between ~ilc[code-char] and the standard characters.
  However, we check that the underlying Common Lisp implementation
  uses a particular relationship that extends the usual ASCII coding
  of characters.  We also check that Space, Tab, Newline, Page, and
  Rubout correspond to characters with respective ~ilc[char-code]s ~t[32], ~t[9],
  ~t[10], ~t[12], and ~t[127].

  ~ilc[Code-char] has an inverse, ~ilc[char-code].  Thus, when ~ilc[char-code] is
  applied to an ACL2 character, ~c[c], it returns a number ~c[n] between ~c[0] and
  ~c[255] inclusive such that ~c[(code-char n)] = ~c[c].

  The preceding paragraph implies that there is only one ACL2
  character with a given character code.  CLTL allows for
  ``attributes'' for characters, which could allow distinct characters
  with the same code, but ACL2 does not allow this.

  ~em[The Character Reader]

  ACL2 supports the `~c[#\\]' notation for characters provided by Common
  Lisp, with some restrictions.  First of all, for every character ~c[c],
  the notation
  ~bv[]
  #\\c
  ~ev[]
  may be used to denote the character object ~c[c].  That is, the user may
  type in this notation and ACL2 will read it as denoting the
  character object ~c[c].  In this case, the character immediately
  following ~c[c] must be one of the following ``terminating characters'':
  a Tab, a Newline, a Page character, a space, or one of the
  characters:
  ~bv[]
  \"  '  (  )  ;  `  ,
  ~ev[]
  Other than the notation above, ACL2 accepts alternate notation for
  five characters.
  ~bv[]
  #\\Space
  #\\Tab
  #\\Newline
  #\\Page
  #\\Rubout
  ~ev[]

  Again, in each of these cases the next character must be from among
  the set of ``terminating characters'' described in the
  single-character case.  Our implementation is consistent with
  IS0-8859, even though we don't provide ~c[#\\] syntax for entering
  characters other than that described above.

  Finally, we note that it is our intention that any object printed by
  ACL2's top-level-loop may be read back into ACL2.  Please notify the
  implementors if you find a counterexample to this claim.~/")

(defaxiom char-code-linear

; The other properties that we might be tempted to state here,
; (integerp (char-code x)) and (<= 0 (char-code x)), are taken care of by
; type-set-char-code.

  (< (char-code x) 256)
  :rule-classes :linear)

(defaxiom code-char-type
  (characterp (code-char n))
  :rule-classes :type-prescription)

(defaxiom code-char-char-code-is-identity
  (implies (force (characterp c))
           (equal (code-char (char-code c)) c)))

(defaxiom char-code-code-char-is-identity
  (implies (and (force (integerp n))
                (force (<= 0 n))
                (force (< n 256)))
           (equal (char-code (code-char n)) n)))

#+acl2-loop-only
(defun char< (x y)

  ":Doc-Section ACL2::ACL2-built-ins

  less-than test for ~il[characters]~/

  ~c[(char< x y)] is true if and only if the character code of ~c[x] is
  less than that of ~c[y].  ~l[char-code].~/

  The ~il[guard] for ~c[char<] specifies that its arguments are ~il[characters].

  ~c[Char<] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (characterp x) (characterp y))))
  (< (char-code x) (char-code y)))

#+acl2-loop-only
(defun char> (x y)

  ":Doc-Section ACL2::ACL2-built-ins

  greater-than test for ~il[characters]~/

  ~c[(char> x y)] is true if and only if the character code of ~c[x] is
  greater than that of ~c[y].  ~l[char-code].~/

  The ~il[guard] for ~c[char>] specifies that its arguments are ~il[characters].

  ~c[Char>] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (characterp x) (characterp y))))
  (> (char-code x) (char-code y)))

#+acl2-loop-only
(defun char<= (x y)

  ":Doc-Section ACL2::ACL2-built-ins

  less-than-or-equal test for ~il[characters]~/

  ~c[(char<= x y)] is true if and only if the character code of ~c[x] is
  less than or equal to that of ~c[y].  ~l[char-code].~/

  The ~il[guard] for ~c[char<=] specifies that its arguments are ~il[characters].

  ~c[Char<=] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (characterp x) (characterp y))))
  (<= (char-code x) (char-code y)))

#+acl2-loop-only
(defun char>= (x y)

  ":Doc-Section ACL2::ACL2-built-ins

  greater-than-or-equal test for ~il[characters]~/

  ~c[(char>= x y)] is true if and only if the character code of ~c[x] is
  greater than or equal to that of ~c[y].  ~l[char-code].~/

  The ~il[guard] for ~c[char>=] specifies that its arguments are ~il[characters].

  ~c[Char>=] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (characterp x) (characterp y))))
  (>= (char-code x) (char-code y)))

(defun string<-l (l1 l2 i)
  (declare (xargs :guard (and (character-listp l1)
                              (character-listp l2)
                              (integerp i))))
  (cond ((endp l1)
         (cond ((endp l2) nil)
               (t i)))
        ((endp l2) nil)
        ((eql (car l1) (car l2))
         (string<-l (cdr l1) (cdr l2) (+ i 1)))
        ((char< (car l1) (car l2)) i)
        (t nil)))

#+acl2-loop-only
(defun string< (str1 str2)

  ":Doc-Section ACL2::ACL2-built-ins

  less-than test for strings~/

  ~c[(String< str1 str2)] is non-~c[nil] if and only if the string
  ~c[str1] precedes the string ~c[str2] lexicographically, where
  character inequalities are tested using ~ilc[char<].  When non-~c[nil],
  ~c[(string< str1 str2)] is the first position (zero-based) at which
  the strings differ.  Here are some examples.
  ~bv[]
  ACL2 !>(string< \"abcd\" \"abu\")
  2
  ACL2 !>(string< \"abcd\" \"Abu\")
  NIL
  ACL2 !>(string< \"abc\" \"abcde\")
  3
  ACL2 !>(string< \"abcde\" \"abc\")
  NIL
  ~ev[]
  ~/

  The ~il[guard] for ~c[string<] specifies that its arguments are strings.

  ~c[String<] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (stringp str1)
                              (stringp str2))))
  (string<-l (coerce str1 'list)
             (coerce str2 'list)
             0))

#+acl2-loop-only
(defun string> (str1 str2)

  ":Doc-Section ACL2::ACL2-built-ins

  greater-than test for strings~/

  ~c[(String> str1 str2)] is non-~c[nil] if and only if ~c[str2] precedes
  ~c[str1] lexicographically.  When non-~c[nil], ~c[(string> str1 str2)]
  is the first position (zero-based) at which the strings differ.
  ~l[string<].~/

  ~c[String>] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (stringp str1)
                              (stringp str2))))
  (string< str2 str1))

#+acl2-loop-only
(defun string<= (str1 str2)

  ":Doc-Section ACL2::ACL2-built-ins

  less-than-or-equal test for strings~/

  ~c[(String<= str1 str2)] is non-~c[nil] if and only if the string
  ~c[str1] precedes the string ~c[str2] lexicographically or the strings
  are equal.  When non-~c[nil], ~c[(string<= str1 str2)] is the first
  position (zero-based) at which the strings differ, if they differ,
  and otherwise is their common length.  ~l[string<].~/

  The ~il[guard] for ~c[string<=] specifies that its arguments are strings.

  ~c[String<=] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (stringp str1)
                              (stringp str2))))
  (if (equal str1 str2)
      (length str1)
    (string< str1 str2)))

#+acl2-loop-only
(defun string>= (str1 str2)

  ":Doc-Section ACL2::ACL2-built-ins

  less-than-or-equal test for strings~/

  ~c[(String>= str1 str2)] is non-~c[nil] if and only if the string
  ~c[str2] precedes the string ~c[str1] lexicographically or the strings
  are equal.  When non-~c[nil], ~c[(string>= str1 str2)] is the first
  position (zero-based) at which the strings differ, if they differ,
  and otherwise is their common length.  ~l[string>].~/

  The ~il[guard] for ~c[string>=] specifies that its arguments are strings.

  ~c[String>=] is a Common Lisp function.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (stringp str1)
                              (stringp str2))))
  (if (equal str1 str2)
      (length str1)
    (string> str1 str2)))

(defun symbol-< (x y)

  ":Doc-Section ACL2::ACL2-built-ins

  less-than test for symbols~/

  ~c[(symbol-< x y)] is non-~c[nil] if and only if either the
  ~ilc[symbol-name] of the symbol ~c[x] lexicographially precedes the
  ~ilc[symbol-name] of the symbol ~c[y] (in the sense of ~ilc[string<]) or
  else the ~ilc[symbol-name]s are equal and the ~ilc[symbol-package-name] of
  ~c[x] lexicographically precedes that of ~c[y] (in the same sense).
  So for example, ~c[(symbol-< 'abcd 'abce)] and
  ~c[(symbol-< 'acl2::abcd 'foo::abce)] are true.~/

  The ~il[guard] for ~c[symbol] specifies that its arguments are symbols.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (symbolp x) (symbolp y))))
  (let ((x1 (symbol-name x))
        (y1 (symbol-name y)))
    (or (string< x1 y1)
        (and (equal x1 y1)
             (string< (symbol-package-name x)
                      (symbol-package-name y))))))

(defthm string<-l-irreflexive
  (not (string<-l x x i)))

(defthm string<-irreflexive
  (not (string< s s)))

(defun substitute-ac (new old seq acc)
  (declare (xargs :guard (and (true-listp acc)
                              (true-listp seq)
                              (or (eqlablep old)
                                  (eqlable-listp seq)))))
  (cond
   ((endp seq)
    (reverse acc))
   ((eql old (car seq))
    (substitute-ac new old (cdr seq) (cons new acc)))
   (t
    (substitute-ac new old (cdr seq) (cons (car seq) acc)))))

#+acl2-loop-only
(defun substitute (new old seq)

  ":Doc-Section ACL2::ACL2-built-ins

  substitute into a string or a list, using ~ilc[eql] as test~/

  ~c[(Substitute new old seq)] is the result of replacing each occurrence
  of ~c[old] in ~c[seq], which is a list or a string, with ~c[new].~/

  The guard for ~c[substitute] requires that either ~c[seq] is a string and
  ~c[new] is a character, or else:  ~c[seq] is a ~ilc[true-listp] such that either
  all of its members are ~ilc[eqlablep] or ~c[old] is ~c[eqlablep].

  ~c[Substitute] is a Common Lisp function.  See any Common Lisp
  documentation for more information.  Since ACL2 functions cannot
  take keyword arguments (though macros can), the test used in
  ~c[substitute] is ~c[eql].

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (or (and (stringp seq)
                                  (characterp new))
                             (and (true-listp seq)
                                  (or (eqlablep old)
                                      (eqlable-listp seq))))

; Wait for state-global-let* to be defined, so that we can provide a
; local lemma.

                  :verify-guards nil))
  (if (stringp seq)
      (coerce (substitute-ac new old (coerce seq 'list) nil)
              'string)
    (substitute-ac new old seq nil)))

#+acl2-loop-only
(defun sublis (alist tree)

  ":Doc-Section ACL2::ACL2-built-ins

  substitute an alist into a tree~/

  ~c[(Sublis alist tree)] is obtained by replacing every leaf of
  ~c[tree] with the result of looking that leaf up in the association
  list ~c[alist].  However, a leaf is left unchanged if it is not found
  as a key in ~c[alist].~/

  Leaves are looked up using the function ~ilc[assoc].  The ~il[guard] for
  ~c[(sublis alist tree)] requires ~c[(eqlable-alistp alist)].  This
  ~il[guard] ensures that the ~il[guard] for ~ilc[assoc] will be met for each
  lookup generated by ~c[sublis].

  ~c[Sublis] is defined in Common Lisp.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (eqlable-alistp alist)))
  (cond ((atom tree)
         (let ((pair (assoc tree alist)))
           (cond (pair (cdr pair))
                 (t tree))))
        (t (cons (sublis alist (car tree))
                 (sublis alist (cdr tree))))))

#+acl2-loop-only
(defun subst (new old tree)

  ":Doc-Section ACL2::ACL2-built-ins

  a single substitution into a tree~/

  ~c[(Subst new old tree)] is obtained by substituting ~c[new] for every
  occurence of ~c[old] in the given tree.~/

  Equality to ~c[old] is determined using the function ~ilc[eql].  The
  ~il[guard] for ~c[(subst new old tree)] requires ~c[(eqlablep old)], which
  ensures that the ~il[guard] for ~ilc[eql] will be met for each comparison
  generated by ~c[subst].

  ~c[Subst] is defined in Common Lisp.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (eqlablep old)))
  (cond ((eql old tree) new)
        ((atom tree) tree)
        (t (cons (subst new old (car tree))
                 (subst new old (cdr tree))))))

(defmacro pprogn (&rest lst)

; Keep in sync with pprogn@par.

  ":Doc-Section ACL2::ACL2-built-ins

  evaluate a sequence of forms that return ~il[state]~/
  ~bv[]
  Example Form:
  (pprogn
   (cond ((or (equal (car l) #\\) (equal (car l) slash-char))
          (princ$ #\\ channel state))
         (t state))
   (princ$ (car l) channel state)
   (mv (cdr l) state))
  ~ev[]
  The convention for ~c[pprogn] usage is to give it a non-empty
  sequence of forms, each of which (except possibly for the last)
  returns state (~pl[state]) as its only value.  The ~il[state] returned by
  each but the last is passed on to the next.  The value or values of
  the last form are returned as the value of the ~c[pprogn].

  If you are using single-threaded objects you may wish to define an
  analogue of this function for your own ~il[stobj].~/

  General Form:
  ~bv[]
  (PPROGN form1
          form2
          ...
          formk
          result-form)
  ~ev[]
  This general form is equivalent, via macro expansion, to:
  ~bv[]
  (LET ((STATE form1))
       (LET ((STATE form2))
            ...
            (LET ((STATE formk))
                 result-form)))
  ~ev[]
  ~/"

  (declare (xargs :guard (and lst
                              (true-listp lst))))
  (cond ((endp (cdr lst)) (car lst))
        #-acl2-loop-only

; The next case avoids compiler warnings from (pprogn .... (progn! ...)).  Note
; that progn! in raw Lisp binds state to *the-live-state*, and hence shadows
; superior bindings of state.  We are tempted to check that the last form
; starts with progn!, but of course it could be a macro call that expands to a
; call of progn!, so we make no such check.

        ((endp (cddr lst))
         (list 'let
               (list (list 'STATE (car lst)))
               '(DECLARE (IGNORABLE STATE))
               (cadr lst)))
        (t (list 'let
                 (list (list 'STATE (car lst)))
                 (cons 'pprogn (cdr lst))))))

(defmacro progn$ (&rest rst)

  ":Doc-Section ACL2::ACL2-built-ins

  execute a sequence of forms and return the value of the last one~/

  This macro expands to a corresponding nest of calls of ~c[prog2$];
  ~pl[prog2$].  The examples below show how this works: the first case below is
  typical, but we conclude with two special cases.
  ~bv[]
  ACL2 !>:trans1 (progn$ (f1 x) (f2 x) (f3 x))
   (PROG2$ (F1 X) (PROG2$ (F2 X) (F3 X)))
  ACL2 !>:trans1 (progn$ (f1 x) (f2 x))
   (PROG2$ (F1 X) (F2 X))
  ACL2 !>:trans1 (progn$ (f1 x))
   (F1 X)
  ACL2 !>:trans1 (progn$)
   NIL
  ACL2 !>
  ~ev[]~/~/"

  (cond ((null rst) nil)
        ((null (cdr rst)) (car rst))
        (t (xxxjoin 'prog2$ rst))))

#+acl2-par
(defmacro pprogn@par (&rest rst)

; Keep in sync with pprogn.

  `(progn$ ,@rst))

; The Unwind-Protect Essay

; We wish to define an ACL2 macro form:

; (acl2-unwind-protect "expl" body cleanup1 cleanup2)

; with the following logical semantics

; (mv-let (erp val state)
;         ,body
;         (cond (erp (pprogn ,cleanup1 (mv erp val state)))
;               (t   (pprogn ,cleanup2 (mv erp val state)))))

; The idea is that it returns the 3 results of evaluating body except before
; propagating those results upwards it runs one of the two cleanup forms,
; depending on whether the body signalled an error.  The cleanup forms return
; state.  In typical use the cleanup forms restore the values of state global
; variables that were "temporarily" set by body.  [Note that the "expl"
; is a string and it is always ignored.  Its only use is to tag the elements
; of the stacks in the frames of *acl2-unwind-protect-stack* so that debugging
; is easier.  None of our code actually looks at it.]

; In addition, we want acl2-unwind-protect to handle aborts caused by the user
; during the processing of body and we want ev to handle acl2-unwind-protect
; "properly" in a sense discussed later.

; We deal first with the notion of the "proper" way to handle aborts.  Because
; of the way acl2-unwind-protect is used, namely to "restore" a "temporarily"
; smashed state, aborts during body should not prevent the execution of the
; cleanup code.  Intuitively, the compiled form of an acl2-unwind-protect
; ought to involve a Common Lisp unwind-protect.  In fact, it does not, for
; reasons developed below.  But it is easier to think about the correctness of
; our implementation if we start by thinking in terms of using a raw lisp
; unwind-protect in the macroexpansion of each acl2-unwind-protect.

; The (imagined) unwind-protect is almost always irrelevant because "errors"
; signalled by body are in fact not Lisp errors.  But should the user cause an
; abort during body, the unwind-protect will ensure that cleanup1 is executed.
; This is a logically arbitrary choice; we might have said cleanup2 is
; executed.  By "ensure" we mean not only will the Lisp unwind-protect fire
; the cleanup code even though body was aborted; we mean that the cleanup code
; will be executed without possibility of abort.  Now there is no way to
; disable interrupts in CLTL.  But if we make sufficient assumptions about the
; cleanup forms then we can effectively disable interrupts by executing each
; cleanup form repeatedly until it is executed once without being aborted.  We
; might define "idempotency" to be just the necessary property: the repeated
; (possibly partial) execution of the form, followed by a complete execution
; of the form, produces the same state as a single complete execution.  For
; example, (f-put-global 'foo 'old-val state) is idempotent but (f-put-global
; 'foo (1- (get-global 'foo state)) state) is not.  Cleanup1 should be idempotent
; to ensure that our implementation of unwind protect in the face of aborts is
; correct with respect to the (non-logical) semantics we have described.
; Furthermore, it bears pointing out that cleanup1 might be called upon to undo
; the work of a "partial" execution of cleanup2!  This happens if the body
; completes normally and without signalling an error, cleanup2 is undertaken,
; and then the user aborts.  So the rule is that if an abort occurs during an
; acl2-unwind-protect, cleanup1 is executed without interrupts.

; What, pray, gives us the freedom to give arbitrary semantics to
; acl2-unwind-protect in the face of an abort?  We regard an abort as akin to
; unplugging the machine and plugging it back in.  One should be thankful for
; any reasonable behavior and not quibble over whether it is the "logical" one
; or whether one ought to enforce informal rules like idempotency.  Thus, we
; are not terribly sympathetic to arguments that this operational model is
; inconsistent with ACL2 semantics when the user types "Abort!" or doesn't
; understand unenforced assumptions about his cleanup code.  All logical bets
; are off the moment the user types "Abort!".  This model has the saving grace
; that we can implement it and that it can be used within the ACL2 system code
; to implement what we need during abort recovery.  The operational model of
; an abort is that the machine finds the innermost acl2-unwind-protect, rips
; out of the execution of its body (or its cleanup code), executes the
; cleanup1 code with all aborts disabled and then propagates the abort upward.

; Now unfortunately this operational model cannot be implemented
; entirely locally in the compilation of an acl2-unwind-protect.
; Operationally, (acl2-unwind-protect "expl" body cleanup1
; cleanup2) sort of feels like:

; (unwind-protect ,body
;   (cond (<body was aborted> ,cleanup1 <pass abort up>)
;         (<body signalled erp> ,cleanup1 <pass (mv erp val state') up>)
;         (t ,cleanup2 <pass (mv erp val state') up>)))

; where we do whatever we have to do to detect aborts and to pass aborts up in
; some cases and triples up in others.  This can all be done with a suitable
; local nest of let, catch, unwind-protect, tests, and throw.  But there is a
; problem: if the user is typing "Abort!" then what is to prevent him from
; doing it during the cleanup forms?  Nothing.  So in fact the sketched use of
; unwind-protect doesn't guarantee that the cleanup forms are executed fully.
; We have been unable to find a way to guarantee via locally produced compiled
; code that even idempotent cleanup forms are executed without interruption.

; Therefore, we take a step back and claim that at the top of the system is
; the ACL2 command interpreter.  It will have an unwind-protect in it (quite
; probably the only unwind-protect in the whole system) and it will guarantee
; to execute all the cleanup forms before it prompts the user for the next
; expression to evaluate.  An abort there will rip us out of the command
; interpreter.  We shall arrange for re-entering it to execute the cleanup
; forms before prompting.  If we imagine, again, that each acl2-unwind-protect
; is compiled into an unwind-protect, then since the aborts are passed up and
; the cleanup forms are each executed in turn as we ascend back to the top,
; the cleanup forms are just stacked.  It suffices then for
; acl2-unwind-protect to push the relevant cleanup form (always form 1) on
; this stack before executing body and for the top-level to pop these forms
; and evaluate them one at a time before prompting for the next input.
; Actually, we must push the cleanup form and the current variable bindings in
; order to be able to evaluate the form "out of context."

; The stack in question is called *acl2-unwind-protect-stack*.  It is really a
; stack of "frames".  Each frame on the stack corresponds to a call of the
; general-purpose ACL2 read-eval-print loop.  By so organizing it we can ensure
; that each call of the read-eval-print loop manages its own unwind protection
; (in the normal case) while also insuring that the stack is global and visible
; to all.  This allows each level to clean up after aborted inferiors what
; failed to clean up after themselves.  If however we abort during the last
; cleanup form, we will find ourselves in raw Lisp.  See the comment about this
; case in ld-fn.

; One final observation is in order.  It could be that there is no command
; interpreter because we are running an ACL2 application in raw lisp.  In that
; case, "Abort!" means the machine was unplugged and all bets are off anyway.

#-acl2-loop-only
(defparameter *acl2-unwind-protect-stack* nil)

#-acl2-loop-only
(defmacro push-car (item place ctx)
  (let ((g (gensym)))
    `(let ((,g ,place))
       (if (consp ,g)
           (push ,item (car ,g))
         (if *lp-ever-entered-p*
             (illegal ,ctx
                      "Apparently you have tried to execute a form in raw Lisp ~
                       that is only intended to be executed inside the ACL2 ~
                       loop.  You should probably abort (e.g., :Q in akcl or ~
                       gcl, :A in LispWorks, :POP in Allegro), then type (LP) ~
                       and try again.  If this explanation seems incorrect, ~
                       then please contact the implementors of ACL2."
                      nil)
           (illegal ,ctx
                    "Please enter the ACL2 loop by typing (LP) <return>."
                    nil))))))

(defmacro acl2-unwind-protect (expl body cleanup1 cleanup2)

; Note: If the names used for the erp and val results are changed in the #+
; code, then change them in the #- code also.  We use the same names (rather
; than using gensym) just because we know they are acceptable if translate
; approves the check-vars-not-free.

; Note: Keep this function in sync with translated-acl2-unwind-protectp4.  That
; function not only knows the precise form of the expression generated below
; but even knows the variable names used!

  #+acl2-loop-only
  (declare (ignore expl))
  #+acl2-loop-only
  `(mv-let (acl2-unwind-protect-erp acl2-unwind-protect-val state)
           (check-vars-not-free
            (acl2-unwind-protect-erp acl2-unwind-protect-val)
            ,body)
           (cond
            (acl2-unwind-protect-erp
             (pprogn (check-vars-not-free
                      (acl2-unwind-protect-erp acl2-unwind-protect-val)
                      ,cleanup1)
                     (mv acl2-unwind-protect-erp
                         acl2-unwind-protect-val
                         state)))
            (t (pprogn (check-vars-not-free
                        (acl2-unwind-protect-erp acl2-unwind-protect-val)
                        ,cleanup2)
                       (mv acl2-unwind-protect-erp
                           acl2-unwind-protect-val
                           state)))))

; The raw code is very similar.  But it starts out by pushing onto the undo
; stack the name of the cleanup function and the values of the arguments.  Note
; however that we do this only if the state is the live state.  That is the
; only state that matters after an abort.  Suppose unwind protected code is
; modifying some state object other than the live one (e.g., we are computing
; some explicit value during a proof).  Suppose an abort occurs.  Consider the
; operational model described: we rip out of the computation, execute the
; cleanup code for the nearest unwind protect, and then pass the abort upwards,
; continuing until we get to the top level.  No state besides the live one is
; relevant because no value is returned from an aborted computation.  The fake
; state cleaned up at each stop on the way up is just wasted time.  So we don't
; push the cleanup code for fake states.  If body concludes without an abort we
; execute the appropriate cleanup form and then we pop the undo stack (if we
; pushed something).  Note that it is possible that body completes without
; error, cleanup2 is started (and begins smashing state) and then (perhaps even
; after the completion of cleanup2 but before the pop) an abort rips us out,
; causing cleanup1 to be executed after cleanup2.  Idempotency is not enough to
; say.

  #-acl2-loop-only
  `(let ((temp (and (live-state-p state)

; We have seen warnings from LispWorks 4.2.7 of this form that appear to be
; related to the present binding, but we do not yet know how to eliminate them:
;
; Eliminating a test of a variable with a declared type : TEMP [type CONS]

                    (cons ,expl (function (lambda nil ,cleanup1))))))

; FUNCTION captures the binding environment in which cleanup1 would
; have been executed.  So by applying the resulting function to no
; arguments we evaluate cleanup1 in the current environment.  We save
; this cons in temp so we can recognize it below.  If we're not
; operating on the live state, temp is nil.

     (cond (temp
            (push-car temp
                      *acl2-unwind-protect-stack*
                      'acl2-unwind-protect)))

     (mv-let (acl2-unwind-protect-erp acl2-unwind-protect-val state)
             ,body

; Roughly speaking, we should execute cleanup1 or cleanup2, as
; appropriate based on acl2-unwind-protect-erp, and then pop the
; stack.  (Indeed, we used to do this.)  However, it is possible that
; the execution of body pushed more forms on the stack and they
; haven't been cleaned off yet because of hard errors.  Therefore, we
; first restore the stack to just after the pushing of temp, if we
; pushed temp.

             (cond (temp (acl2-unwind -1 temp)))

             (cond
              (acl2-unwind-protect-erp
               (pprogn ,cleanup1
                       (cond (temp
                              (pop (car *acl2-unwind-protect-stack*))
                              state)
                             (t state))
                       (mv acl2-unwind-protect-erp
                           acl2-unwind-protect-val
                           state)))
              (t (pprogn ,cleanup2
                         (cond (temp
                                (pop (car *acl2-unwind-protect-stack*))
                                state)
                               (t state))
                         (mv acl2-unwind-protect-erp
                             acl2-unwind-protect-val
                             state)))))))

#-acl2-loop-only
(defun-one-output acl2-unwind (n flg)

; flg = nil, pop until length of stack is n.  Do not mess with new top-most
; frame.

; flg = t, pop until the length of the stack is n and there is
; at most one form in the top-most frame.  This configures the stack
; the way it was when frame n was first built.

; (consp flg), pop until the top-most form in the top frame is eq to
; flg.  We do not execute that form.  Note that n is irrelevant in
; this case.

; In all cases, no form is removed from the stack until the form has been
; executed.  Thus, an interruption in this process will leave the still-undone
; cleanup forms on the stack for continued processing.

; There is a very odd aspect to this function: the value of each cleanup form
; is simply discarded!  What is going on?  To think about this it is clarifying
; first to consider the case of cleanup in the absence of aborts, i.e., to
; think about the logical semantics of unwind protection.  Consider then
; (acl2-unwind-protect "expl" body cleanup1 cleanup2).  Call the initial STATE st.
; Suppose body computes normally but returns (mv t nil st').  That is, body
; signals an error and returns a modified state (e.g., that has the error
; message printed to it).  Then cleanup1 is executed on st' to produce st''
; and then the error triple (mv t nil st'') is propagated upwards.  Note that
; unlike all the other variables in the cleanup form, the STATE used by
; cleanup1 is the post-body value of the variable, not the pre-body value.

; Now reflect on our abort processing.  Before body is executed we captured the
; binding environment in which cleanup1 would have been executed, except that
; that environment contains the pre-body value for STATE.  If an abort occurs
; during body we evaluate the cleanup function on those saved values.
; Technically we should replace the value of STATE by the post-body state, st',
; produced by body before the abort.  Technically we should then pass upward to
; the next cleanup form the state, st'', produced by the just executed cleanup
; form.

; What prevents us from having to do this is the fact that we are always
; cleaning up the live state and only the live state.  The slot holding STATE
; in the environment captured by FUNCTION contains *the-live-state*, which is
; both the pre-body and post-body value of STATE.  The result of the cleanup
; form is guaranteed to be *the-live-state*.  And so it only looks like we are
; ignoring the values of the cleanup forms!

  (cond ((cond
          ((eq flg nil)
           (= (length *acl2-unwind-protect-stack*) n))
          ((eq flg t)
           (and (= (length *acl2-unwind-protect-stack*) n)
                (or (null (car *acl2-unwind-protect-stack*))
                    (null (cdr (car *acl2-unwind-protect-stack*))))))
          (t (eq flg (car (car *acl2-unwind-protect-stack*)))))
         nil)
        ((null (car *acl2-unwind-protect-stack*))
         (pop *acl2-unwind-protect-stack*)
         (acl2-unwind n flg))
        (t (let ((*wormholep* nil))

; We bind *wormholep* to nil so that we do not try to store undo forms
; for the state changes we are about to make.

             (apply (cdr (car (car *acl2-unwind-protect-stack*)))
; The presence of expl requires us to take the cdr!
                    nil))

           (pop (car *acl2-unwind-protect-stack*))
           (acl2-unwind n flg))))

; The above function, acl2-unwind, will be called in the command interpreter
; before any command is read from the user.  Thus, by the time a user command
; is executed we are guaranteed that all cleanup forms from the previous
; command have been completed, regardless of how often it and its cleanup forms
; were interrupted.  This completes our consideration of user-caused aborts
; during the execution of ACL2 source or compiled code by the Common Lisp
; system.  Now we turn to the even more complicated (!) business of the
; "correct" execution acl2-unwind-protect by ACL2's own EV.

; The code for EV is presented several files from here.  But we discuss
; the design issues here while the previous discussion is still fresh.
; By way of foreshadowing, ev is an interpreter for the logic.

; The first problem is that when EV sees an acl2-unwind-protect it doesn't see
; an acl2-unwind-protect at all.  It sees the translation of the macro
; expansion.  To make matters worse, there are two translations of an MV-LET
; expression: one if the expression occurs inside a function definition (or is
; otherwise deemed "executable") and another if it does not.  The functions
; translated-acl2-unwind-protectp and translated-acl2-unwind-protectp4
; recognize and return the relevant parts of a translated acl2-unwind-protect.
; We can't define them here because they use case-match, which isn't yet
; defined.

; So imagine that EV encounters a translated acl2-unwind-protect form, say
; (acl2-unwind-protect "expl" body cleanup1 cleanup2).  Of course, if the
; evaluation is error and abort free, then it is done correctly.  If an abort
; occurs we are free (by the unplugging argument) to do whatever we want.  But
; what should EV do if there is some kind of an evaluation error in body?  For
; example, suppose body calls an undefined function or violates some guard.  A
; simple concrete question is "what should EV return on

; (acl2-unwind-protect "expl"
;                      (mv nil (car 0) state)
;                      (f-put-global 'foo 'error state)
;                      (f-put-global 'foo 'no-error state))?"

; For what it is worth, our answer to this concrete question is:
; (mv t "guard violation msg for car" (f-put-global 'foo 'error state)).
; To discuss this, we have to tip-toe carefully around a variety of "errors."
; Let us review EV's functionality.

; EV returns (mv erp val latches), where val is the value of the given
; form when erp is nil.  If the form returns a multiple value, then val
; is the corresponding list.  Note well: if form returns an error
; triple, then the error flag of that triple is the car of val, not
; erp.  If erp is t, then some sort of "evaluation error" occurred
; (such as a udf, ubv or guard violation) and val is an error message.
; Latches is an alist that contains the current values of all stobjs,
; including one for 'state.  We distinguish "evaluation errors" (erp =
; t) from the "programmed errors" that may be signaled by some bodies.
; A programmed error is signaled by val being a list of the form
; (t nil state), except that the actual state is to be found in the final
; value of the latches, not in val.

; It is useful to draw an analogy between Common Lisp execution of
; ACL2 source code and the EV interpretation of such code.  In that
; analogy, EV's "evaluation errors" correspond to "aborts" and "hard
; errors," while EV's "programmed errors" correspond to "soft errors."
; It is this analogy that guides us in the design of EV.  What does EV
; do if an evaluation error occurs during body?  Consider the analogy:
; if Common Lisp gets a hard error during the evaluation of body, it
; evaluates cleanup1 and then passes the hard error up.  Therefore, if
; EV gets an evaluation error during the evaluation of body, it
; evaluates cleanup1 and then passes the evaluation error up.  In
; particular, if the attempt to eval body produces (mv t "msg"
; latches') then EV returns (mv t "msg" latches''), where latches'' is
; obtained by evaluating cleanup1 with STATE bound to latches'.  This is
; analogous to what Common Lisp does for the live state.  EV can do it
; for any state (live or otherwise) because it is tracking explicitly
; "the last returned state" during the computation, while Common Lisp
; is not.  Furthermore, Common Lisp need not pass non-live states up
; since it is only the cleaned up live state that matters -- no other
; value is returned from aborted computations.  But EV may be called
; by ACL2 code that makes use of the last state returned during the
; computation.

; If we could stop here the situation would be pretty neat.  But there
; is more.  EV must deal with a third kind of error: true aborts.  We
; have just spoken of evaluation errors (i.e., guard violations and
; other errors detected by EV during evaluation) and of programmed
; errors signaled by the code EV is evaluating.  But what if the user
; types "Abort?"  Certainly neither EV nor its caller "catches" the
; abort: we just rip our way up through the unwind protects.  But if
; EV was being used to modify the live state in an unwind protected
; way, those cleanup forms must be evaluated.  This is just another
; way of saying that EV's interpretation of acl2-unwind-protect must
; be phrased in terms of acl2-unwind-protect just so that the live
; state is cleaned up after aborts.  We can't actually do that because
; acl2-unwind-protect is too structured and insists that we deal with
; (mv erp val state) triples when EV is dealing with (mv erp (mv erp
; val state) latches) triples.  But we use the same raw mechanism of
; the *acl2-unwind-protect-stack*.

; Now the question arises, "what gives us the right to design EV by
; analogy?"  The spec for EV is that it returns the correct value when
; it reports no error (returned erp = nil).  When an evaluation error
; is reported then all bets are off, i.e., the plug was pulled, and we
; can pretty much return the latches we want, as long as it, indeed,
; contains the final values of all the stobjs.

; This completes the unwind-protect essay.  There are some additional comments
; in the code for EV.

; It is IMPERATIVE that the following macro, when-logic, is ONLY used when its
; second argument is a form that evaluates to an error triple.  Keep this
; function in sync with boot-translate.

(defmacro when-logic (str x)
  (list 'if
        '(eq (default-defun-mode-from-state state)
             :program)
        (list 'skip-when-logic (list 'quote str) 'state)
        x))

; ---------------------------------------------------------------------------
; The *initial-event-defmacros* Discussion

; Lasciate ogni speranza, voi ch' entrate

; The following sequence of defmacros is critically important during
; boot strapping because they define the macros we have been using all
; this time!  In fact, this very sequence of forms (minus those not
; marked by the Warning message seen repeatedly below) appears
; elsewhere in this system as a quoted list of constants,
; *initial-event-defmacros*.

; We'll present the defmacros first and then explain the rules for
; adding to or changing them.  See also the discussion at
; *initial-event-defmacros*.

#+acl2-loop-only
(defmacro in-package (str)

; Warning: See the Important Boot-Strapping Invariants before modifying!

  ":Doc-Section ACL2::Other

  select current package~/
  ~bv[]
  Example:
  (in-package \"MY-PKG\")~/

  General Form:
  (in-package str)
  ~ev[]
  where ~c[str] is a string that names an existing ACL2 package, i.e.,
  one of the initial packages such as ~c[\"KEYWORD\"] or ~c[\"ACL2\"] or a
  package introduced with ~ilc[defpkg].  For a complete list of the known
  packages created with ~ilc[defpkg], evaluate
  ~bv[]
  (strip-cars (known-package-alist state)).
  ~ev[]
  ~l[defpkg].  An ACL2 book (~pl[books]) must contain a single ~c[in-package]
  form, which must be the first form in that book."

; Warning: See the Important Boot-Strapping Invariants before modifying!

  (list 'in-package-fn (list 'quote str) 'state))

#+acl2-loop-only
(defmacro defpkg (&whole event-form name form &optional doc book-path hidden-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".

; Keep this in sync with get-cmds-from-portcullis1, make-hidden-defpkg,
; equal-modulo-hidden-defpkgs, and (of course) the #-acl2-loop-only definition
; of defpkg.

  ":Doc-Section Events

  define a new symbol package~/
  ~bv[]
  Example:
  (defpkg \"MY-PKG\"
          (union-eq *acl2-exports*
                    *common-lisp-symbols-from-main-lisp-package*))~/

  General Form:
  (defpkg \"name\" term doc-string)
  ~ev[]

  where ~c[\"name\"] is a non-empty string consisting of standard characters
  (~pl[standard-char-p]), none of which is lower case, that names the package
  to be created; ~c[term] is a variable-free expression that evaluates to a
  list of symbols, where no two distinct symbols in the list may have the same
  ~ilc[symbol-name], to be imported into the newly created package; and
  ~ilc[doc-string] is an optional ~il[documentation] string; ~pl[doc-string].
  The name of the new package must be ``new'': the host lisp must not contain
  any package of that name.  There are two exceptions to this newness rule,
  discussed at the end of this documentation.

  (There is actually an additional argument, book-path, that is used for error
  reporting but has no logical content.  Users should generally ignore this
  argument, as well as the rest of this sentence: a book-path will be specified
  for ~ilc[defpkg] events added by ACL2 to the ~il[portcullis] of a book's
  ~il[certificate]; ~pl[hidden-death-package].)

  ~c[Defpkg] forms can be entered at the top-level of the ACL2 ~il[command]
  loop.  They should not occur in ~il[books] (~pl[certify-book]).

  After a successful ~c[defpkg] it is possible to ``intern'' a string
  into the package using ~ilc[intern-in-package-of-symbol].  The result
  is a symbol that is in the indicated package, provided the imports
  allow it.  For example, suppose ~c['my-pkg::abc] is a symbol whose
  ~ilc[symbol-package-name] is ~c[\"MY-PKG\"].  Suppose further that
  the imports specified in the ~c[defpkg] for ~c[\"MY-PKG\"] do not include
  a symbol whose ~ilc[symbol-name] is ~c[\"XYZ\"].  Then
  ~bv[]
  (intern-in-package-of-symbol \"XYZ\" 'my-pkg::abc)
  ~ev[]
  returns a symbol whose ~ilc[symbol-name] is ~c[\"XYZ\"] and whose
  ~ilc[symbol-package-name] is ~c[\"MY-PKG\"].  On the other hand, if
  the imports to the ~c[defpkg] does include a symbol with the name
  ~c[\"XYZ\"], say in the package ~c[\"LISP\"], then
  ~bv[]
  (intern-in-package-of-symbol \"XYZ\" 'my-pkg::abc)
  ~ev[]
  returns that symbol (which is uniquely determined by the restriction
  on the imports list above).  ~l[intern-in-package-of-symbol].

  Upon admission of a ~c[defpkg] event, the function ~c[pkg-imports] is
  extended to compute a list of all symbols imported into the given package,
  without duplicates.

  ~c[Defpkg] is the only means by which an ACL2 user can create a new
  package or specify what it imports.  That is, ACL2 does not support
  the Common Lisp functions ~c[make-package] or ~c[import].  Currently, ACL2
  does not support exporting at all.

  The Common Lisp function ~ilc[intern] is weakly supported by ACL2;
  ~pl[intern].  A more general form of that function is also provided:
  ~pl[intern$].

  We now explain the two exceptions to the newness rule for package
  names.  The careful experimenter will note that if a package is
  created with a ~c[defpkg] that is subsequently undone, the host lisp
  system will contain the created package even after the undo.
  Because ACL2 hangs onto ~il[world]s after they have been undone, e.g., to
  implement ~c[:]~ilc[oops] but, more importantly, to implement error recovery,
  we cannot actually destroy a package upon undoing it.  Thus, the
  first exception to the newness rule is that ~c[name] is allowed to be
  the name of an existing package if that package was created by an
  undone ~c[defpkg] and the newly proposed set of imports is identical to the
  old one.  ~l[package-reincarnation-import-restrictions].  This
  exception does not violate the spirit of the newness rule, since one
  is disinclined to believe in the existence of undone packages.  The
  second exception is that ~c[name] is allowed to be the name of an
  existing package if the package was created by a ~c[defpkg] with
  identical set of imports.  That is, it is permissible to execute
  ``redundant'' ~c[defpkg] ~il[command]s.  The redundancy test is based on the
  values of the two import forms (comparing them after sorting and removing
  duplicates), not on the forms themselves.

  Finally, we explain why we require the package name to contain standard
  characters, none of which is lower case.  We have seen at least one
  implementation that handled lower-case package names incorrectly.  Since we
  see no need for lower-case characters in package names, which can lead to
  confusion anyhow (note for example that ~c[foo::bar] is a symbol whose
  ~ilc[symbol-package-name] is ~c[\"FOO\"], not ~c[\"foo\"]), we simply
  disallow them.  Since the notion of ``lower case'' is only well-specified in
  Common Lisp for standard characters, we restrict to these.

  NOTE: Also ~pl[managing-acl2-packages] for contributed documentation on
  managing ACL2 packages.~/

  :cited-by Programming"

; Warning: See the Important Boot-Strapping Invariants before modifying!

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

(defdoc managing-acl2-packages
  ":Doc-Section defpkg

  user-contributed documentation on packages~/

  Jared Davis has contributed documentation on managing ACL2
  packages.  See
  ~url[http://www.cs.utexas.edu/users/moore/acl2/contrib/managing-acl2-packages.html].~/~/")

(deflabel hidden-defpkg
  :doc
  ":Doc-Section defpkg

  handling defpkg events that are local~/

  ~l[hidden-death-package]~/~/")

(deflabel hidden-death-package
  :doc
  ":Doc-Section defpkg

  handling ~ilc[defpkg] ~il[events] that are ~ilc[local]~/

  This documentation topic explains a little bit about certain errors users may
  see when attempting to evaluate a ~ilc[defpkg] event.  In brief, if you see
  an error that refers you to this topic, you are probably trying to admit a
  ~ilc[defpkg] event, and you should change the name of the package to be
  introduced by that event.

  Recall that ~c[defpkg] events introduce axioms, for example as follows.
  ~bv[]
  ACL2 !>(defpkg \"PKG0\" '(a b))

  Summary
  Form:  ( DEFPKG \"PKG0\" ...)
  Rules: NIL
  Warnings:  None
  Time:  0.01 seconds (prove: 0.00, print: 0.00, other: 0.01)
   \"PKG0\"
  ACL2 !>:pr! \"PKG0\"

  Rune:       (:REWRITE PKG0-PACKAGE)
  Status:     Enabled
  Lhs:        (SYMBOL-PACKAGE-NAME (INTERN-IN-PACKAGE-OF-SYMBOL X Y))
  Rhs:        \"PKG0\"
  Hyps:       (AND (STRINGP X)
                   (NOT (MEMBER-SYMBOL-NAME X '(A B)))
                   (SYMBOLP Y)
                   (EQUAL (SYMBOL-PACKAGE-NAME Y) \"PKG0\"))
  Equiv:      EQUAL
  Backchain-limit-lst:    NIL
  Subclass:   BACKCHAIN
  Loop-stopper: NIL
  ACL2 !>
  ~ev[]
  Now, a ~ilc[defpkg] event may be executed underneath an ~ilc[encapsulate] or
  ~ilc[include-book] form that is marked ~ilc[local].  In that case, traces of
  the added axiom will disappear after the surrounding ~ilc[encapsulate] or
  ~ilc[include-book] form is admitted.  This can cause inconsistencies.  (You
  can take our word for it, or you can look at the example shown in the
  ``Essay on Hidden Packages'' in source file ~c[axioms.lisp].)

  In order to prevent unsoundness, then, ACL2 maintains the following
  invariant.  Let us say that a ~c[defpkg] event is ``hidden'' if it is in
  support of the current logical ~il[world] but is not present in that world as
  an event, because it is ~ilc[local] as indicated above.  We maintain the
  invariant that all ~ilc[defpkg] ~il[events], even if ``hidden'', are tracked
  under-the-hood in the current logical ~il[world].  Sometimes this property
  causes ~ilc[defpkg] events to be written to the ~il[portcullis] of a book's
  ~il[certificate] (~pl[books]).  At any rate, if you then try to define the
  package in a manner inconsistent with the earlier such definition, that is,
  with a different imports list, you will see an error because of the
  above-mentioned tracking.

  (By the way, this topic's name comes from Holly Bell, who heard
  \"hidden death package\" instead of \"hidden defpkg\".  The description
  seemed to fit.  Thanks, Holly!)~/~/")

#+acl2-loop-only
(defmacro defun (&whole event-form &rest def)

; Warning: See the Important Boot-Strapping Invariants before modifying!

  ":Doc-Section acl2::Events

  define a function symbol~/
  ~bv[]
  Examples:
  (defun app (x y)
    (if (consp x)
        (cons (car x) (app (cdr x) y))
        y))

  (defun fact (n)
    (declare (xargs :guard (and (integerp n)
                                (>= n 0))))
    (if (zp n)
        1
        (* n (fact (1- n)))))~/

  General Form:
  (defun fn (var1 ... varn) doc-string dcl ... dcl body),
  ~ev[]
  where ~c[fn] is the symbol you wish to define and is a new symbolic name
  (~pl[name]), ~c[(var1 ... varn)] is its list of formal parameters
  (~pl[name]), and ~c[body] is its body.  The definitional axiom is logically
  admissible provided certain restrictions are met.  These are sketched below.

  Note that ACL2 does not support the use of ~c[lambda-list] keywords (such as
  ~c[&optional]) in the formals list of functions.  We do support some such
  keywords in macros and often you can achieve the desired syntax by defining a
  macro in addition to the general version of your function.  ~l[defmacro].
  The ~il[documentation] string, ~ilc[doc-string], is optional; for a
  description of its form, ~pl[doc-string].

  The ~em[declarations] (~pl[declare]), ~c[dcl], are also optional.  If more
  than one ~c[dcl] form appears, they are effectively grouped together as one.
  Perhaps the most commonly used ACL2 specific declaration is of the form
  ~c[(declare (xargs :guard g :measure m))].  This declaration in the ~c[defun]
  of some function ~c[fn] has the effect of making the ``~il[guard]'' for
  ~c[fn] be the term ~c[g] and the ``measure'' be the term ~c[m].  The notion
  of ``measure'' is crucial to ACL2's definitional principle.  The notion of
  ``guard'' is not, and is discussed elsewhere; ~pl[verify-guards] and
  ~pl[set-verify-guards-eagerness].  Note that the ~c[:measure] is ignored in
  ~c[:]~ilc[program] mode; ~pl[defun-mode].

  We now briefly discuss the ACL2 definitional principle, using the following
  definition form which is offered as a more or less generic example.
  ~bv[]
  (defun fn (x y)
    (declare (xargs :guard (g x y)
                    :measure (m x y)))
    (if (test x y)
        (stop x y)
      (step (fn (d x) y))))
  ~ev[]
  Note that in our generic example, ~c[fn] has just two arguments, ~c[x] and
  ~c[y], the ~il[guard] and measure terms involve both of them, and the body is
  a simple case split on ~c[(test x y)] leading to a ``non-recursive'' branch,
  ~c[(stop x y)], and a ``recursive'' branch.  In the recursive branch, ~c[fn]
  is called after ``decrementing'' ~c[x] to ~c[(d x)] and some step function is
  applied to the result.  Of course, this generic example is quite specific in
  form but is intended to illustrate the more general case.

  Provided this definition is admissible under the logic, as outlined below, it
  adds the following axiom to the logic.
  ~bv[]
  Defining Axiom:
  (fn x y)
    =
  (if (test x y)
      (stop x y)
    (step (fn (d x) y)))
  ~ev[]
  Note that the ~il[guard] of ~c[fn] has no bearing on this logical axiom.

  This defining axiom is actually implemented in the ACL2 system by a
  ~c[:]~ilc[definition] rule, namely
  ~bv[]
  (equal (fn x y)
         (if (test a b)
             (stop a b)
           (step (fn (d a) b)))).
  ~ev[]
  ~l[definition] for a discussion of how definition rules are applied.  Roughly
  speaking, the rule causes certain instances of ~c[(fn x y)] to be replaced by
  the corresponding instances of the body above.  This is called ``opening up''
  ~c[(fn x y)].  The instances of ~c[(fn x y)] opened are chosen primarily by
  heuristics which determine that the recursive calls of ~c[fn] in the opened
  body (after simplification) are more desirable than the unopened call of
  ~c[fn].

  This discussion has assumed that the definition of ~c[fn] was admissible.
  Exactly what does that mean?  First, ~c[fn] must be a previously
  unaxiomatized function symbol (however, ~pl[ld-redefinition-action]).
  Second, the formal parameters must be distinct variable names.  Third, the
  ~il[guard], measure, and body should all be terms and should mention no free
  variables except the formal parameters.  Thus, for example, body may not
  contain references to ``global'' or ``special'' variables; ACL2 constants or
  additional formals should be used instead.

  The final conditions on admissibility concern the termination of the
  recursion.  Roughly put, all applications of ~c[fn] must terminate.  In
  particular, there must exist a binary relation, ~c[rel], and some unary
  predicate ~c[mp] such that ~c[rel] is well-founded on objects satisfying
  ~c[mp], the measure term ~c[m] must always produce something satisfying
  ~c[mp], and the measure term must decrease according to ~c[rel] in each
  recursive call, under the hypothesis that all the tests governing the call
  are satisfied.  By the meaning of well-foundedness, we know there are no
  infinitely descending chains of successively ~c[rel]-smaller ~c[mp]-objects.
  Thus, the recursion must terminate.

  The only primitive well-founded relation in ACL2 is ~ilc[o<] (~pl[o<]), which
  is known to be well-founded on the ~ilc[o-p]s (~pl[o-p]).  For the proof of
  well-foundedness, ~pl[proof-of-well-foundedness].  However it is possible to
  add new well-founded relations.  For details, ~pl[well-founded-relation].  We
  discuss later how to specify which well-founded relation is selected by
  ~c[defun] and in the present discussion we assume, without loss of
  generality, that it is ~ilc[o<] on the ~ilc[o-p]s.

  For example, for our generic definition of ~c[fn] above, with measure term
  ~c[(m x y)], two theorems must be proved.  The first establishes that ~c[m]
  produces an ordinal:
  ~bv[]
  (o-p (m x y)).
  ~ev[]
  The second shows that ~c[m] decreases in the (only) recursive call of ~c[fn]:
  ~bv[]
  (implies (not (test x y))
           (o< (m (d x) y) (m x y))).
  ~ev[]
  Observe that in the latter formula we must show that the ``~c[m]-size'' of
  ~c[(d x)] and ~c[y] is ``smaller than'' the ~c[m]-size of ~c[x] and ~c[y],
  provided the test, ~c[(test x y)], in the body fails, thus leading to the
  recursive call ~c[(fn (d x) y)].

  ~l[o<] for a discussion of this notion of ``smaller than.''  It should be
  noted that the most commonly used ordinals are the natural numbers and that
  on natural numbers, ~ilc[o<] is just the familiar ``less than'' relation
  (~ilc[<]).  Thus, it is very common to use a measure ~c[m] that returns a
  nonnegative integer, for then ~c[(o-p (m x y))] becomes a simple conjecture
  about the type of ~c[m] and the second formula above becomes a conjecture
  about the less-than relationship of nonnegative integer arithmetic.

  The most commonly used measure function is ~ilc[acl2-count], which computes a
  nonnegative integer size for all ACL2 objects.  ~l[acl2-count].

  Probably the most common recursive scheme in Lisp ~il[programming] is when
  some formal is supposed to be a list and in the recursive call it is replaced
  by its ~ilc[cdr].  For example, ~c[(test x y)] might be simply ~c[(atom x)]
  and ~c[(d x)] might be ~c[(cdr x)].  In that case, ~c[(acl2-count x)] is a
  suitable measure because the ~ilc[acl2-count] of a ~ilc[cons] is strictly
  larger than the ~ilc[acl2-count]s of its ~ilc[car] and ~ilc[cdr].  Thus,
  ``recursion by ~ilc[car]'' and ``recursion by ~ilc[cdr]'' are trivially
  admitted if ~ilc[acl2-count] is used as the measure and the definition
  protects every recursive call by a test insuring that the decremented
  argument is a ~ilc[consp].  Similarly, ``recursion by ~ilc[1-]'' in which a
  positive integer formal is decremented by one in recursion, is also trivially
  admissible.  ~l[built-in-clause] to extend the class of trivially admissible
  recursive schemes.

  We now turn to the question of which well-founded relation ~c[defun] uses.
  It should first be observed that ~c[defun] must actually select both a
  relation (e.g., ~ilc[o<]) and a domain predicate (e.g., ~ilc[o-p]) on which
  that relation is known to be well-founded.  But, as noted elsewhere
  (~pl[well-founded-relation]), every known well-founded relation has a unique
  domain predicate associated with it and so it suffices to identify simply the
  relation here.

  The ~ilc[xargs] field of a ~ilc[declare] permits the explicit specification
  of any known well-founded relation with the keyword
  ~c[:]~ilc[well-founded-relation].  An example is given below.  If the
  ~ilc[xargs] for a ~c[defun] specifies a well-founded relation, that relation
  and its associated domain predicate are used in generating the termination
  conditions for the definition.

  If no ~c[:]~ilc[well-founded-relation] is specified, ~c[defun] uses the
  ~c[:]~ilc[well-founded-relation] specified in the ~ilc[acl2-defaults-table].
  ~l[set-well-founded-relation] to see how to set the default well-founded
  relation (and, implicitly, its domain predicate).  The initial default
  well-founded relation is ~ilc[o<] (with domain predicate ~ilc[o-p]).

  This completes the brief sketch of the ACL2 definitional principle.
  Optionally, ~pl[ruler-extenders] for a more detailed discussion of the
  termination analysis and resulting proof obligations for admissibility, as
  well as a discussion of the relation to how ACL2 stores induction schemes.

  On very rare occasions ACL2 will seem to \"hang\" when processing a
  definition, especially if there are many subexpressions of the body whose
  function symbol is ~ilc[if] (or which macroexpand to such an expression).  In
  those cases you may wish to supply the following to ~ilc[xargs]:
  ~c[:normalize nil].  This is an advanced feature that turns off ACL2's usual
  propagation upward of ~c[if] tests.

  The following example illustrates all of the available declarations and most
  hint keywords, but is completely nonsensical.  For documentation, ~pl[xargs]
  and ~pl[hints].
  ~bv[]
  (defun example (x y z a b c i j)
    (declare (ignore a b c)
             (type integer i j)
             (xargs :guard (symbolp x)
                    :measure (- i j)
                    :ruler-extenders :basic
                    :well-founded-relation my-wfr
                    :hints ((\"Goal\"
                             :do-not-induct t
                             :do-not '(generalize fertilize)
                             :expand ((assoc x a) (member y z))
                             :restrict ((<-trans ((x x) (y (foo x)))))
                             :hands-off (length binary-append)
                             :in-theory (set-difference-theories
                                          (current-theory :here)
                                          '(assoc))
                             :induct (and (nth n a) (nth n b))
                             :use ((:instance assoc-of-append
                                              (x a) (y b) (z c))
                                   (:functional-instance
                                     (:instance p-f (x a) (y b))
                                     (p consp)
                                     (f assoc)))))
                    :guard-hints ((\"Subgoal *1/3'\"
                                   :use ((:instance assoc-of-append
                                                    (x a) (y b) (z c)))))
                    :mode :logic
                    :normalize nil
                    :verify-guards nil
                    :non-executable t
                    :otf-flg t))
    (example-body x y z i j))
  ~ev[]~/

  :cited-by Programming"

; Warning: See the Important Boot-Strapping Invariants before modifying!

  (list 'defun-fn
        (list 'quote def)
        'state
        (list 'quote event-form)
        #+:non-standard-analysis ; std-p
        nil))

#+(and acl2-loop-only :non-standard-analysis)
(defmacro defun-std (&whole event-form &rest def)

  ":Doc-Section acl2::Events

  define a function symbol~/~/

  ~l[defun] for details.  (More documentation on features
  related to non-standard analysis may be available in the future.)"

  (list 'defun-fn
        (list 'quote def)
        'state
        (list 'quote event-form)
        t))

#+acl2-loop-only
(defmacro defuns (&whole event-form &rest def-lst)

; Warning: See the Important Boot-Strapping Invariants before modifying!

  ":Doc-Section Miscellaneous

  an alternative to ~ilc[mutual-recursion]~/
  ~bv[]
  Example:
  (DEFUNS
   (evenlp (x)
     (if (consp x) (oddlp (cdr x)) t))
   (oddlp (x)
     (if (consp x) (evenlp (cdr x)) nil)))~/

  General Form:
  (DEFUNS defuns-tuple1 ... defuns-tuplen)
  ~ev[]
  is equivalent to
  ~bv[]
  (MUTUAL-RECURSION
    (DEFUN . defuns-tuple1)
    ...
    (DEFUN . defuns-tuplen))
  ~ev[]
  In fact, ~c[defuns] is the more primitive of the two and
  ~ilc[mutual-recursion] is just a macro that expands to a call of ~ilc[defun]
  after stripping off the ~ilc[defun] at the ~ilc[car] of each argument to
  ~ilc[mutual-recursion].  We provide and use ~ilc[mutual-recursion] rather than
  ~c[defuns] because by leaving the ~ilc[defun]s in place, ~ilc[mutual-recursion]
  forms can be processed by the Emacs ~c[tags] program.
  ~l[mutual-recursion]."

; Warning: See the Important Boot-Strapping Invariants before modifying!

  (list 'defuns-fn
        (list 'quote def-lst)
        'state
        (list 'quote event-form)
        #+:non-standard-analysis ; std-p
        nil))

#+(and acl2-loop-only :non-standard-analysis)
(defmacro defuns-std (&whole event-form &rest def-lst)

  ":Doc-Section Miscellaneous

  an alternative to ~ilc[mutual-recursion]~/~/

  ~l[defuns] for details.  (More documentation on features
  related to non-standard analysis may be available in the future.)"

  (list 'defuns-fn
        (list 'quote def-lst)
        'state
        (list 'quote event-form)
        t))

(defmacro verify-termination (&rest lst)

  ":Doc-Section Events

  convert a function from :program mode to :logic mode~/
  ~bv[]
  Example:
  (verify-termination fact)~/

  General Forms:
  (verify-termination fn dcl ... dcl)
  (verify-termination (fn1 dcl ... dcl)
                      (fn2 dcl ... dcl)
                      ...)
  ~ev[]
  where ~c[fn] and the ~c[fni] are function symbols having ~c[:]~ilc[program] mode
  (~pl[defun-mode]) and all of the ~c[dcl]s are either ~ilc[declare]
  forms or ~il[documentation] strings.  The first form above is an
  abbreviation for
  ~bv[]
  (verify-termination (fn dcl ... dcl))
  ~ev[]
  so we limit our discussion to the second form.  Each of the ~c[fni]
  must be in the same clique of mutually recursively defined
  functions, but not every function in the clique need be among the
  ~c[fni].

  ~c[Verify-termination] attempts to establish the admissibility of the
  ~c[fni]. ~c[Verify-termination] retrieves their definitions, creates modified
  definitions using the ~c[dcl]s supplied above, and resubmits these
  definitions.  You could avoid using ~c[verify-termination] by typing the new
  definitions yourself.  So in that sense, ~c[verify-termination] adds no new
  functionality.  But if you have prototyped your system in ~c[:]~ilc[program]
  mode and tested it, you can use ~c[verify-termination] to resubmit your
  definitions and change their ~il[defun-mode]s to ~c[:]~ilc[logic], addings
  ~il[hints] without having to retype or recopy the code.

  The ~ilc[defun] ~il[command] executed by ~c[verify-termination] is obtained
  by retrieving the ~ilc[defun] (or ~ilc[mutual-recursion]) ~il[command] that
  introduced the clique in question and then possibly modifying each definition
  as follows.  Consider a function, ~c[fn], in the clique.  If ~c[fn] is not
  among the ~c[fni] above, its definition is left unmodified other than to add
  ~c[(declare (xargs :mode :logic))].  Otherwise, ~c[fn] is some ~c[fni] and we
  modify its definition by inserting into it the corresponding ~c[dcl]s listed
  with ~c[fni] in the arguments to ~c[verify-termination], as well as
  ~c[(declare (xargs :mode :logic))].  In addition, we throw out from the old
  declarations in ~c[fn] the ~c[:mode] specification and anything that is
  specified in the new ~c[dcl]s.

  For example, suppose that ~c[fact] was introduced with:
  ~bv[]
  (defun fact (n)
    (declare (type integer n)
             (xargs :mode :program))
    (if (zp n) 1 (* n (fact (1- n))))).
  ~ev[]
  Suppose later we do ~c[(verify-termination fact)].  Then the
  following definition is submitted.
  ~bv[]
  (defun fact (n)
    (declare (type integer n))
    (if (zp n) 1 (* n (fact (1- n))))).
  ~ev[]
  Observe that this is the same definition as the original one, except
  the old specification of the ~c[:mode] has been deleted so that the
  ~il[defun-mode] now defaults to ~c[:]~ilc[logic].  Although the termination
  proof succeeds, ACL2 also tries to verify the ~il[guard], because we have
  (implicitly) provided a ~il[guard], namely ~c[(integerp n)], for this
  function.  (~l[guard] for a general discussion of guards, and
  ~pl[type-spec] for a discussion of how type declarations are
  used in guards.)  Unfortunately, the ~il[guard] verification fails,
  because the subterm ~c[(zp n)] requires that ~c[n] be nonnegative, as
  can be seen by invoking ~c[:args zp].  (For a discussion of termination
  issues relating to recursion on the naturals, ~pl[zero-test-idioms].)
  So we might be tempted to submit the following:
  ~bv[]
  (verify-termination
   fact
   (declare (xargs :guard (and (integerp n) (<= 0 n))))).
  ~ev[]
  However, this is considered a changing of the guard (from ~c[(integerp n)]),
  which is illegal.  If we instead change the guard in the earlier ~c[defun]
  after undoing that earlier definition with ~c[:]~ilc[ubt]~c[ fact], then
  ~c[(verify-termination fact)] will succeed.

  ~st[Remark on system functions.]  There may be times when you want to apply
  ~c[verify-termination] (and also, perhaps, ~ilc[verify-guards]) to functions
  that are predefined in ACL2.  It may be necessary in such cases to modify the
  system code first.  See Part II of
  ~url[http://www.cs.utexas.edu/users/moore/acl2/open-architecture/] for a
  discussion of the process for contributing updates to the system code and
  ~il[books] with such ~c[verify-termination] or ~ilc[verify-guards]
  ~il[events], perhaps resulting in more system functions being built-in as
  ~il[guard]-verified.  To see which built-in functions have already received
  such treatment, see community books directory ~c[books/system/]; or, evaluate
  the constant ~c[*system-verify-guards-alist*], each of whose entries
  associates the name of a community book with a list of functions whose
  guard-verification is proved by including that book.  See the above URL for
  more details.

  Note that if ~c[fn1] is already in ~c[:]~ilc[logic] mode, then the
  ~c[verify-termination] call has no effect.  It is generally considered to be
  redundant, in the sense that it returns without error; but if the ~c[fn1] is
  a constrained function (i.e., introduced in the signature of an
  ~ilc[encapsulate], or by ~ilc[defchoose]), then an error occurs.  This error
  is intended to highlight unintended uses of ~c[verify-termination]; but if
  you do not want to see an error in this case, you can write and use your own
  macro in place of ~c[verify-termination].  The following explanation of the
  implementation of ~c[verify-termination] may help with such a task.

  We conclude with a discussion of the use of ~ilc[make-event] to implement
  ~c[verify-termination].  This discussion can be skipped; we include it only
  for those who want to create variants of ~c[verify-termination], or who are
  interested in seeing an application of ~ilc[make-event].

  Consider the following proof of ~c[nil], which succeeded up through
  Version_3.4 of ACL2.
  ~bv[]
  (encapsulate
   ()
   (defun foo (x y)
     (declare (xargs :mode :program))
     (if (or (zp x) (zp y))
         (list x y)
       (foo (1+ x) (1- y))))
   (local (defun foo (x y)
            (declare (xargs :measure (acl2-count y)))
            (if (or (zp x) (zp y))
                (list x y)
              (foo (1+ x) (1- y)))))
   (verify-termination foo))

  (defthm bad-lemma
    (zp x)
    :hints ((\"Goal\" :induct (foo x 1)))
    :rule-classes nil)
  ~ev[]
  How did this work?  In the first pass of the ~ilc[encapsulate], the second
  ~ilc[defun] of ~c[foo] promoted ~c[foo] from ~c[:program] to ~c[:logic] mode,
  with ~c[y] as the unique measured variable.  The following call to
  ~c[verify-termination] was then redundant.  However, on the second pass of
  the ~ilc[encapsulate], the second (~ilc[local]) definition of ~c[foo] was
  skipped, and the ~c[verify-termination] event then used the first definition
  of ~c[foo] to guess the measure, based (as with all guesses of measures) on a
  purely syntactic criterion.  ACL2 incorrectly chose ~c[(acl2-count x)] as the
  measure, installing ~c[x] as the unique measured variable, which in turn led
  to an unsound induction scheme subsequently used to prove ~c[nil] (lemma
  ~c[bad-lemma], above)

  Now, ~c[verify-termination] is a macro whose calls expand to ~ilc[make-event]
  calls.  So in the first pass above, the ~c[verify-termination] call generated
  a ~c[defun] event identical to the ~ilc[local] ~ilc[defun] of ~c[foo], which
  was correctly identified as redundant.  That expansion was recorded, and on
  the second pass of the ~ilc[encapsulate], the expansion was recalled and used
  in place of the ~c[verify-termination] call (that is how ~ilc[make-event]
  works).  So instead of a measure being guessed for the ~c[verify-termination]
  call on the second pass, the same measure was used as was used on the first
  pass, and a sound induction scheme was stored.  The attempt to prove ~c[nil]
  (lemma ~c[bad-lemma]) then failed."

  `(make-event
    (verify-termination-fn ',lst state)))

#+acl2-loop-only
(defmacro verify-termination-boot-strap (&whole event-form &rest lst)

; Warning: See the Important Boot-Strapping Invariants before modifying!

  (list 'verify-termination-boot-strap-fn
        (list 'quote lst)
        'state
        (list 'quote event-form)))

#+acl2-loop-only
(defmacro verify-guards (&whole event-form name &key hints otf-flg guard-debug
                                doc)

; Warning: See the Important Boot-Strapping Invariants before modifying!

; Note: If you change the default for guard-debug, then consider changing it in
; chk-acceptable-defuns as well, and fix the "Otherwise" message about
; :guard-debug in prove-guard-clauses.

  ":Doc-Section Events

  verify the ~il[guard]s of a function~/

  ~l[guard] for a general discussion of guards.

  Before discussing the ~c[verify-guards] event, we first discuss guard
  verification, which can take place at definition time or, later, using
  ~c[verify-guards].  Typically, guard verification takes place at definition
  time if a guard (or type, or ~il[stobjs]) has been supplied explicitly unless
  ~c[:verify-guards nil] has been specified; ~pl[defun] and ~pl[xargs], and
  ~pl[set-verify-guards-eagerness] for how to change this default.  The point
  of guard verification is to ensure that during evaluation of an expression
  without free variables, no guard violation takes place.

  Technical note: the first argument of ~c[verify-guards] must be a function
  symbol or the name of a ~ilc[defthm] or ~ilc[defaxiom] event, not a
  macro-alias for a function symbol (~pl[macro-aliases-table]).
  ~l[verify-guards+] for a utility that does not have this restriction.

  Guard verification is intended to guarantee that for any call of a given
  function, if its ~il[guard] holds for that call then the ~il[guard] will hold
  for every function call in the body of that function.  Moreover, in order to
  avoid guard violations during evaluation of the function's guard itself,
  guard verification also is intended to guarantee that the guards are
  satisfied for all calls in the guard itself.  Consider the following simple
  example.
  ~bv[]
  (defun f (x)
    (declare (xargs :guard (and (consp x)
                                (integerp (car x)))))
    (if (rationalp (cdr x))
        (+ (car x) (cdr x))
      17))
  ~ev[]
  If you evaluate ~c[(f t)], for example, in the top-level loop, you will (by
  default) get a guard error.  The point of guard verification is to guarantee
  the absence of guard errors, and we start by using this example to illustrate
  the proof obligations that guarantee such absence.

  The body of the above definition has the following function calls, where the
  first is the entire body.
  ~bv[]
    (if (rationalp (cdr x))
        (< (car x) (cdr x))
      17)
    (rationalp (cdr x)) ; the test of the top-level IF call
    (cdr x)             ; from (rationalp (cdr x))
    (< (car x) (cdr x)) ; the true branch of the top-level IF call
    (car x)             ; from (< (car x) (cdr x))
    (cdr x)             ; from (< (car x) (cdr x))
  ~ev[]
  We thus see potentially six conditions to prove, one for each call.  The
  guards of the function symbols of those calls are ~c[t] for ~ilc[if] and
  ~ilc[rationalp], ~c[(or (consp x) (equal x nil))] for both ~c[(car x)] and
  ~c[(cdr x)], and finally that both arguments are rationals for ~c[<].
  Moreover, we can take advantage of ``contextual assumptions'': the
  ~c[if]-test conditions and the top-level ~c[:guard].  Thus, for
  ~c[verify-guards] the proof obligation from the body of ~c[f] is as follows.
  ~bv[]
  (implies
   (and (consp x) (integerp (car x))) ; from the :guard
   (and t ; from the top-level IF call
        t ; from (rationalp (cdr x))
        (or (consp x) (equal x nil)) ; from the first (cdr x)
        (implies
         (rationalp (cdr x)) ; IF-test for calls in the true branch
         (and (or (consp x) (equal x nil)) ; from (car x)
              (or (consp x) (equal x nil)) ; from the second (cdr x)
              (and (rationalp (car x)) (rationalp (cdr x))) ; from the < call
              ))))
  ~ev[]
  But the ~c[:guard] itself generates a similar sort of proof obligation.  Note
  that the guard ~c[(and (consp x) (integerp (car x)))] is really an
  abbreviation (i.e. via the macro ~ilc[AND]) for the term
  ~c[(if (consp x) (integerp (car x)) nil)].  The guard proof obligation for
  the guard itself is thus as follows.
  ~bv[]
  (and t ; from (consp x)
       (implies (consp x)
                (and t         ; from (integerp (car x)) ;
                     (consp x) ; from (car x) ;
                     )))
  ~ev[]
  All of the above proof obligations are indeed theorems, and guard
  verification succeeds for the above definition of ~c[f].

  The example above illustrates the general procedure for generating the guard
  proof obligation.  Each function call is considered in the body or guard of
  the function, and it is required that the guard is met for that call, under
  certain ``contextual assumptions'', which are as follows.  In the case of the
  body of the named function, it is assumed that the guard holds for that
  function on its formal parameters.  And in both cases ~-[] the body of the
  named function and also its guard ~-[] the governing tests from superior
  calls of ~ilc[IF] are also assumed.

  As mentioned above, if the guard on a function is not ~c[t], then guard
  verification requires not only consideration of the body under the assumption
  that the guard is true, but also consideration of the guard itself.  Thus,
  for example, guard verification fails in the following example, even though
  there are no proof obligations arising from the body, because the guard
  itself can cause a guard violation when evaluated for an arbitrary value of
  ~c[x]:
  ~bv[]
  (defun foo (x)
    (declare (xargs :guard (car x)))
    x)
  ~ev[]

  We turn now to the ~c[verify-guards] event as a way of verifying the
  ~il[guard]s for a function or theorem.
  ~bv[]
  Examples:
  (verify-guards flatten)
  (verify-guards flatten
                 :hints ((\"Goal\" :use (:instance assoc-of-app)))
                 :otf-flg t
                 :guard-debug t ; default = nil
                 :doc \"string\")~/

  General Form:
  (verify-guards name
          :hints        hints
          :otf-flg      otf-flg
          :guard-debug  t ; typically t, but any value is legal
          :doc          doc-string)
  ~ev[]
  In the General Form above, ~c[name] is the name of a ~c[:]~ilc[logic]
  function (~pl[defun-mode]) or of a theorem or axiom.  In the most common case
  ~c[name] is the name of a function that has not yet had its ~il[guard]s
  verified, each subroutine of which has had its ~il[guard]s verified.  The
  values ~ilc[hints], ~ilc[otf-flg], and ~ilc[guard-debug] are as described in
  the corresponding ~il[documentation] entries; and ~ilc[doc-string], if
  supplied, is a string ~st[not] beginning with ``~c[:Doc-Section]''.  The four
  keyword arguments above are all optional.  To admit this event, the
  conjunction of the guard proof obligations must be proved.  If that proof is
  successful, ~c[name] is considered to have had its ~il[guard]s verified.

  ~l[verify-guards-formula] for a utility that lets you view the formula to be
  proved by ~c[verify-guards], but without creating an event.

  If ~c[name] is one of several functions in a mutually recursive clique,
  ~c[verify-guards] will attempt to verify the ~il[guard]s of all of the
  functions.

  If ~c[name] is a theorem or axiom name, ~c[verify-guards] verifies the
  guards of the associated formula.  When a theorem has had its guards
  verified then you know that the theorem will evaluate to non-~c[nil]
  in all Common Lisps, without causing a runtime error (other than possibly
  a resource error).  In particular, you know that the theorem's validity
  does not depend upon ACL2's arbitrary completion of the domains of partial
  Common Lisp functions.

  For example, if ~c[app] is defined as
  ~bv[]
  (defun app (x y)
    (declare (xargs :guard (true-listp x)))
    (if (endp x)
        y
        (cons (car x) (app (cdr x) y))))
  ~ev[]
  then we can verify the guards of ~c[app] and we can prove the theorem:
  ~bv[]
  (defthm assoc-of-app
    (equal (app (app a b) c) (app a (app b c))))
  ~ev[]
  However, if you go into almost any Common Lisp in which ~c[app] is defined
  as shown and evaluate
  ~bv[]
  (equal (app (app 1 2) 3) (app 1 (app 2 3)))
  ~ev[]
  we get an error or, perhaps, something worse like ~c[nil]!  How can
  this happen since the formula is an instance of a theorem?  It is supposed
  to be true!

  It happens because the theorem exploits the fact that ACL2 has completed
  the domains of the partially defined Common Lisp functions like ~ilc[car]
  and ~ilc[cdr], defining them to be ~c[nil] on all non-conses.  The formula
  above violates the guards on ~c[app].  It is therefore ``unreasonable''
  to expect it to be valid in Common Lisp.

  But the following formula is valid in Common Lisp:
  ~bv[]
  (if (and (true-listp a)
           (true-listp b))
      (equal (app (app a b) c) (app a (app b c)))
      t)
  ~ev[]
  That is, no matter what the values of ~c[a], ~c[b] and ~c[c] the formula
  above evaluates to ~c[t] in all Common Lisps (unless the Lisp engine runs out
  of memory or stack computing it).  Furthermore the above formula is a theorem:

  ~bv[]
  (defthm guarded-assoc-of-app
    (if (and (true-listp a)
             (true-listp b))
        (equal (app (app a b) c) (app a (app b c)))
        t))
  ~ev[]
  This formula, ~c[guarded-assoc-of-app], is very easy to prove from
  ~c[assoc-of-app].  So why prove it?  The interesting thing about
  ~c[guarded-assoc-of-app] is that we can verify the guards of the
  formula.  That is, ~c[(verify-guards guarded-assoc-of-app)] succeeds.
  Note that it has to prove that if ~c[a] and ~c[b] are true lists then
  so is ~c[(app a b)] to establish that the guard on the outermost ~c[app]
  on the left is satisfied.  By verifying the guards of the theorem we
  know it will evaluate to true in all Common Lisps.  Put another way,
  we know that the validity of the formula does not depend on ACL2's
  completion of the partial functions or that the formula is ``well-typed.''

  One last complication:  The careful reader might have thought we could
  state ~c[guarded-assoc-of-app] as
  ~bv[]
  (implies (and (true-listp a)
                (true-listp b))
           (equal (app (app a b) c)
                  (app a (app b c))))
  ~ev[]
  rather than using the ~c[if] form of the theorem.  We cannot!  The
  reason is technical:  ~ilc[implies] is defined as a function in ACL2.
  When it is called, both arguments are evaluated and then the obvious truth
  table is checked.  That is, ~c[implies] is not ``lazy.''  Hence, when
  we write the guarded theorem in the ~c[implies] form we have to prove
  the guards on the conclusion without knowing that the hypothesis is true.
  It would have been better had we defined ~c[implies] as a macro that
  expanded to the ~c[if] form, making it lazy.  But we did not and after
  we introduced guards we did not want to make such a basic change.

  Recall however that ~c[verify-guards] is almost always used to verify
  the guards on a function definition rather than a theorem.  We now
  return to that discussion.

  Because ~c[name] is not uniquely associated with the ~c[verify-guards] event
  (it necessarily names a previously defined function) the
  ~il[documentation] string, ~ilc[doc-string], is not stored in the
  ~il[documentation] database.  Thus, we actually prohibit ~ilc[doc-string]
  from having the form of an ACL2 ~il[documentation] string;
  ~pl[doc-string].

  ~c[Verify-guards] must often be used when the value of a recursive call
  of a defined function is given as an argument to a subroutine that
  is ~il[guard]ed.  An example of such a situation is given below.  Suppose
  ~c[app] (read ``append'') has a ~il[guard] requiring its first argument to be
  a ~ilc[true-listp].  Consider
  ~bv[]
  (defun rev (x)
    (declare (xargs :guard (true-listp x)))
    (cond ((endp x) nil)
          (t (app (rev (cdr x)) (list (car x))))))
  ~ev[]
  Observe that the value of a recursive call of ~c[rev] is being passed
  into a ~il[guard]ed subroutine, ~c[app].  In order to verify the ~il[guard]s of
  this definition we must show that ~c[(rev (cdr x))] produces a
  ~ilc[true-listp], since that is what the ~il[guard] of ~c[app] requires.  How do we
  know that ~c[(rev (cdr x))] is a ~ilc[true-listp]?  The most elegant argument
  is a two-step one, appealing to the following two lemmas: (1) When ~c[x]
  is a ~ilc[true-listp], ~c[(cdr x)] is a ~ilc[true-listp].  (2) When ~c[z] is a
  ~ilc[true-listp], ~c[(rev z)] is a ~ilc[true-listp].  But the second lemma is a
  generalized property of ~c[rev], the function we are defining.  This
  property could not be stated before ~c[rev] is defined and so is not
  known to the theorem prover when ~c[rev] is defined.

  Therefore, we might break the admission of ~c[rev] into three steps:
  define ~c[rev] without addressing its ~il[guard] verification, prove some
  general properties about ~c[rev], and then verify the ~il[guard]s.  This can
  be done as follows:
  ~bv[]
  (defun rev (x)
    (declare (xargs :guard (true-listp x)
                    :verify-guards nil))    ; Note this additional xarg.
    (cond ((endp x) nil)
          (t (app (rev (cdr x)) (list (car x))))))

  (defthm true-listp-rev
    (implies (true-listp x2)
             (true-listp (rev x2))))

  (verify-guards rev)
  ~ev[]
  The ACL2 system can actually admit the original definition of
  ~c[rev], verifying the ~il[guard]s as part of the ~ilc[defun] event.  The
  reason is that, in this particular case, the system's heuristics
  just happen to hit upon the lemma ~c[true-listp-rev].  But in many
  more complicated functions it is necessary for the user to formulate
  the inductively provable properties before ~il[guard] verification is
  attempted.

  ~st[Remark on computation of guard conjectures and evaluation].  When ACL2
  computes the ~il[guard] conjecture for the body of a function, it
  evaluates any ground subexpressions (those with no free variables), for
  calls of functions whose ~c[:]~ilc[executable-counterpart] ~il[rune]s are
  ~ilc[enable]d.  Note that here, ``enabled'' refers to the current global
  ~il[theory], not to any ~c[:]~ilc[hints] given to the guard verification
  process; after all, the guard conjecture is computed even before its initial
  goal is produced.  Also note that this evaluation is done in an environment
  as though ~c[:set-guard-checking :all] had been executed, so that we can
  trust that this evaluation takes place without guard violations;
  ~pl[set-guard-checking].

  If you want to verify the ~il[guard]s on functions that are built into ACL2,
  you will first need to put them into ~c[:]~ilc[logic] mode.
  ~l[verify-termination], specifically the ``Remark on system functions'' in
  that ~il[documentation]."

; Warning: See the Important Boot-Strapping Invariants before modifying!

 (list 'verify-guards-fn
       (list 'quote name)
       'state
       (list 'quote hints)
       (list 'quote otf-flg)
       (list 'quote guard-debug)
       (list 'quote doc)
       (list 'quote event-form)))

(defmacro verify-guards+ (name &rest rest)

; We considered renaming verify-guards as verify-guards-basic, and then
; defining verify-guards on top of verify-guards-basic just as we now define
; verify-guards+ on top of verify-guards.  But that could be complicated to
; carry out during the boot-strap, and it could be challenging to present a
; nice view to the user, simulataneously promoting the fiction that
; verify-guards is a primitive while giving accurate feedback.  So we are
; leaving verify-guards as the primitive, but improving it to point to
; verify-guards+ when there is a macro alias.

; The example in the documentation below doesn't immediately yield a proof of
; nil, but perhaps mbe could be used for that (we haven't tried).  At any rate,
; violation of the intent of guard verification is bad enough.

  ":Doc-Section Events

  verify the ~il[guard]s of a function~/

  We assume familiarity with ~il[guard] verification; ~pl[verify-guards].
  Unlike ~c[verify-guards], the macro call ~c[(verify-guards+ mac ...)] will
  verify guards for a function, ~c[fn], such that the macro ~c[mac] is
  associated with the function symbol ~c[fn] in ~ilc[macro-aliases-table]
  (also ~pl[add-macro-alias]).  For example, if you define a macro ~c[app] and
  list append function ~c[binary-app], and you associate macro ~c[app] with
  function symbol ~c[binary-app] in ~ilc[macro-aliases-table], then evaluation
  of the form ~c[(verify-guard+ app)] will have the effect of evaluating
  ~c[(verify-guards fn)].  Note that in this setting, evaluation of
  ~c[(verify-guard app)] would cause an error, because ~c[app] is a macro and
  ~c[verify-guards], unlike ~c[verify-guards+], cannot handle macros.~/

  The rest of this ~il[documentation] topic discusses why we do not simply
  arrange that ~c[verify-guards] be permitted to take a macro alias.  The
  following example shows a soundness issue in doing so.
  ~bv[]
  (encapsulate
   ()
   (defun f1 (x)
     (declare (xargs :guard (consp x)
                     :verify-guards nil))
     (car x))
   (defun f2 (x)
     (declare (xargs :guard t
                     :verify-guards nil))
     (cdr x))
   (defmacro mac (x)
     x)
   (add-macro-alias mac f2) ; silly macro alias ;
   (local (add-macro-alias mac f1)) ; alternate silly macro alias ;
   (verify-guards mac))
  ~ev[]

  If we were to allow macro aliases in ~ilc[verify-guards], this event would be
  admitted, because on the first pass we are verifying guards of ~c[f1].  But
  after the ~ilc[encapsulate] form completes evaluation, it would appear that
  ~c[f2] is guard-verified.  That could of course cause a raw Lisp error.

  The enhanced functionality provided by ~c[verify-guards+] does not have the
  above problem, because it takes advantage of ~ilc[make-event] to avoid taking
  advantage of the contradictory results produced by the two calls of
  ~c[add-macro-alias].  ~l[make-event].  If the specific example above is
  modified by replacing ~c[verify-guards] with ~c[verify-guards+], then the
  first pass through the ~ilc[encapsulate] form will expand the form
  ~c[(verify-guards+ mac)] to ~c[(verify-guards f1)].  That same expansion will
  be used for the ~c[verify-guards+] call during the second pass through the
  ~c[encapsulate] form, which is evaluated successfully and leaves us in a
  ~il[world] where ~c[f1] is guard-verified and ~c[f2] is not.~/"

  `(make-event
    (let* ((name ',name)
           (rest ',rest)
           (fn (deref-macro-name name (macro-aliases (w state)))))
      (pprogn (observation 'verify-guards+
                           "Attempting to verify guards for ~x0."
                           fn)
              (value (list* 'verify-guards fn rest))))
    :expansion? (verify-guards ,name ,@rest)))

(defdoc defpun

  ":Doc-Section acl2::Events

  define a tail-recursive function symbol~/~/

  ~c[Defpun] is a macro developed by Pete Manolios and J Moore that allows
  tail-recursive definitions.  It is defined in community book
  ~c[books/misc/defpun.lisp], so to use it, execute the following event.
  ~bv[]
  (include-book \"misc/defpun\" :dir :system)
  ~ev[]
  Details of defpun are provided by Manolios and Moore in the ``Partial
  Functions in ACL2'' published with the ACL2 2000 workshop; see
  ~url[http://www.cs.utexas.edu/users/moore/acl2/workshop-2000/].  Also see
  ~url[http://www.cs.utexas.edu/users/moore/publications/defpun/index.html].

  A variant, ~c[defp], has been developed by Matt Kaufmann to allow more
  general forms of tail recursion.  If ~c[defpun] doesn't work for you, try
  ~c[defp] by first executing the following event.
  ~bv[]
  (include-book \"misc/defp\" :dir :system)
  ~ev[]

  Sandip Ray has contributed a variant of ~c[defpun], ~c[defpun-exec], that
  supports executability.  See community book
  ~c[books/defexec/defpun-exec/defpun-exec.lisp]:
  ~bv[]
  (include-book \"defexec/defpun-exec/defpun-exec\" :dir :system)
  ~ev[]
  He has also contributed community book
  ~c[books/misc/misc2/defpun-exec-domain-example.lisp], for functions that are
  uniquely defined in a particular domain.")

#+acl2-loop-only
(defmacro defmacro (&whole event-form &rest mdef)

; Warning: See the Important Boot-Strapping Invariants before modifying!

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

  ":Doc-Section acl2::Events

  define a macro~/
  ~bv[]
  Example Defmacros:
  (defmacro xor (x y)
    (list 'if x (list 'not y) y))

  (defmacro git (sym key)
    (list 'getprop sym key nil
          '(quote current-acl2-world)
          '(w state)))

  (defmacro one-of (x &rest rst)
    (declare (xargs :guard (symbol-listp rst)))
    (cond ((null rst) nil)
          (t (list 'or
                   (list 'eq x (list 'quote (car rst)))
                   (list* 'one-of x (cdr rst))))))

  Example Expansions:
  term                    macroexpansion

  (xor a b)              (if a (not b) b)
  (xor a (foo b))        (if a (not (foo b)) (foo b))

  (git 'car 'lemmas)     (getprop 'car 'lemmas nil
                                  'current-acl2-world
                                  (w state))

  (one-of x a b c)       (or (eq x 'a)
                             (or (eq x 'b)
                                 (or (eq x 'c) nil)))

  (one-of x 1 2 3)       ill-formed (guard violation)~/

  General Form:
  (defmacro name macro-args doc-string dcl ... dcl body)
  ~ev[]
  where ~c[name] is a new symbolic name (~pl[name]), ~c[macro-args] specifies
  the formal parameters of the macro, and ~c[body] is a term.  The formal
  parameters can be specified in a much more general way than is allowed by
  ACL2 ~ilc[defun] ~il[events]; ~pl[macro-args] for a description of keyword
  (~c[&key]) and optional (~c[&optional]) parameters as well as other so-called
  ``lambda-list keywords'', ~c[&rest] and ~c[&whole].  ~ilc[Doc-string] is an
  optional ~il[documentation] string; ~pl[doc-string].  Each ~c[dcl] is an
  optional declaration (~pl[declare]) except that the only ~ilc[xargs] keyword
  permitted by ~c[defmacro] is ~c[:]~ilc[guard].

  For compute-intensive applications see the community book
  ~c[misc/defmac.lisp], which can speed up macroexpansion by introducing an
  auxiliary ~c[defun].  For more information, evaluate the form
  ~c[(include-book \"misc/defmac\" :dir :system)] and then evaluate
  ~c[:doc defmac].

  Macroexpansion occurs when a form is read in, i.e., before the
  evaluation or proof of that form is undertaken.  To experiment with
  macroexpansion, ~pl[trans].  When a form whose ~ilc[car] is ~c[name]
  arises as the form is read in, the arguments are bound as described
  in CLTL pp. 60 and 145, the ~il[guard] is checked, and then the ~c[body] is
  evaluated.  The result is used in place of the original form.

  In ACL2, macros do not have access to the ACL2 state ~ilc[state].  (If
  ~ilc[state] or any user-defined stobj (~pl[stobj]) is a macro argument, it is
  treated as an ordinary variable, bound at macro-expansion time to a piece of
  syntax.)  This is in part a reflection of CLTL, p. 143, ``More generally, an
  implementation of Common Lisp has great latitude in deciding exactly when to
  expand macro calls with a program. ...  Macros should be written in such a
  way as to depend as little as possible on the execution environment to
  produce a correct expansion.''  In ACL2, the product of macroexpansion is
  independent of the current environment and is determined entirely by the
  macro body and the functions and constants it references.  It is possible,
  however, to define macros that produce expansions that refer to ~ilc[state]
  or other single-threaded objects (~pl[stobj]) or variables not among the
  macro's arguments.  See the ~c[git] example above.  For a related utility
  that does have access to the ACL2 ~il[state], ~pl[make-event].~/"

; Warning: See the Important Boot-Strapping Invariants before modifying!

  (list 'defmacro-fn
        (list 'quote mdef)
        'state
        (list 'quote event-form)))

#+acl2-loop-only
(defmacro defconst (&whole event-form name form &optional doc)

; Warning: See the Important Boot-Strapping Invariants before modifying!

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

  ":Doc-Section acl2::Events

  define a constant~/
  ~bv[]
  Examples:
  (defconst *digits* '(0 1 2 3 4 5 6 7 8 9))
  (defconst *n-digits* (the unsigned-byte (length *digits*)))~/

  General Form:
  (defconst name term doc-string)
  ~ev[]
  where ~c[name] is a symbol beginning and ending with the character ~c[*],
  ~c[term] is a variable-free term that is evaluated to determine the
  value of the constant, and ~ilc[doc-string] is an optional ~il[documentation]
  string (~pl[doc-string]).

  When a constant symbol is used as a ~il[term], ACL2 replaces it by
  its value; ~pl[term].

  Note that ~c[defconst] uses a ``safe mode'' to evaluate its form, in order
  to avoids soundness issues but with an efficiency penalty (perhaps increasing
  the evaluation time by several hundred percent).  If efficiency is a concern,
  or if for some reason you need the form to be evaluated without safe mode
  (e.g., you are an advanced system hacker using trust tags to traffic in raw
  Lisp code), consider using the macro ~c[defconst-fast] instead, defined in
  community book ~c[books/make-event/defconst-fast.lisp], for example:
  ~bv[]
  (defconst-fast *x* (expensive-fn ...))
  ~ev[]
  A more general utility may be found in community book
  ~c[books/tools/defconsts.lisp].  Also ~pl[using-tables-efficiently] for an
  analogous issue with ~ilc[table] events.

  It may be of interest to note that ~c[defconst] is implemented at the
  lisp level using ~c[defparameter], as opposed to ~c[defconstant].
  (Implementation note:  this is important for proper support of
  undoing and redefinition.)

  We close with a technical remark, perhaps of interest only to users of
  ACL2(h), the experimental extension of ACL2 that supports hash cons, function
  memoization, and hash-table-based ``fast alists''; ~pl[hons-and-memoization].
  For an event of the form ~c[(defconst *C* (quote OBJ))], i.e.,
  ~c[(defconst *C* 'OBJ)], then the value associated with ~c[*C*] is ~c[OBJ];
  that is, the value of ~c[*C*] is ~ilc[eq] to the actual object ~c[OBJ]
  occurring in the ~c[defconst] form.  So for example, if ~ilc[make-event] is
  used to generate such a ~c[defconst] event, as it is in the two books
  mentioned above, and ~c[OBJ] is a fast alist (using ACL2(h)), then the value
  of ~c[*C*] is a fast alist.  This guarantee disappears if the term in the
  ~c[defconst] form is not a quoted object, i.e., if it is not of the form
  ~c[(quote OBJ)].~/

  :cited-by Programming"

; Warning: See the Important Boot-Strapping Invariants before modifying!

  (list 'defconst-fn
        (list 'quote name)
        (list 'quote form)
        'state
        (list 'quote doc)
        (list 'quote event-form)))

#+acl2-loop-only
(defmacro defthm (&whole event-form
                  name term
                       &key (rule-classes '(:REWRITE))
                       instructions
                       hints
                       otf-flg
                       doc)

; Warning: See the Important Boot-Strapping Invariants before modifying!

  ":Doc-Section Events

  prove and name a theorem~/
  ~bv[]
  Examples:
  (defthm assoc-of-app
          (equal (app (app a b) c)
                 (app a (app b c))))
  ~ev[]
  The following nonsensical example illustrates all the optional
  arguments but is illegal because not all combinations are permitted.
  ~l[hints] for a complete list of ~il[hints].
  ~bv[]
  (defthm main
          (implies (hyps x y z) (concl x y z))
         :rule-classes (:REWRITE :GENERALIZE)
         :instructions (induct prove promote (dive 1) x
                               (dive 2) = top (drop 2) prove)
         :hints ((\"Goal\"
                  :do-not '(generalize fertilize)
                  :in-theory (set-difference-theories
                               (current-theory :here)
                               '(assoc))
                  :induct (and (nth n a) (nth n b))
                  :use ((:instance assoc-of-append
                                   (x a) (y b) (z c))
                        (:functional-instance
                          (:instance p-f (x a) (y b))
                          (p consp)
                          (f assoc)))))
         :otf-flg t
         :doc \"#0[one-liner/example/details]\")~/

  General Form:
  (defthm name term
          :rule-classes rule-classes
          :instructions instructions
          :hints        hints
          :otf-flg      otf-flg
          :doc          doc-string)
  ~ev[]
  where ~c[name] is a new symbolic name (~pl[name]), ~c[term] is a
  term alleged to be a theorem, and ~ilc[rule-classes], ~ilc[instructions],
  ~ilc[hints], ~ilc[otf-flg] and ~ilc[doc-string] are as described in their
  respective ~il[documentation].  The five keyword arguments above are
  all optional, however you may not supply both ~c[:]~ilc[instructions]
  and ~c[:]~ilc[hints], since one drives the proof checker and the other
  drives the theorem prover.  If ~c[:]~ilc[rule-classes] is not specified,
  the list ~c[(:rewrite)] is used; if you wish the theorem to generate
  no rules, specify ~c[:]~ilc[rule-classes] ~c[nil].

  When ACL2 processes a ~c[defthm] event, it first tries to prove the
  ~il[term] using the indicated hints (~pl[hints]) or ~il[instructions]
  (~pl[proof-checker]).  If it is successful, it stores the rules
  described by the rule-classes (~pl[rule-classes]), proving the
  necessary corollaries.~/"

  (list 'defthm-fn
        (list 'quote name)
        (list 'quote term)
        'state
        (list 'quote rule-classes)
        (list 'quote instructions)
        (list 'quote hints)
        (list 'quote otf-flg)
        (list 'quote doc)
        (list 'quote event-form)
        #+:non-standard-analysis ; std-p
        nil))

#+acl2-loop-only
(defmacro defthmd (&whole event-form
                          name term
                          &rest rst)

  ":Doc-Section acl2::Events

  prove and name a theorem and then disable it~/~/

  Use ~c[defthmd] instead of ~ilc[defthm] when you want to disable a theorem
  immediately after proving it.  This macro has been provided for users who
  prefer working in a mode where theorems are only enabled when explicitly
  directed by ~c[:]~ilc[in-theory].  Specifically, the form
  ~bv[]
  (defthmd NAME TERM ...)
  ~ev[]
  expands to:
  ~bv[]
  (progn
    (defthmd NAME TERM ...)
    (with-output
     :off summary
     (in-theory (disable NAME)))
    (value-triple '(:defthmd NAME))).
  ~ev[]

  Note that ~c[defthmd] commands are never redundant (~pl[redundant-events]).
  Even if the ~c[defthm] event is redundant, then the ~ilc[in-theory] event
  will still be executed.

  The summary for the ~ilc[in-theory] event is suppressed.  ~l[defthm] for
  documentation of ~c[defthm]."

  (declare (xargs :guard t) (ignore term rst))

  (list 'progn
        (cons 'defthm (cdr event-form))
        (list
         'with-output
         :off 'summary
         (list 'in-theory
               (list 'disable name)))
        (list 'value-triple
              (list 'quote (xd-name 'defthmd name))
              :on-skip-proofs t)))

#+(and acl2-loop-only :non-standard-analysis)
(defmacro defthm-std (&whole event-form
                      name term
                       &key (rule-classes '(:REWRITE))
                       instructions
                       hints
                       otf-flg
                       doc)

  ":Doc-Section Events

  prove and name a theorem~/~/

  ~l[defthm] for details.  (More documentation on features
  related to non-standard analysis may be available in the future.)"

  (list 'defthm-fn
        (list 'quote name)
        (list 'quote term)
        'state
        (list 'quote rule-classes)
        (list 'quote instructions)
        (list 'quote hints)
        (list 'quote otf-flg)
        (list 'quote doc)
        (list 'quote event-form)
        t))

#+acl2-loop-only
(defmacro defaxiom (&whole event-form name term
                    &key (rule-classes '(:REWRITE))
                         doc)

; Warning: See the Important Boot-Strapping Invariants before modifying!

  ":Doc-Section Events

  add an axiom~/

  WARNING: We strongly recommend that you not add axioms.  If at all
  possible you should use ~ilc[defun] or ~ilc[mutual-recursion] to define new
  concepts recursively or use ~ilc[encapsulate] to constrain them
  constructively.  If your goal is to defer a proof by using a
  top-down style, consider using ~ilc[skip-proofs]; see the discussion
  on ``Top-Down Proof'' in Section B.1.2 of ``Computer-Aided
  Reasoning: An Approach.''  Adding new axioms frequently renders the
  logic inconsistent.
  ~bv[]
  Example:
  (defaxiom sbar (equal t nil)
            :rule-classes nil
            :doc \":Doc-Section ...\")~/

  General Form:
  (defaxiom name term
           :rule-classes rule-classes
           :doc          doc-string)
  ~ev[]
  where ~c[name] is a new symbolic name (~pl[name]), ~c[term] is a term
  intended to be a new axiom, and ~ilc[rule-classes] and ~ilc[doc-string] are as
  described in the corresponding ~il[documentation] topics .  The two keyword
  arguments are optional.  If ~c[:]~ilc[rule-classes] is not supplied, the list
  ~c[(:rewrite)] is used; if you wish the axiom to generate no rules,
  specify ~c[:]~ilc[rule-classes] ~c[nil].~/"

; Warning: See the Important Boot-Strapping Invariants before modifying!

  (list 'defaxiom-fn
        (list 'quote name)
        (list 'quote term)
        'state
        (list 'quote rule-classes)
        (list 'quote doc)
        (list 'quote event-form)))

#+acl2-loop-only
(defmacro deflabel (&whole event-form name &key doc)

; Warning: See the Important Boot-Strapping Invariants before modifying!

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

  ":Doc-Section Events

  build a landmark and/or add a ~il[documentation] topic~/
  ~bv[]
  Examples:
  (deflabel interp-section
     :doc
     \":Doc-Section ...\")~/

  General Form:
  (deflabel name :doc doc-string)
  ~ev[]
  where ~c[name] is a new symbolic name (~pl[name]) and ~ilc[doc-string] is an
  optional ~il[documentation] string (~pl[doc-string]).  This event adds the
  ~il[documentation] string for symbol ~c[name] to the ~c[:]~ilc[doc] database.
  By virtue of the fact that ~c[deflabel] is an event, it also marks the
  current ~il[history] with the ~c[name].  Thus, even undocumented labels are
  convenient as landmarks in a proof development.  For example, you may wish to
  undo back through some label or compute a theory expression (~pl[theories])
  in terms of some labels.  ~c[Deflabel] ~il[events] are never considered
  redundant.  ~l[redundant-events].

  ~l[defdoc] for a means of attaching a ~il[documentation] string to a
  name without marking the current ~il[history] with that name.~/"

; Warning: See the Important Boot-Strapping Invariants before modifying!

  (list 'deflabel-fn
        (list 'quote name)
        'state
        (list 'quote doc)
        (list 'quote event-form)))

(deflabel theories
  :doc
  ":Doc-Section Theories

  sets of ~il[rune]s to ~il[enable]/~il[disable] in concert~/
  ~bv[]
  Example: '((:definition app) ; or (:d app)
             (:executable-counterpart app)
             (:i app)
             rv
             (rv)
             assoc-of-app)
  ~ev[]
  See:~/

  A theory is a list of ``runic designators'' as described below.  Each runic
  designator denotes a set of ``runes'' (~pl[rune]) and by unioning together
  the runes denoted by each member of a theory we define the set of runes
  corresponding to a theory.  Theories are used to control which rules are
  ``~il[enable]d,'' i.e., available for automatic application by the theorem
  prover.  There is always a ``current'' theory.  A rule is ~il[enable]d
  precisely if its ~il[rune] is an element of the set of ~il[rune]s
  corresponding to the current theory.  At the top-level, the current theory is
  the theory selected by the most recent ~ilc[in-theory] event, extended with
  the rule names introduced since then.  Inside the theorem prover, the
  ~c[:]~ilc[in-theory] hint (~pl[hints]) can be used to select a particular
  theory as current during the proof attempt for a particular goal.

  Theories are generally constructed by ``theory expressions.''  Formally, a
  theory expression is any term, containing at most the single free variable
  ~ilc[world], that when evaluated with ~ilc[world] bound to the current ACL2
  world (~pl[world]) produces a theory.  ACL2 provides various functions for
  the convenient construction and manipulation of theories.  These are called
  ``theory functions''(~pl[theory-functions]).  For example, the theory
  function ~ilc[union-theories] takes two theories and produces their union.
  The theory function ~ilc[universal-theory] returns the theory containing all
  known rule names as of the introduction of a given logical name.  But a
  theory expression can contain constants, e.g.,
  ~bv[]
  '(len (len) (:rewrite car-cons) car-cdr-elim)
  ~ev[]
  and user-defined functions.  The only important criterion is that a theory
  expression mention no variable freely except ~ilc[world] and evaluate to a
  theory.

  More often than not, theory expressions typed by the user do not mention the
  variable ~ilc[world].  This is because user-typed theory expressions are
  generally composed of applications of ACL2's theory functions.  These
  ``functions'' are actually macros that expand into terms in which ~ilc[world]
  is used freely and appropriately.  Thus, the technical definition of ``theory
  expression'' should not mislead you into thinking that interestng theory
  expressions must mention ~ilc[world]; they probably do and you just didn't
  know it!

  One aspect of this arrangement is that theory expressions cannot generally be
  evaluated at the top-level of ACL2, because ~ilc[world] is not bound.  To see
  the value of a theory expression, ~c[expr], at the top-level, type
  ~bv[]
  ACL2 !>(LET ((WORLD (W STATE))) expr).
  ~ev[]
  However, because the built-in theories are quite long, you may be sorry you
  printed the value of a theory expression!

  A theory is a true list of runic designators and to each theory there
  corresponds a set of ~il[rune]s, obtained by unioning together the sets of
  ~il[rune]s denoted by each runic designator.  For example, the theory
  constant
  ~bv[]
     '(len (len) (:e nth) (:rewrite car-cons) car-cdr-elim)
  ~ev[]
  corresponds to the set of ~il[rune]s
  ~bv[]
     {(:definition len)
      (:induction len)
      (:executable-counterpart len)
      (:executable-counterpart nth)
      (:elim car-cdr-elim)
      (:rewrite car-cons)} .
  ~ev[]
  Observe that the theory contains five elements but its runic correspondent
  contains six.  That is because runic designators can denote sets of several
  ~il[rune]s, as is the case for the first designator, ~c[len].  If the above
  theory were selected as current then the six rules named in its runic
  counterpart would be ~il[enable]d and all other rules would be ~il[disable]d.

  We now precisely define the runic designators and the set of ~il[rune]s
  denoted by each.  When we refer below to the ``macro-aliases dereference of''
  a symbol, ~c[symb], we mean the (function) symbol corresponding ~c[symb] in
  the macro-aliases-table if there is such a symbol, else ~c[symb] itself;
  ~pl[macro-aliases-table].  For example, the macro-aliases dereference of
  ~ilc[append] is ~ilc[binary-append], and the macro-aliases dereference of
  ~ilc[nth] is ~c[nth].~bq[]

  o A ~il[rune] is a runic designator and denotes the singleton set
  containing that rune.

  o Suppose that ~c[symb] is a symbol and ~c[symb'] is the macro-aliases
  dereference of ~c[symb], where ~c[symb'] is a function symbol introduced with
  a ~ilc[defun] (or ~ilc[defuns]) event.  Then ~c[symb] is a runic designator
  and denotes the set containing the runes ~c[(:definition symb')] and
  ~c[(:induction symb')], omitting the latter if no such ~il[induction] rune
  exists (presumably because the definition of ~c[symb'] is not singly
  recursive).

  o Suppose that ~c[symb] is a symbol and ~c[symb'] is the macro-aliases
  dereference of ~c[symb], where ~c[symb'] is a function symbol introduced with
  a ~ilc[defun] (or ~ilc[defuns]) event.  Then ~c[(symb)] is a runic designator
  and denotes the singleton set containing the rune
  ~c[(:executable-counterpart symb')].

  o If ~c[symb] is the name of a ~ilc[defthm] (or ~ilc[defaxiom]) event that
  introduced at least one rule, then ~c[symb] is a runic designator and
  denotes the set of the names of all rules introduced by the named
  event.

  o If ~c[str] is the string naming some ~ilc[defpkg] event and ~c[symb] is the
  symbol returned by ~c[(intern str \"ACL2\")], then ~c[symb] is a runic
  designator and denotes the singleton set containing ~c[(:rewrite symb)],
  which is the name of the rule stating the conditions under which the
  ~ilc[symbol-package-name] of ~c[(intern x str)] is ~c[str].

  o If ~c[symb] is the name of a ~ilc[deftheory] event, then ~c[symb] is a runic
  designator and denotes the runic theory corresponding to ~c[symb].

  o Finally, suppose that ~c[symb] is a symbol and ~c[symb'] is the
  macro-aliases dereference of ~c[symb].  Then ~c[(:KWD symb . rest)] is a
  runic designator if ~c[(:KWD' symb' . rest)] is a ~il[rune], where ~c[:KWD]
  is one of ~c[:d], ~c[:e], ~c[:i], or ~c[:t], and correspondingly ~c[:KWD'] is
  ~c[:definition], ~c[:executable-counterpart], ~c[:induction], or
  ~c[:type-prescription], respectively.  In this case, ~c[(:KWD symb . rest)]
  denotes the runic theory corresponding to the rune ~c[(:KWD' symb' . rest)].

  ~eq[]Note that including a function name, e.g., ~ilc[len], in the current
  theory ~il[enable]s that function but does not ~il[enable] the executable
  counterpart.  Similarly, including ~c[(len)] or ~c[(:e len)] ~il[enable]s the
  executable counterpart but not the symbolic definition.  And including the
  name of a proved lemma ~il[enable]s all of the rules added by the event.  Of
  course, one can include explicitly the ~il[rune]s naming the rules in
  question and so can avoid entirely the use of non-runic elements in theories.

  Because a ~il[rune] is a runic designator denoting the set containing that
  ~il[rune], a list of ~il[rune]s is a theory and denotes itself.  We call such
  theories ``runic theories.''  To every theory there corresponds a runic
  theory obtained by unioning together the sets denoted by each designator in
  the theory.  When a theory is selected as ``current'' it is actually its
  runic correspondent that is effectively used.  That is, a ~il[rune] is
  ~il[enable]d iff it is a member of the runic correspondent of the current
  theory.  The value of a theory defined with ~ilc[deftheory] is the runic
  correspondent of the theory computed by the defining theory expression.  The
  theory manipulation functions, e.g., ~ilc[union-theories], actually convert
  their theory arguments to their runic correspondents before performing the
  required set operation.  The manipulation functions always return runic
  theories.  Thus, it is sometimes convenient to think of
  (non-runic) theories as merely abbreviations for their runic
  correspondents, abbreviations which are ``expanded'' at the first
  opportunity by theory manipulation functions and the ``theory
  consumer'' functions such as ~ilc[in-theory] and ~ilc[deftheory].~/")

#+acl2-loop-only
(defmacro deftheory (&whole event-form name expr &key doc)

; Warning: See the Important Boot-Strapping Invariants before modifying!

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

  ":Doc-Section Events

  define a theory (to ~il[enable] or ~il[disable] a set of rules)~/
  ~bv[]
  Example:
  (deftheory interp-theory
             (set-difference-theories
               (universal-theory :here)
               (universal-theory 'interp-section)))~/

  General Form:
  (deftheory name term :doc doc-string)
  ~ev[]
  where ~c[name] is a new symbolic name (~pl[name]), ~c[term] is a term
  that when evaluated will produce a theory (~pl[theories]), and
  ~ilc[doc-string] is an optional ~il[documentation] string
  (~pl[doc-string]).  Except for the variable ~ilc[world], ~c[term] must
  contain no free variables.  ~c[Term] is evaluated with ~ilc[world] bound to
  the current world (~pl[world]) and the resulting theory is then
  converted to a ~em[runic theory] (~pl[theories]) and associated with
  ~c[name].  Henceforth, this runic theory is returned as the value of the
  theory expression ~c[(theory name)].

  The value returned is the length of the resulting theory.  For example, in
  the following, the theory associated with ~c['FOO] has 54 ~il[rune]s:
  ~bv[]
  ACL2 !>(deftheory foo (union-theories '(binary-append)
                                        (theory 'minimal-theory)))

  Summary
  Form:  ( DEFTHEORY FOO ...)
  Rules: NIL
  Warnings:  None
  Time:  0.00 seconds (prove: 0.00, print: 0.00, other: 0.00)
   54
  ACL2 !>
  ~ev[]

  Note that the theory being defined depends on the context.  For example,
  consider the following (contrived) example book.
  ~bv[]
    (in-package \"ACL2\")
    (defund foo (x) (consp x)) ; defund disables foo
    (local (in-theory (enable foo)))
    (deftheory my-theory (current-theory :here))
    (in-theory (disable foo))
    (defthm foo-property
      (implies (consp x)
               (foo x))
      :hints ((\"Goal\" :in-theory (enable my-theory))))
  ~ev[]
  At the time ~c[foo-property] is proved admissible during book certification
  (~pl[certify-book]), the ~ilc[local] ~ilc[in-theory] event has previously
  been evaluated, so the ~il[definition] of ~c[foo] is ~il[enable]d.  Thus, the
  ~c[:in-theory] hint on ~c[foo-property] will ~il[enable] ~c[foo], and the
  theorem proves.  HOWEVER, when the book is later included
  (~pl[include-book]), the ~ilc[local] event is skipped, so the definition of
  ~c[foo] is ~il[disable]d at the time the ~il[theory] ~c[my-theory] is
  defined.  Hence, unlike the case for the admissibility pass of the book's
  certification, that theory does not include the definition of ~c[foo] when
  the book is included.

  There is, however, a way to ensure that a ~il[theory] defined in a book is
  the same at ~ilc[include-book] time as it was during the admissibility pass
  of the book's certification; ~pl[deftheory-static].~/

  :cited-by Theories"

; Warning: See the Important Boot-Strapping Invariants before modifying!

  (list 'deftheory-fn
        (list 'quote name)
        (list 'quote expr)
        'state
        (list 'quote doc)
        (list 'quote event-form)))

(defmacro deftheory-static (name theory)

  ":Doc-Section Events

  define a `static' theory (to ~il[enable] or ~il[disable] a set of rules)~/

  This macro provides a variant of ~ilc[deftheory], such that the resulting
  theory is the same at ~ilc[include-book] time as it was at ~ilc[certify-book]
  time.

  We assume that the reader is familiar with ~il[theories]; ~pl[deftheory].  We
  begin here by illustrating how ~c[deftheory-static] differs from
  ~ilc[deftheory].  Suppose for example that the following events are the first
  two events in a book, where that book is certified in the initial ACL2
  ~il[world] (~pl[ground-zero]).
  ~bv[]
  (deftheory my-theory
    (current-theory :here))
  (deftheory-static my-static-theory
    (current-theory :here))
  ~ev[]
  Now suppose we include that book after executing the following event.
  ~bv[]
  (in-theory (disable car-cons))
  ~ev[]
  Suppose that later we execute ~c[(in-theory (theory 'my-theory))].  Then the
  rule ~c[car-cons] will be disabled, because it was disabled at the time the
  expression ~c[(current-theory :here)] was evaluated when processing the
  ~c[deftheory] of ~c[my-theory] while including the book.  However, if we
  execute ~c[(in-theory (theory 'my-static-theory))], then the rule
  ~c[car-cons] will be enabled, because the value of the theory
  ~c[my-static-theory] was saved at the time the book was certified.~/

  ~bv[]
  General Form:
  (deftheory-static name term :doc doc-string)
  ~ev[]
  The arguments are handled the same as for ~ilc[deftheory].  Thus, ~c[name] is
  a new symbolic name (~pl[name]), ~c[term] is a term that when evaluated will
  produce a theory (~pl[theories]), and ~ilc[doc-string] is an optional
  ~il[documentation] string (~pl[doc-string]).  Except for the variable
  ~ilc[world], ~c[term] must contain no free variables.  ~c[Term] is evaluated
  with ~ilc[world] bound to the current world (~pl[world]) and the resulting
  theory is then converted to a ~em[runic theory] (~pl[theories]) and
  associated with ~c[name].  Henceforth, this runic theory is returned as the
  value of the theory expression ~c[(theory name)].

  As for ~ilc[deftheory], the value returned is the length of the resulting
  theory.

  We conclude with an optional discussion about the implementation of
  ~c[deftheory-static], for those familiar with ~ilc[make-event].  The
  following macroexpansion of the ~c[deftheory-static] form above shows how
  this works (~pl[trans1]).
  ~bv[]
  ACL2 !>:trans1 (deftheory-static my-static-theory
                   (current-theory :here))
   (MAKE-EVENT (LET ((WORLD (W STATE)))
                    (LIST 'DEFTHEORY
                          'MY-STATIC-THEORY
                          (LIST 'QUOTE (CURRENT-THEORY :HERE)))))
  ACL2 !>
  ~ev[]

  The idea is that upon evaluation of this ~c[make-event] form, the first step
  is to evaluate the indicated ~ilc[LET] expression to obtain a form
  ~c[(deftheory my-theory '(...))], where ``~c[(...)]'' is a list of all
  ~il[rune]s in current theory.  If this form is in a book being certified,
  then the resulting ~c[deftheory] form is stored in the book's certificate,
  and is used when the book is included later.~/

  :cited-by Theories"

  `(make-event
    (let ((world (w state)))
      (list 'deftheory ',name
         (list 'quote ,theory)))))

#+acl2-loop-only
(defmacro defstobj (&whole event-form name &rest args)

; Warning: See the Important Boot-Strapping Invariants before modifying!

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

  ":Doc-Section Events

  define a new single-threaded object ~/

  Note: Novices are advised to avoid ~c[defstobj], perhaps instead using
  community books ~c[books/cutil/defaggregate.lisp] or
  ~c[books/data-structures/structures.lisp].  At the least, consider using
  ~c[(]~ilc[set-verify-guards-eagerness]~c[ 0)] to avoid ~il[guard]
  verification.  On the other hand, after you learn to use ~c[defstobj],
  ~pl[defabsstobj] for another way to introduce single-threaded objects.

  ~bv[]
  Example:
  (defconst *mem-size* 10) ; for use of *mem-size* just below
  (defstobj st
            (reg :type (array (unsigned-byte 31) (8))
                 :initially 0)
            (p-c :type (unsigned-byte 31)
                 :initially 555)
            halt                  ; = (halt :type t :initially nil)
            (mem :type (array (unsigned-byte 31) (*mem-size*))
                 :initially 0 :resizable t))

  General Form:
  (defstobj name
            (field1 :type type1 :initially val1 :resizable b1)
            ...
            (fieldk :type typek :initially valk :resizable bk)
            :renaming alist
            :doc doc-string
            :inline flg
            :congruent-to old-stobj-name)
  ~ev[]
  where ~c[name] is a new symbol, each ~c[fieldi] is a symbol, each ~c[typei]
  is either a type-indicator (a ~ilc[type-spec] or ~il[stobj] name) or of the
  form ~c[(ARRAY type-indicator max)], each ~c[vali] is an object satisfying
  ~c[typei], and each ~c[bi] is ~c[t] or ~c[nil].  Each pair
  ~c[:initially vali] and ~c[:resizable bi] may be omitted; more on this below.
  The ~c[:renaming alist] argument is optional and allows the user to override
  the default function names introduced by this event.  The ~ilc[doc-string] is
  also optional.  The ~c[:inline flg] Boolean argument is also optional and
  declares to ACL2 that the generated access and update functions for the stobj
  should be implemented as macros under the hood (which has the effect of
  inlining the function calls).  The optional ~c[:congruent-to old-stobj-name]
  argument specifies an existing stobj with exactly the same structure, and is
  discussed below.  We describe further restrictions on the ~c[fieldi],
  ~c[typei], ~c[vali], and on ~c[alist] below.  We recommend that you read
  about single-threaded objects (stobjs) in ACL2 before proceeding; ~pl[stobj].

  The effect of this event is to introduce a new single-threaded object (i.e.,
  a ``~il[stobj]''), named ~c[name], and the associated recognizers, creator,
  accessors, updaters, constants, and, for fields of ~c[ARRAY] type, length and
  resize functions.~/

  ~em[The Single-Threaded Object Introduced]

  The ~c[defstobj] event effectively introduces a new global variable, named
  ~c[name], which has as its initial logical value a list of ~c[k] elements,
  where ~c[k] is the number of ``field descriptors'' provided.  The elements
  are listed in the same order in which the field descriptors appear.  If the
  ~c[:type] of a field is ~c[(ARRAY type-indicator (max))] then ~c[max] is a
  non-negative integer or a symbol introduced by ~ilc[defconst]) whose value is
  a non-negative integer, and the corresponding element of the stobj is
  initially of length specified by ~c[max].

  Whether the value ~c[:type] is of the form ~c[(ARRAY type-indicator (max))]
  or, otherwise, just ~c[type-indicator], then ~c[type-indicator] is typically
  a type-spec; ~pl[type-spec].  However, ~c[type-indicator] can also be the
  name of a stobj that was previously introduced (by ~c[defstobj] or
  ~ilc[defabsstobj]).  We ignore this ``nested stobj'' case below;
  ~pl[nested-stobjs] for a discussion of stobjs within stobjs.

  The keyword value ~c[:initially val] specifies the initial value of a field,
  except for the case of a ~c[:type] ~c[(ARRAY type-indicator (max))], in which
  case ~c[val] is the initial value of the corresponding array.

  Note that the actual representation of the stobj in the underlying Lisp may
  be quite different; ~pl[stobj-example-2].  For the moment we focus entirely
  on the logical aspects of the object.

  In addition, the ~c[defstobj] event introduces functions for recognizing and
  creating the stobj and for recognizing, accessing, and updating its fields.
  For fields of ~c[ARRAY] type, length and resize functions are also
  introduced.  Constants are introduced that correspond to the accessor
  functions.

  ~em[Restrictions on the Field Descriptions in Defstobj]

  Each field descriptor is of the form:
  ~bv[]
  (fieldi :TYPE typei :INITIALLY vali)
  ~ev[]
  Note that the type and initial value are given in ``keyword argument'' format
  and may be given in either order.  The ~c[typei] and ~c[vali] ``arguments''
  are not evaluated.  If omitted, the type defaults to ~c[t] (unrestricted) and
  the initial value defaults to ~c[nil].

  Each ~c[typei] must be either a ~ilc[type-spec] or else a list of the form
  ~c[(ARRAY type-spec (max))].  (Again, we are ignoring the case of nested
  stobjs, discussed elsewhere; ~pl[nested-stobjs].)  The latter forms are said
  to be ``array types.''  Examples of legal ~c[typei] are:
  ~bv[]
  (INTEGER 0 31)
  (SIGNED-BYTE 31)
  (ARRAY (SIGNED-BYTE 31) (16))
  (ARRAY (SIGNED-BYTE 31) (*c*)) ; where *c* has a non-negative integer value
  ~ev[]

  The ~c[typei] describes the objects which are expected to occupy the given
  field.  Those objects in ~c[fieldi] should satisfy ~c[typei].  We are more
  precise below about what we mean by ``expected.''  We first present the
  restrictions on ~c[typei] and ~c[vali].

  Non-Array Types

  When ~c[typei] is a ~ilc[type-spec] it restricts the contents, ~c[x], of
  ~c[fieldi] according to the ``meaning'' formula given in the table for
  ~ilc[type-spec].  For example, the first ~c[typei] above restricts the field
  to be an integer between 0 and 31, inclusive.  The second restricts the field
  to be an integer between -2^30 and (2^30)-1, inclusive.

  The initial value, ~c[vali], of a field description may be any ACL2 object
  but must satisfy ~c[typei].  Note that ~c[vali] is not a form to be evaluated
  but an object.  A form that evaluates to ~c[vali] could be written ~c['vali],
  but ~c[defstobj] does not expect you to write the quote mark.  For example,
  the field description
  ~bv[]
  (days-off :initially (saturday sunday))
  ~ev[]
  describes a field named ~c[days-off] whose initial value is the list
  consisting of the two symbols ~c[SATURDAY] and ~c[SUNDAY].  In particular,
  the initial value is NOT obtained by applying the function ~c[saturday] to
  the variable ~c[sunday]!  Had we written
  ~bv[]
  (days-off :initially '(saturday sunday))
  ~ev[]
  it would be equivalent to writing
  ~bv[]
  (days-off :initially (quote (saturday sunday)))
  ~ev[]
  which would initialize the field to a list of length two, whose first element
  is the symbol ~c[quote] and whose second element is a list containing the
  symbols ~c[saturday] and ~c[sunday].

  Array Types

  When ~c[typei] is of the form ~c[(ARRAY type-spec (max))], the field is
  supposed to be a list of items, initially of length specified by ~c[max],
  each of which satisfies the indicated ~c[type-spec].  ~c[Max] must be a
  non-negative integer or a defined constant evaluating to a non-negative
  integer. Thus, each of
  ~bv[]
  (ARRAY (SIGNED-BYTE 31) (16))
  (ARRAY (SIGNED-BYTE 31) (*c*)) ; given previous event (defconst *c* 16)
  ~ev[]
  restricts the field to be a list of integers, initially of length 16, where
  each integer in the list is a ~c[(SIGNED-BYTE 31)].  We sometimes call such a
  list an ``array'' (because it is represented as an array in the underlying
  Common Lisp).  The elements of an array field are indexed by position,
  starting at 0.  Thus, the maximum legal index of an array field one less than
  is specified by ~c[max].  Note that the value of ~c[max] must be less than
  the Common Lisp constant ~c[array-dimension-limit], and also (though this
  presumably follows) less than the Common Lisp constant
  ~c[array-total-size-limit].

  Note also that the ~c[ARRAY] type requires that the ~c[max] be enclosed in
  parentheses.  This makes ACL2's notation consistent with the Common Lisp
  convention of describing the (multi-)dimensionality of arrays.  But ACL2
  currently supports only single dimensional arrays in stobjs.

  For array fields, the initial value ~c[vali] must be an object satisfying the
  ~ilc[type-spec] of the ~c[ARRAY] description.  The initial value of the field
  is a list of ~c[max] repetitions of ~c[vali].

  Array fields can be ``resized,'' that is, their lengths can be changed, if
  ~c[:resizable t] is supplied as shown in the example and General Form above.
  The new length must satisfy the same restriction as does ~c[max], as
  described above.  Each array field in a ~c[defstobj] event gives rise to a
  length function, which gives the length of the field, and a resize function,
  which modifies the length of the field if ~c[:resizable t] was supplied with
  the field when the ~c[defstobj] was introduced and otherwise causes an error.
  If ~c[:resizable t] was supplied and the resize function specifies a new
  length ~c[k], then: if ~c[k] is less than the existing array length, the array
  is shortened simply by dropping elements with index at least ~c[k];
  otherwise, the array is extended to length ~c[k] by mapping the new indices
  to the initial value (supplied by ~c[:initially], else default ~c[nil]).

  Array resizing is relatively slow, so we recommend using it somewhat
  sparingly.

  ~em[The Default Function Names]

  To recap, in
  ~bv[]
  (defstobj name
            (field1 :type type1 :initially val1)
            ...
            (fieldk :type typek :initially valk)
            :renaming alist
            :doc doc-string
            :inline inline-flag)
  ~ev[]
  ~c[name] must be a new symbol, each ~c[fieldi] must be a symbol,
  each ~c[typei] must be a ~ilc[type-spec] or ~c[(ARRAY type-spec (max))],
  and each ~c[vali] must be an object satisfying ~c[typei].

  Roughly speaking, for each ~c[fieldi], a ~c[defstobj] introduces a
  recognizer function, an accessor function, and an updater function.
  The accessor function, for example, takes the stobj and returns the
  indicated component; the updater takes a new component value and the
  stobj and return a new stobj with the component replaced by the new
  value.  But that summary is inaccurate for array fields.

  The accessor function for an array field does not take the stobj and return
  the indicated component array, which is a list of length specified by
  ~c[max].  Instead, it takes an additional index argument and returns the
  indicated element of the array component.  Similarly, the updater function
  for an array field takes an index, a new value, and the stobj, and returns a
  new stobj with the indicated element replaced by the new value.

  These functions ~-[] the recognizer, accessor, and updater, and also length
  and resize functions in the case of array fields ~-[] have ``default names.''
  The default names depend on the field name, ~c[fieldi], and on whether the
  field is an array field or not.  For clarity, suppose ~c[fieldi] is named
  ~c[c]. The default names are shown below in calls, which also indicate the
  arities of the functions.  In the expressions, we use ~c[x] as the object to
  be recognized by field recognizers, ~c[i] as an array index, ~c[v] as the
  ``new value'' to be installed by an updater, and ~c[name] as the
  single-threaded object.

  ~bv[]
                   non-array field        array field
  recognizer         (cP x)                (cP x)
  accessor           (c name)              (cI i name)
  updater            (UPDATE-c v name)     (UPDATE-cI i v name)
  length                                   (c-LENGTH name)
  resize                                   (RESIZE-c k name)
  ~ev[]

  Finally, a recognizer and a creator for the entire single-threaded object are
  introduced.  The creator returns the initial stobj, but may only be used in
  limited contexts; ~pl[with-local-stobj].  If the single-threaded object is
  named ~c[name], then the default names and arities are as shown below.
  ~bv[]
  top recognizer     (nameP x)
  creator            (CREATE-name)
  ~ev[]

  For example, the event
  ~bv[]
  (DEFSTOBJ $S
    (X :TYPE INTEGER :INITIALLY 0)
    (A :TYPE (ARRAY (INTEGER 0 9) (3)) :INITIALLY 9))
  ~ev[]
  introduces a stobj named ~c[$S].  The stobj has two fields, ~c[X] and ~c[A].
  The ~c[A] field is an array.  The ~c[X] field contains an integer and is
  initially 0.  The ~c[A] field contains a list of integers, each between 0 and
  9, inclusively.  Initially, each of the three elements of the ~c[A] field is
  9.

  This event introduces the following sequence of definitions:
  ~bv[]
  (DEFUN XP (X) ...)               ; recognizer for X field
  (DEFUN AP (X) ...)               ; recognizer of A field
  (DEFUN $SP ($S) ...)             ; top-level recognizer for stobj $S
  (DEFUN CREATE-$S () ...)         ; creator for stobj $S
  (DEFUN X ($S) ...)               ; accessor for X field
  (DEFUN UPDATE-X (V $S) ...)      ; updater for X field
  (DEFUN A-LENGTH ($S) ...)        ; length of A field
  (DEFUN RESIZE-A (K $S) ...)      ; resizer for A field
  (DEFUN AI (I $S) ...)            ; accessor for A field at index I
  (DEFUN UPDATE-AI (I V $S) ...)   ; updater for A field at index I
  ~ev[]

  ~em[Avoiding the Default Function Names]

  If you do not like the default names listed above you may use the optional
  ~c[:renaming] alist to substitute names of your own choosing.  Each element
  of ~c[alist] should be of the form ~c[(fn1 fn2)], where ~c[fn1] is a default
  name and ~c[fn2] is your choice for that name.

  For example
  ~bv[]
  (DEFSTOBJ $S
    (X :TYPE INTEGER :INITIALLY 0)
    (A :TYPE (ARRAY (INTEGER 0 9) (3)) :INITIALLY 9)
    :renaming ((X XACCESSOR) (CREATE-$S MAKE$S)))
  ~ev[]
  introduces the following definitions
  ~bv[]
  (DEFUN XP (X) ...)               ; recognizer for X field
  (DEFUN AP (X) ...)               ; recognizer of A field
  (DEFUN $SP ($S) ...)             ; top-level recognizer for stobj $S
  (DEFUN MAKE$S () ...)            ; creator for stobj $S
  (DEFUN XACCESSOR ($S) ...)       ; accessor for X field
  (DEFUN UPDATE-X (V $S) ...)      ; updater for X field
  (DEFUN A-LENGTH ($S) ...)        ; length of A field
  (DEFUN RESIZE-A (K $S) ...)      ; resizer for A field
  (DEFUN AI (I $S) ...)            ; accessor for A field at index I
  (DEFUN UPDATE-AI (I V $S) ...)   ; updater for A field at index I
  ~ev[]
  Note that even though the renaming alist substitutes ``~c[XACCESSOR]'' for
  ``~c[X]'' the updater for the ~c[X] field is still called ``~c[UPDATE-X].''
  That is because the renaming is applied to the default function names, not to
  the field descriptors in the event.

  Use of the ~c[:renaming] alist may be necessary to avoid name clashes between
  the default names and and pre-existing function symbols.

  ~em[Constants]

  ~c[Defstobj] events also introduce constant definitions
  (~pl[defconst]).  One constant is introduced for each accessor function by
  prefixing and suffixing a `~c[*]' character on the function name.  The value
  of that constant is the position of the field being accessed.  For example,
  if the accessor functions are ~c[a], ~c[b], and ~c[c], in that order, then
  the following constant definitions are introduced.
  ~bv[]
  (defconst *a* 0)
  (defconst *b* 1)
  (defconst *c* 2)
  ~ev[]
  These constants are used for certain calls of ~ilc[nth] and ~ilc[update-nth]
  that are displayed to the user in proof output.  For example, for stobj
  ~c[st] with accessor functions ~c[a], ~c[b], and ~c[c], in that order, the
  term ~c[(nth '2 st)] would be printed during a proof as ~c[(nth *c* st)].
  Also ~pl[term], in particular the discussion there of untranslated terms, and
  ~pl[nth-aliases-table].

  ~em[Inspecting the Effects of a Defstobj]

  Because the stobj functions are introduced as ``sub-events'' of the
  ~c[defstobj] the history commands ~c[:]~ilc[pe] and ~c[:]~ilc[pc] will not
  print the definitions of these functions but will print the superior
  ~c[defstobj] event.  To see the definitions of these functions use the
  history command ~c[:]~ilc[pcb!].

  To see an s-expression containing the definitions what constitute the raw
  Lisp implementation of the event, evaluate the form
  ~bv[]
  (nth 4 (global-val 'cltl-command (w state)))
  ~ev[]
  ~em[immediately after] the ~c[defstobj] event has been processed.

  A ~c[defstobj] is considered redundant only if the name, field descriptors,
  renaming alist, and inline flag are identical to a previously executed
  ~c[defstobj].  Note that a redundant ~c[defstobj] does not reset the
  ~il[stobj] fields to their initial values.

  ~em[Inlining and Performance]

  The ~c[:inline] keyword argument controls whether or not accessor, updater,
  and length functions are inlined (as macros under the hood, in raw Lisp).  If
  ~c[:inline t] is provided then these are inlined; otherwise they are not.
  The advantage of inlining is potentially better performance; there have been
  contrived examples, doing essentially nothing except accessing and updating
  array fields, where inlining reduced the time by a factor of 10 or more; and
  inlining has sped up realistic examples by a factor of at least 2.  Inlining
  may get within a factor of 2 of C execution times for such contrived
  examples, and within a few percent of C execution times on realistic
  examples.

  A drawback to inlining is that redefinition may not work as expected, much as
  redefinition may not work as expected for macros: defined functions that call
  a macro, or inlined stobj function, will not see a subsequent redefinition of
  the macro or inlined function.  Another drawback to inlining is that because
  inlined functions are implemented as macros in raw Lisp, tracing
  (~pl[trace$]) will not show their calls.  These drawbacks are avoided by
  default, but the user who is not concerned about them is advised to specify
  ~c[:inline t].

  ~em[Specifying Congruent Stobjs]

  Two stobjs are may be considered to be ``congruent'' if they have the same
  structure, that is, their ~c[defstobj] events are identical when ignoring
  field names.  In particular, every stobj is congruent to itself.  In order to
  tell ACL2 that a new stobj ~c[st2] is indeed to be considered as congruent to
  an existing stobj ~c[st1], the ~c[defstobj] event introducing ~c[st2] is
  given the keyword argument ~c[:congruent-to st1].  Congruence is an
  equivalence relation: when you specify a new stobj to be congruent to an old
  one, you are also specifying that the new stobj is congruent to all other
  stobjs that are congruent to the old one.  Thus, continuing the example
  above, if you specify that ~c[st3] is ~c[:congruent-to st2], then ~c[st1],
  ~c[st2], and ~c[st3] will all be congruent to each other.

  When two stobjs are congruent, ACL2 allows you to substitute one for another
  in a function call.  Any number of stobjs may be replaced with congruent
  stobjs in the call, provided no two get replaced with the same stobj.  The
  return values are correspondingly modified: if stobj ~c[st1] is replaced by
  ~c[st2] at an argument position, and if ~c[st1] is returned in the output
  ~il[signature] of the function, then ~c[st2] is returned in place of ~c[st1].

  The following example illustrates congruent stobjs.  For more examples of how
  to take advantage of congruent stobjs, and also of how to misuse them, see
  community book ~c[books/misc/congruent-stobjs-test.lisp].
  ~bv[]
  (defstobj st1 fld1)
  (defstobj st2 fld2 :congruent-to st1)
  (defstobj st3 fld3 :congruent-to st2) ; equivalently, :congruent-to st1
  (defun f (st1 st2 st3)
    (declare (xargs :stobjs (st1 st2 st3)))
    (list (fld2 st1) (fld3 st2) (fld1 st3)))
  (update-fld1 1 st1)
  (update-fld1 2 st2) ; notice use of update-fld1 on st2
  (update-fld1 3 st3) ; notice use of update-fld1 on st3
  (assert-event (equal (f st3 st2 st1) '(3 2 1)))
  ~ev[]
  The following example shows an error that occurs when stobj arguments are
  repeated, i.e., at least two stobj arguments (in this case, three) get
  replaced by the same stobj.
  ~bv[]
  ACL2 !>(f st1 st1 st1)


  ACL2 Error in TOP-LEVEL:  The form ST1 is being used, as an argument
  to a call of F, where the single-threaded object ST2 was expected,
  even though these are congruent stobjs.  See :DOC defstobj, in particular
  the discussion of congruent stobjs.  Note:  this error occurred in
  the context (F ST1 ST1 ST1).

  ACL2 !>
  ~ev[]~/"

; Warning: See the Important Boot-Strapping Invariants before modifying!

  (list 'defstobj-fn
        (list 'quote name)
        (list 'quote args)
        'state
        (list 'quote event-form)))

#+acl2-loop-only
(defmacro in-theory (&whole event-form expr &key doc)

; Warning: See the Important Boot-Strapping Invariants before modifying!

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

  ":Doc-Section Events

  designate ``current'' theory (enabling its rules)~/
  ~bv[]
  Example:
  (in-theory (set-difference-theories
               (universal-theory :here)
               '(flatten (:executable-counterpart flatten))))~/

  General Form:
  (in-theory term :doc doc-string)
  ~ev[]
  where ~c[term] is a term that when evaluated will produce a theory
  (~pl[theories]), and ~ilc[doc-string] is an optional ~il[documentation]
  string not beginning with ``~c[:Doc-Section] ...''.  Because no unique name
  is associated with an ~c[in-theory] event, there is no way we can store the
  ~il[documentation] string ~ilc[doc-string] in our ~il[documentation]
  database.  Hence, we actually prohibit ~ilc[doc-string] from having the form
  of an ACL2 ~il[documentation] string; ~pl[doc-string].

  Except for the variable ~ilc[world], ~c[term] must contain no free variables.
  ~c[Term] is evaluated with the variable ~ilc[world] bound to the current
  ~il[world] to obtain a theory and the corresponding runic theory
  (~pl[theories]) is then made the current theory.  Thus,
  immediately after the ~c[in-theory], a rule is ~il[enable]d iff its rule name
  is a member of the runic interpretation (~pl[theories]) of some
  member of the value of ~c[term].  ~l[theory-functions] for a list
  of the commonly used theory manipulation functions.

  Note that it is often useful to surround ~c[in-theory] ~il[events] with
  ~c[local], that is, to use ~c[(local (in-theory ...))].  This use of
  ~ilc[local] in ~ilc[encapsulate] events and ~il[books] will prevent the
  effect of this theory change from being exported outside the context of that
  ~c[encapsulate] or book.

  Also ~pl[hints] for a discussion of the ~c[:in-theory] hint, including some
  explanation of the important point that an ~c[:in-theory] hint will always be
  evaluated relative to the current ACL2 logical ~il[world], not relative to
  the theory of a previous goal.

  ~ilc[In-theory] returns an error triple (~pl[error-triples]).  When the
  return is without error, the value is of the form
  ~c[(mv nil (:NUMBER-OF-ENABLED-RUNES k) state)] where ~c[k] is the length of
  the new current theory.  This value of ~c[k] is what is printed when an
  ~c[in-theory] event evaluates without error at the top level.~/

  :cited-by Theories"

; Warning: See the Important Boot-Strapping Invariants before modifying!

  (list 'in-theory-fn
        (list 'quote expr)
        'state
        (list 'quote doc)
        (list 'quote event-form)))

#+acl2-loop-only
(defmacro in-arithmetic-theory (&whole event-form expr &key doc)

; Warning: See the Important Boot-Strapping Invariants before modifying!

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

  ":Doc-Section Events

  designate theory for some rewriting done for non-linear arithmetic~/

  We assume familiarity with ~il[theories]; in particular, ~pl[in-theory] for
  the normal way to set the current theory.  Here, we discuss an analogous
  event that pertains only to non-linear arithmetic
  (~pl[non-linear-arithmetic]).

  ~bv[]
  Example:
  (in-arithmetic-theory '(lemma1 lemma2))~/

  General Form:
  (in-arithmetic-theory term :doc doc-string)
  ~ev[]
  where ~c[term] is a term that when evaluated will produce a theory
  (~pl[theories]), and ~ilc[doc-string] is an optional ~il[documentation]
  string not beginning with ``~c[:Doc-Section] ...''.  Except for the
  variable ~ilc[world], ~c[term] must contain no free variables.  ~c[Term] is
  evaluated with the variable ~ilc[world] bound to the current ~il[world] to
  obtain a theory and the corresponding runic theory
  (~pl[theories]) is then used by non-linear arithmetic
  (~pl[non-linear-arithmetic]).

  Warning:  If ~c[term] involves macros such as ~ilc[ENABLE] and ~ilc[DISABLE]
  you will probably not get what you expect!  Those macros are defined
  relative to the ~ilc[CURRENT-THEORY].  But in this context you might
  wish they were defined in terms of the ``~c[CURRENT-ARITHMETIC-THEORY]''
  which is not actually a defined function.  We do not anticipate that users
  will repeatedly modify the arithmetic theory.  We expect ~c[term] most often
  to be a constant list of runes and so have not provided ``arithmetic theory
  manipulation functions'' analogous to ~ilc[CURRENT-THEORY] and ~ilc[ENABLE].

  Because no unique name is associated with an ~c[in-arithmetic-theory] event,
  there is no way we can store the ~il[documentation] string ~ilc[doc-string]
  in our il[documentation] database.  Hence, we actually prohibit ~ilc[doc-string]
  from having the form of an ACL2 ~il[documentation] string;
  ~pl[doc-string].

  ~l[non-linear-arithmetic].~/"

; Warning: See the Important Boot-Strapping Invariants before modifying!

  (list 'in-arithmetic-theory-fn
        (list 'quote expr)
        'state
        (list 'quote doc)
        (list 'quote event-form)))

#+acl2-loop-only
(defmacro regenerate-tau-database (&whole event-form &key doc)

; Warning: See the Important Boot-Strapping Invariants before modifying!

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

  ":Doc-Section Events

  regenerate the tau database relative to the current enabled theory~/
  ~bv[]
  Example:
  (regenerate-tau-database)~/

  General Form:
  (regenerate-tau-database :doc doc-string)
  ~ev[]
  where ~ilc[doc-string] is an optional ~il[documentation] string not beginning
  with ``~c[:Doc-Section] ...''.  Because no unique name is associated with a
  ~c[regenerate-tau-database] event, there is no way we can store the
  ~il[documentation] string ~ilc[doc-string] in our il[documentation] database.
  Hence, we actually prohibit ~ilc[doc-string] from having the form of an ACL2
  ~il[documentation] string; ~pl[doc-string].

  The tau database is regenerated by scanning the current logical world and
  re-processing every rule-generating event in it relative to the current
  enabled theory and current tau auto mode settings.
  ~l[introduction-to-the-tau-system] for background details.

  This command was intended to allow the user to remove a fact from the tau
  database, by regenerating the database without the fact.  But as the
  following discussion highlights, ~c[regenerate-tau-database] does not really
  solve the problem.  We regard it as a placeholder for a more sophisticated
  mechanism.  However, we have trouble understanding why a user might wish to
  remove a fact from the database and are awaiting further user experiences
  before designing the more sophisticated mechanism.

  Suppose, for example, that you wanted to remove a signature rule provided by
  some rule with name ~i[rune].  You could disable ~i[rune] and regenerate the
  database.  We discuss why you might ~-[] or might not ~-[] want to do this
  later.  But suppose you did it.  Unfortunately, the database you get will
  not be just like the one you started with minus the signature rule.  The
  reason is that the database you started with was generated incrementally and
  the current theory might have evolved.  To take a simple example, your
  starting database might have included a rule that has been disabled since it
  was first added.  Thus, the part of your starting database built before the
  disabling was constructed with the rule enabled and the part built afterwards
  has the rule disabled.  You are unlikely to get the same database whether
  you enable or disable that rule now.

  You might hope that the avoidance of ~c[in-theory] events would eliminate the
  problem but it does not because even the ~ilc[ground-zero] theory is
  constructed incrementally from the ``pre-history'' commands used to boot up
  ACL2.  Those pre-history commands include some global ~c[in-theory] commands.
  Since every session starts from the ~c[ground-zero] state, the starting
  database is already ``infected'' with global ~c[in-theory] commands.

  The reason we hope that it will not be necessary to remove tau facts is that
  the tau system is designed merely to be fast and benign (see
  ~i[Design Philosophy] in ~il[introduction-to-the-tau-system]).  The tau system's
  coverage should grows monotonically with the addition of rules.  According to
  this understanding of tau, adding a signature rule, for example, may allow
  tau to prove some additional goals but will not prevent it from proving goals
  it could prove previously.  If this is understanding of tau is accurate, we
  see no fundamental reason to support the removal of a fact.  This, of course,
  ignores the possibility that the user wishes to explore alternative proof
  strategies or measure performance.

  We welcome user observations and experience on this issue.~/"

; Warning: See the Important Boot-Strapping Invariants before modifying!

  (list 'regenerate-tau-database-fn
        'state
        (list 'quote doc)
        (list 'quote event-form)))

#+acl2-loop-only
(defmacro push-untouchable (&whole event-form name fn-p &key doc)

; Warning: See the Important Boot-Strapping Invariants before modifying!

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

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

  add name or list of names to the list of untouchable symbols~/
  ~bv[]
  Examples:
  (push-untouchable my-var nil)
  (push-untouchable set-mem t)~/

  General Form:
  (push-untouchable name{s}  fn-p :doc doc-string)
  ~ev[]
  where ~c[name{s}] is a non-~c[nil] symbol or a non-~c[nil] true list of
  symbols, ~c[fn-p] is any value (but generally ~c[nil] or ~c[t]), and
  ~ilc[doc-string] is an optional ~il[documentation] string not
  beginning with ``~c[:Doc-Section] ...''.  If ~c[name{s}] is a symbol it
  is treated as the singleton list containing that symbol.  The effect
  of this event is to union the given symbols into the list of
  ``untouchable variables'' in the current world if ~c[fn-p] is
  ~c[nil], else to union the symbols into the list of ``untouchable
  functions''.  This event is redundant if every symbol listed is
  already a member of the appropriate untouchables list (variables or
  functions).

  When a symbol is on the untouchables list it is syntactically
  illegal for any event to call a function or macro of that name, if
  ~c[fn-p] is non-~c[nil], or to change the value of a state global
  variable of that name, if ~c[fn-p] is ~c[nil].  Thus, the effect of
  pushing a function symbol, ~c[name], onto untouchables is to prevent
  any future event from using that symbol as a function or macro, or
  as a state global variable (according to ~c[fn-p]).  This is
  generally done to ``fence off'' some primitive function symbol from
  ``users'' after the developer has used the symbol freely in the
  development of some higher level mechanism.

  Also ~pl[remove-untouchable].~/"

; Warning: See the Important Boot-Strapping Invariants before modifying!

  (declare (xargs :guard (and name
                              (or (symbolp name)
                                  (symbol-listp name))
                              (booleanp fn-p))))
  (list 'push-untouchable-fn
        (list 'quote name)
        (list 'quote fn-p)
        'state
        (list 'quote doc)
        (list 'quote event-form)))

#+acl2-loop-only
(defmacro remove-untouchable (&whole event-form name fn-p &key doc)

; Warning: See the Important Boot-Strapping Invariants before modifying!

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

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

  remove names from lists of untouchable symbols~/

  ~bv[]
  Example Forms:
  (remove-untouchable my-var nil) ; then state global my-var is not untouchable
  (remove-untouchable set-mem t)  ; then function set-mem is not untouchable
  ~ev[]

  Also ~pl[push-untouchable].

  This documentation topic is directed at those who build systems on top of
  ACL2.  We first describe a means for removing restrictions related to
  so-called ``untouchables'': functions (or macros) that cannot be called, or
  state global variables that cannot be modified or unbound, without
  intervention that requires an active trust tag (~pl[defttag]).  Then we
  describe the ~c[remove-untouchable] event.

  We begin by discussing untouchable state global variables
  ~c[temp-touchable-vars] and ~c[temp-touchable-fns], which initially have
  value ~c[nil].  These can often be used in place of ~c[remove-untouchable].
  When the value is ~c[t], no variable (respectively, no function or macro) is
  treated as untouchable, regardless of the set of initial untouchables or the
  ~c[remove-untouchable] or ~ilc[push-untouchable] ~il[events] that have been
  admitted.  Otherwise the value of each of these two variables is a
  ~ilc[symbol-listp], and no member of this list is treated as an untouchable
  variable (in the case of ~c[temp-touchable-vars]) or as an untouchable
  function or macro (in the case of ~c[temp-touchable-fns]).  These two state
  global variables can be set by ~c[set-temp-touchable-vars] and
  ~c[set-temp-touchable-fns], respectively, provided there is an active trust
  tag (~pl[defttag]).  Here is an illustrative example.  This macro executes the
  indicated forms in a context where there are no untouchable variables, but
  requires an active trust tag when invoked.
  ~bv[]
  (defmacro with-all-touchable (&rest forms)
    `(progn!
      :state-global-bindings
      ((temp-touchable-vars t set-temp-touchable-vars))
      (progn! ,@forms)))
  ~ev[]
  An equivalent version, which however is not recommended since
  ~ilc[state-global-let*] may have surprising behavior in raw Lisp, is as
  follows.
  ~bv[]
  (defmacro with-all-touchable (&rest forms)
    `(progn!
      (state-global-let*
       ((temp-touchable-vars t set-temp-touchable-vars))
       (progn! ,@forms))))
  ~ev[]
  Finally, the value ~c[t] for ~c[temp-touchable-vars] removes the requirement
  that built-in state globals cannot be made unbound (with
  ~c[makunbound-global]).~/

  We now turn to the ~c[remove-untouchable] event, in case the approach above
  is for some reason not adequate.  This event is illegal by default, since it
  can be used to provide access to ACL2 internal functions and data structures
  that are intentionally made untouchable for the user.  If you want to call
  it, you must first create an active trust tag; ~pl[defttag].

  ~bv[]
  General Form:
  (remove-untouchable name{s}  fn-p :doc doc-string)
  ~ev[]
  where ~c[name{s}] is a non-~c[nil] symbol or a non-~c[nil] true list of symbols,
  ~c[fn-p] is any value (but generally ~c[nil] or ~c[t]), and ~ilc[doc-string]
  is an optional ~il[documentation] string not beginning with
  ``~c[:Doc-Section] ...''.  If ~c[name{s}] is a symbol it is treated as the
  singleton list containing that symbol.  The effect of this event is to remove
  the given symbols from the list of ``untouchable variables'' in the current
  world if ~c[fn-p] is ~c[nil], else to remove the symbols into the list of
  ``untouchable functions''.  This event is redundant if no symbol listed is a
  member of the appropriate untouchables list (variables or functions).~/"

  (declare (xargs :guard (and name
                              (or (symbolp name)
                                  (symbol-listp name))
                              (booleanp fn-p))))
  `(cond ((not (ttag (w state)))
          (er soft 'remove-untouchable
              "It is illegal to execute remove-untouchable when there is no ~
               active ttag; see :DOC defttag."))
         (t ,(list 'remove-untouchable-fn
                   (list 'quote name)
                   (list 'quote fn-p)
                   'state
                   (list 'quote doc)
                   (list 'quote event-form)))))

#+acl2-loop-only
(defmacro set-body (&whole event-form fn name-or-rune)

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

  ":Doc-Section Events

  set the definition body~/
  ~bv[]
  Examples:
  (set-body foo (:definition foo)) ; restore original definition of foo
  (set-body foo foo) ; same as just above
  (set-body foo my-foo-def) ; use my-foo-def for the body of foo
  (set-body foo (:definition my-foo-def)) ; same as just above
  ~ev[]
  Rules of class ~c[:]~ilc[definition] can install a new definition body, used
  for example by ~c[:expand] ~il[hints].  ~l[definition] and also ~pl[hints]
  for a detailed discussion of the ~c[:install-body] fields of
  ~c[:]~ilc[definition] rules and their role in ~c[:expand] hints.

  There may be several such definitions, but by default, the latest one is used
  by ~c[:expand] hints.  Although the ~c[:with] keyword may be used in
  ~c[:expand] hints to override this behavior locally (~pl[hints]), it may be
  convenient to install a definition for expansion other than the latest one
  ~-[] for example, the original definition.  ~c[Set-body] may be used for this
  purpose.

  ~bv[]
  General Form:
  (set-body function-symbol rule-name)
  ~ev[]
  where ~c[rule-name] is either a ~c[:definition] ~il[rune] or is a function
  symbol, ~c[sym], which represents the rune ~c[(:definition sym)].

  You can view all definitions available for expansion;
  ~pl[show-bodies].~/~/"

  `(set-body-fn ',fn ',name-or-rune state ',event-form))

#+acl2-loop-only
(defmacro table (&whole event-form name &rest args)

; Warning: See the Important Boot-Strapping Invariants before modifying!

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

  ":Doc-Section Events

  user-managed tables~/
  ~bv[]
  Examples:
  (table tests 1 '(...))                ; set contents of tests[1] to '(...)
  (table tests 25)                      ; get contents of tests[25]
  (table tests)                         ; return table tests as an alist
  (table tests nil nil :clear)          ; clear table tests
  (table tests nil '((foo . 7)) :clear) ; set table tests to ((foo . 7))
  (table tests nil nil :guard)          ; fetch the table guard
  (table tests nil nil :guard term)     ; set the table guard~/

  General Form:
  (table table-name key-term value-term op term)
  ~ev[]
  where ~c[table-name] is a symbol that is the name of a (possibly new)
  table, ~c[key-term] and ~c[value-term], if present, are arbitrary terms
  involving (at most) the single variable ~ilc[world], ~c[op], if present, is
  one of the table operations below, and ~c[term], if present, is a term.
  ~c[Table] returns an ACL2 ``error triple'' (~pl[error-triples]).  The effect
  of ~c[table] on ~ilc[state] depends on ~c[op] and how many arguments are
  presented.  Some invocations actually have no effect on the ACL2 ~il[world]
  and hence an invocation of ~c[table] is not always an ``event''.  We explain
  below, after giving some background information.

  ~b[Important Note:] The ~c[table] forms above are calls of a macro that
  expand to involve the special variable ~ilc[state].  This will prevent you
  from accessing a table from within a hint or theory where you do not have the
  ~ilc[state] variable.  However, the form
  ~bv[]
  (table-alist 'tests world)
  ~ev[]
  returns the alist representation of the table named ~c[test] in the
  given world.  Often you have access to ~c[world].

  The ACL2 system provides ``tables'' by which the user can associate
  one object with another.  Tables are in essence just conventional
  association lists ~-[] lists of pairs ~-[] but the ACL2 environment
  provides a means of storing these lists in the ``ACL2 world'' of the
  current ~ilc[state].  The ACL2 user could accomplish the same ends by
  using ACL2 ``global variables;'' however, limitations on global
  variable names are imposed to ensure ACL2's soundness.  By
  convention, no table is important to ACL2's soundness, even though
  some features of the system use tables, and the user is invited to
  make free use of tables.  Because tables are stored in the ACL2
  ~il[world] they are restored by ~ilc[include-book] and undone by ~c[:]~ilc[ubt].  Many
  users of Nqthm requested a facility by which user data could be
  saved in Nqthm ``lib files'' and tables are ACL2's answer to that
  request.

  Abstractly, each table is an association list mapping ``keys'' to
  ``values.'' In addition, each table has a ``~c[:guard],'' which is a
  term that must be true of any key and value used.  By setting the
  ~c[:guard] on a table you may enforce an invariant on the objects in the
  table, e.g., that all keys are positive integers and all values are
  symbols.  Each table has a ``name,'' which must be a symbol.  Given
  a table name, the following operations can be performed on the table.

  ~c[:put] ~-[] associate a value with a key (possibly changing the value
  currently associated with that key).

  ~c[:get] ~-[] retrieve the value associated with a key (or nil if no
  value has been associated with that key).

  ~c[:alist] ~-[] return an alist showing all keys and non-nil values in
  the table.

  ~c[:clear] ~-[] clear the table (so that every value is nil), or if val
  is supplied then set table to that value (which must be an alist).

  ~c[:guard] ~-[] fetch or set the :guard of the table.

  When the operations above suggest that the table or its ~c[:guard] are
  modified, what is actually meant is that the current ~il[state] is redefined
  so that in it, the affected table name has the appropriate properties.  in
  such cases, the ~c[table] form is an event (~pl[events]).  In the ~c[:put]
  case, if the key is already in the table and associated with the proposed
  value, then the ~c[table] event is redundant (~pl[redundant-events]).

  ~c[Table] forms are commonly typed by the user while interacting with
  the system.  ~c[:Put] and ~c[:get] forms are especially common.  Therefore,
  we have adopted a positional syntax that is intended to be
  convenient for most applications.  Essentially, some operations
  admit a ``short form'' of invocation.
  ~bv[]
  (table name key-term value-term :put)   ; long form
  (table name key-term value-term)        ; short form
  ~ev[]
  evaluates the key- and value-terms, obtaining two objects that we
  call ~c[key] and ~c[value], checks that the ~c[key] and ~c[value] satisfy the
  ~c[:guard] on the named table and then ``modifies'' the named table
  so that the value associated with ~c[key] is ~c[value].  When used like
  this, ~c[table] is actually an event in the sense that it changes the
  ACL2 ~il[world].  In general, the forms evaluated to obtain the ~c[key] and
  ~c[value] may involve the variable ~ilc[world], which is bound to the
  then-current ~il[world] during the evaluation of the forms.  However, in
  the special case that the table in question is named
  ~ilc[acl2-defaults-table], the ~c[key] and ~c[value] terms may not contain any
  variables.  Essentially, the keys and values used in ~il[events] setting
  the ~ilc[acl2-defaults-table] must be explicitly given constants.
  ~l[acl2-defaults-table].
  ~bv[]
  (table name key-term nil :get)          ; long form
  (table name key-term)                   ; short form
  ~ev[]
  evaluates the key-term (see note below), obtaining an object, ~c[key],
  and returns the value associated with ~c[key] in the named table (or,
  ~c[nil] if there is no value associated with ~c[key]).  When used like this,
  ~c[table] is not an event; the value is simply returned.
  ~bv[]
  (table name nil nil :alist)             ; long form
  (table name)                            ; short form
  ~ev[]
  returns an alist representing the named table; for every key in
  the table with a non-~c[nil] associated value, the alist pairs the key
  and its value.  The order in which the keys are presented is
  unspecified.  When used like this, ~c[table] is not an event; the alist
  is simply returned.
  ~bv[]
  (table name nil val :clear)
  ~ev[]
  sets the named table to the alist ~c[val], making the checks that ~c[:put]
  makes for each key and value of ~c[val].  When used like this, ~c[table] is
  an event because it changes the ACL2 ~il[world].
  ~bv[]
  (table name nil nil :guard)
  ~ev[]
  returns the translated form of the guard of the named table.
  ~bv[]
  (table name nil nil :guard term)
  ~ev[]
  Provided the named table is empty and has not yet been assigned a
  ~c[:guard] and ~c[term] (which is not evaluated) is a term that mentions at
  most the variables ~c[key], ~c[val] and ~ilc[world], this event sets the ~c[:guard] of
  the named table to ~c[term].  Whenever a subsequent ~c[:put] occurs, ~c[term]
  will be evaluated with ~c[key] bound to the key argument of the ~c[:put],
  ~c[val] bound to the ~c[val] argument of the ~c[:put], and ~ilc[world] bound to the
  then current ~il[world].  An error will be caused by the ~c[:put] if the
  result of the evaluation is ~c[nil].

  Note that it is not allowed to change the ~c[:guard] on a table once it
  has been explicitly set.  Before the ~c[:guard] is explicitly set, it is
  effectively just ~c[t].  After it is set it can be changed only by
  undoing the event that set it.  The purpose of this restriction is
  to prevent the user from changing the ~c[:guards] on tables provided by
  other people or the system.

  The intuition behind the ~c[:guard] mechanism on tables is to enforce
  invariants on the keys and values in a table, so that the values,
  say, can be used without run-time checking.  But if the ~c[:guard] of a
  table is sensitive to the ACL2 ~il[world], it may be possible to cause
  some value in the table to cease satisfying the ~c[:guard] without doing
  any operations on the table.  Consider for example the ~c[:guard] ``no
  value in this table is the name of an event.'' As described, that is
  enforced each time a value is stored.  Thus, ~c['bang] can be ~c[:put] in
  the table provided there is no event named ~c[bang].  But once it is in
  the table, there is nothing to prevent the user from defining ~c[bang]
  as a function, causing the table to contain a value that could not
  be ~c[:put] there anymore.  Observe that not all state-sensitive ~c[:guard]s
  suffer this problem.  The ~c[:guard] ``every value is an event name''
  remains invariant, courtesy of the fact that undoing back through an
  event name in the table would necessarily undo the ~c[:put] of the name
  into the table.

  ~c[Table] was designed primarily for convenient top-level use.  Tables
  are not especially efficient.  Each table is represented by an alist
  stored on the property list of the table name.  ~c[:Get] is just a
  ~c[getprop] and ~ilc[assoc-equal].  ~c[:Put] does a ~c[getprop] to the get the table
  alist, a ~c[put-assoc-equal] to record the new association, and a
  ~c[putprop] to store the new table alist ~-[] plus the overhead associated
  with ~c[:guard]s and undoable ~il[events], and checking (for redundancy) if
  the key is already bound to its proposed value.  Note that there are never
  duplicate keys in the resulting ~c[alist]; in particular, when the
  operation ~c[:clear] is used to install new ~c[alist], duplicate keys are
  removed from that alist.

  A table name may be any symbol whatsoever.  Symbols already in use
  as function or theorem names, for example, may be used as table
  names.  Symbols in use only as table names may be defined with
  ~ilc[defun], etc.  Because there are no restrictions on the user's choice
  of table names, table names are not included among the logical
  names.  Thus, ~c[:pe name] will never display a table event (for a
  logical name other than ~c[:here]).  Either ~c[:pe name] will display a
  ``normal'' event such as ~c[(defun name ...)] or ~c[(defthm name ...)] or
  else ~c[:pe name] will cause an error indicating that ~c[name] is not a
  logical name.  This happens even if ~c[name] is in use as a table name.
  Similarly, we do not permit table names to have ~il[documentation]
  strings, since the same name might already have a ~il[documentation]
  string.  If you want to associate a ~il[documentation] string with a
  table name that is being used no other way, define the name as a
  label and use the ~c[:]~ilc[doc] feature of ~ilc[deflabel]
  (~pl[deflabel]); also ~pl[defdoc].~/"

; At one time the table macro expanded to several different forms,
; depending on whether it was really expected to affect world.  That
; was abandoned when it was actually included in the source files
; because of the important invariant that these defmacros be
; translatable by boot-translate.

; Warning: See the Important Boot-Strapping Invariants before modifying!

  (list 'table-fn
        (list 'quote name)
        (list 'quote args)
        'state
        (list 'quote event-form)))

#+acl2-loop-only
(defmacro encapsulate (&whole event-form signatures &rest cmd-lst)

; Warning: See the Important Boot-Strapping Invariants before modifying!

  ":Doc-Section Events

  hide some ~il[events] and/or constrain some functions~/

  ~c[Encapsulate] provides a way to execute a sequence of ~il[events] and then
  hide some of the resulting effects.  There are two kinds of encapsulations:
  ``trivial'' and ``non-trivial''.  We discuss these briefly before providing
  detailed ~il[documentation].

  A trivial encapsulation is an event of the following form.
  ~bv[]
  (encapsulate
   () ; nil here indicates \"trivial\"
   <event-1>
   ...
   <event-k>)
  ~ev[]
  We use the term ``sub-events'' to refer to ~c[<event-1>] through
  ~c[<event-k>].  Each sub-event ~c[<event-i>] may be ``~il[local]'', that is,
  of the form ~c[(local <event-i'>)]; the other sub-events are called
  ``non-local''.  When this ~c[encapsulate] form is submitted to ACL2, it is
  processed in two passes.  On the first pass, each sub-event is processed in
  sequence; admission of the ~c[encapsulate] fails if any ~c[<event-i>] fails
  to be admitted.  Then a second pass is made after rolling back the logical
  ~il[world] to what it was just before executing the ~c[encapsulate] form.  In
  the second pass, only the non-~il[local] forms ~c[<event-i>] are evaluated,
  again in order, and proofs are skipped.

  For example, the following trivial encapsulation exports a single event,
  ~c[member-equal-reverse].  The lemma ~c[member-revappend] is used (as a
  ~il[rewrite] rule) to prove ~c[member-equal-reverse] on the first pass, but
  since ~c[member-revappend] is ~il[local], it is ignored on the second (final)
  pass.
  ~bv[]
  (encapsulate
   ()

   (local
    (defthm member-revappend
      (iff (member-equal a (revappend x y))
           (or (member-equal a x)
               (member-equal a y)))
      :hints ((\"Goal\" :induct (revappend x y)))))

   (defthm member-equal-reverse
     (iff (member-equal a (reverse x))
          (member-equal a x))))
  ~ev[]
  Of course, one might prefer to prove these ~il[events] at the top level,
  rather than within an encapsulation; but the point here is to illustrate that
  you can have ~il[local] ~il[events] that do not become part of the logical
  ~il[world].  (Such a capability is also provided at the level of ~il[books];
  in particular, ~pl[include-book].)

  On the other hand, non-trivial encapsulations provide a way to introduce
  axioms about new function symbols, without introducing inconsistency and
  without introducing complete definitions.  The following example illustrates
  how that works.
  ~bv[]
  (encapsulate

  ; The following list has a single signature, introducing a function foo of
  ; one argument that returns one value.  (The list is non-empty, so we call
  ; this a \"non-trivial\" encapsulation.)
   ( ((foo *) => *) )

  ; Introduce a ``witness'' (example) for foo, marked as local so that
  ; it is not exported:
   (local (defun foo (x) x))

  ; Introduce a non-local property to be exported:
   (defthm foo-preserves-consp
     (implies (consp x)
              (consp (foo x))))
  )
  ~ev[]
  The form above introduces a new function symbol, ~c[foo], with the indicated
  property and no definition.  In fact, the output from ACL2 concludes as
  follows.
  ~bv[]

  The following constraint is associated with the function FOO:

  (IMPLIES (CONSP X) (CONSP (FOO X)))
  ~ev[]
  To understand this example, we consider how non-trivial encapsulations are
  processed.  The same two passes are made as for trivial encapsulations, and
  the (~il[local]) definition of ~c[foo] is ignored on the second pass, and
  hence does not appear in the resulting ACL2 logical ~il[world].  But before
  the second pass, each ~il[signature] is stored in the ~il[world].  Thus, when
  the theorem ~c[foo-preserves-consp] is encountered in the second pass,
  ~c[foo] is a known function symbol with the indicated signature.

  We turn now to more complete documentation.  But discussion of redundancy for
  ~c[encapsulate] events may be found elsewhere; ~pl[redundant-encapsulate].

  ~bv[]
  Other Examples:
  (encapsulate (((an-element *) => *))

  ; The list of signatures above could also be written
  ;            ((an-element (lst) t))

    (local (defun an-element (lst)
             (if (consp lst) (car lst) nil)))
    (local (defthm member-equal-car
              (implies (and lst (true-listp lst))
                       (member-equal (car lst) lst))))
    (defthm thm1
       (implies (null lst) (null (an-element lst))))
    (defthm thm2
       (implies (and (true-listp lst)
                     (not (null lst)))
                (member-equal (an-element lst) lst))))

  (encapsulate
   () ; empty signature: no constrained functions indicated

   (local (defthm hack
            (implies (and (syntaxp (quotep x))
                          (syntaxp (quotep y)))
                     (equal (+ x y z)
                            (+ (+ x y) z)))))

   (defthm nthcdr-add1-conditional
     (implies (not (zp (1+ n)))
              (equal (nthcdr (1+ n) x)
                     (nthcdr n (cdr x))))))~/

  General Form:
  (encapsulate (signature ... signature)
    ev1
    ...
    evn)
  ~ev[]
  where each ~ilc[signature] is a well-formed signature, each ~c[signature]
  describes a different function symbol, and each ~c[evi] is an embedded event
  form (~l[embedded-event-form]).  Also ~pl[signature], in particular for a
  discussion of how a signature can assign a ~il[guard] to a function symbol.
  There must be at least one ~c[evi].  The ~c[evi] inside ~ilc[local] special
  forms are called ``local'' ~il[events] below.  ~il[Events] that are not
  ~ilc[local] are sometimes said to be ``exported'' by the encapsulation.  We
  make the further restriction that no ~ilc[defaxiom] event may be introduced
  in the scope of an ~c[encapsulate] (not even by ~c[encapsulate] or
  ~ilc[include-book] events that are among the ~c[evi]).  Furthermore, no
  non-~ilc[local] ~ilc[include-book] event is permitted in the scope of any
  ~c[encapsulate] with a non-empty list of signatures.

  To be well-formed, an ~c[encapsulate] event must have the properties that
  each event in the body (including the ~ilc[local] ones) can be successfully
  executed in sequence and that in the resulting theory, each function
  mentioned among the ~il[signature]s was introduced via a ~ilc[local] event
  and has the ~il[signature] listed.  (A utility is provided to assist in
  debugging failures of such execution; ~pl[redo-flat].)  In addition, the body
  may contain no ``local incompatibilities'' which, roughly stated, means that
  the ~il[events] that are not ~ilc[local] must not syntactically require
  symbols defined by ~ilc[local] ~ilc[events], except for the functions listed
  in the ~il[signature]s.  ~l[local-incompatibility].  Finally, no
  non-~ilc[local] recursive definition in the body may involve in its suggested
  induction scheme any function symbol listed among the ~il[signature]s.
  ~l[subversive-recursions].

  Observe that if the ~il[signature]s list is empty, the resulting ``trivial''
  ~c[encapsulate] may still be useful for deriving theorems to be exported
  whose proofs require lemmas you prefer to hide (i.e., made ~ilc[local]).
  Whether trivial or not (i.e., whether the signature is empty or not),
  ~c[encapsulate] exports the results of evaluating its non-~ilc[local]
  ~il[events], but its ~ilc[local] ~il[events] are ignored for the resulting
  logical ~il[world].

  The result of a non-trivial ~c[encapsulate] event is an extension of the
  logic in which, roughly speaking, the functions listed in the ~il[signature]s
  are constrained to have the ~il[signature]s listed and to satisfy the
  non-~ilc[local] theorems proved about them.  In fact, other functions
  introduced in the ~c[encapsulate] event may be considered to have
  ``~il[constraint]s'' as well.  (~l[constraint] for details, which are only
  relevant to functional instantiation.)  Since the ~il[constraint]s were all
  theorems in the ``ephemeral'' or ``local'' theory, we are assured that the
  extension produced by ~c[encapsulate] is sound.  In essence, the ~ilc[local]
  definitions of the constrained functions are just ``witness functions'' that
  establish the consistency of the ~il[constraint]s.  Because those definitions
  are ~ilc[local], they are not present in the theory produced by
  encapsulation.  After a non-trivial ~c[encapsulate] event is admitted,
  theorems about the constrained function symbols may then be proved ~-[]
  theorems whose proofs necessarily employ only the ~il[constraint]s.  Thus,
  those theorems may be later functionally instantiated, as with the
  ~c[:functional-instance] lemma instance (~pl[lemma-instance]), to derive
  analogous theorems about different functions, provided the
  constraints (~pl[constraint]) can be proved about the new functions.

  The ~il[default-defun-mode] for the first event in an encapsulation is
  the default ~il[defun-mode] ``outside'' the encapsulation.  But since
  ~il[events] changing the ~il[defun-mode] are permitted within the body of an
  ~c[encapsulate], the default ~il[defun-mode] may be changed.  However,
  ~il[defun-mode] changes occurring within the body of the ~c[encapsulate]
  are not exported.  In particular, the ~ilc[acl2-defaults-table] after
  an ~c[encapsulate] is always the same as it was before the
  ~c[encapsulate], even though the ~c[encapsulate] body might contain
  ~il[defun-mode] changing ~il[events], ~c[:]~ilc[program] and ~c[:]~ilc[logic].
  ~l[defun-mode].  More generally, after execution of an
  ~c[encapsulate] event, the value of ~ilc[acl2-defaults-table] is
  restored to what it was immediately before that event was executed.
  ~l[acl2-defaults-table].

  We make some remarks on ~il[guard]s and evaluation.  Calls of functions
  introduced in the ~il[signature]s list cannot be evaluated in the ACL2
  read-eval-print loop.  ~l[defattach] for a way to overcome this limitation.
  Moreover, any ~c[:]~ilc[guard] supplied in the signature is automatically
  associated in the ~il[world] with its corresponding function symbol, with no
  requirement other than that the guard is a legal term all of whose function
  symbols are in ~c[:]~ilc[logic] mode with their ~il[guard]s verified.  In
  particular, there need not be any relationship between a guard in a signature
  and the guard in a ~c[local] witness function.  Finally, note that for
  functions introduced non-~il[local]ly inside a non-trivial ~c[encapsulate]
  event, ~il[guard] verification is illegal unless ACL2 determines that the
  proof obligations hold outside the ~ilc[encapsulate] event as well.
  ~bv[]
  (encapsulate
   ((f (x) t))
   (local (defun f (x) (declare (xargs :guard t)) (consp x)))
   ;; ERROR!
   (defun g (x)
     (declare (xargs :guard (f x)))
     (car x)))
  ~ev[]

  The order of the ~il[events] in the vicinity of an ~c[encapsulate] is
  confusing.  We discuss it in some detail here because when logical names are
  being used with theory functions to compute sets of rules, it is sometimes
  important to know the order in which ~il[events] were executed.
  (~l[logical-name] and ~pl[theory-functions].)  What, for example, is the set
  of function names extant in the middle of an encapsulation?

  If the most recent event is ~c[previous] and then you execute an
  ~c[encapsulate] constraining ~c[an-element] with two non-~ilc[local]
  ~il[events] in its body, ~c[thm1] and ~c[thm2], then the order of the
  ~il[events] after the encapsulation is (reading chronologically forward):
  ~c[previous], ~c[thm1], ~c[thm2], ~c[an-element] (the ~c[encapsulate]
  itself).  Actually, between ~c[previous] and ~c[thm1] certain extensions were
  made to the ~il[world] by the superior ~c[encapsulate], to permit
  ~c[an-element] to be used as a function symbol in ~c[thm1].

  Remark for ACL2(r) (~pl[real]).  For ACL2(r), ~ilc[encapsulate] can be used
  to introduce classical and non-classical functions, as determined by the
  signatures; ~pl[signature].  Those marked as classical (respectively
  non-classical) must have classical (respectively, non-classical) ~ilc[local]
  witness functions.  A related requirement applies to functional
  instantiation; ~pl[lemma-instance].~/"

; Warning: See the Important Boot-Strapping Invariants before modifying!

  (list 'encapsulate-fn
        (list 'quote signatures)
        (list 'quote cmd-lst)
        'state
        (list 'quote event-form)))

(defdoc redundant-encapsulate
  ":Doc-Section encapsulate

  redundancy of ~ilc[encapsulate] ~il[events]~/

  For this ~il[documentation] topic we assume familiarity with ~c[encapsulate]
  events and the notion of redundancy for ~il[events]; ~pl[encapsulate] and
  ~pl[redundant-events].

  The typical way for an ~c[encapsulate] event to be redundant is when a
  syntactically identical ~c[encapsulate] has already been executed under the
  same ~ilc[default-defun-mode], ~ilc[default-ruler-extenders], and
  ~ilc[default-verify-guards-eagerness].  But more generally, the
  ~c[encapsulate] events need not be syntactically identical; for example, it
  suffices that they agree when the contents of ~ilc[local] sub-events are
  ignored.  The precise criterion for redundancy is given below, but let us
  first look at a consequence of the point just made about ignoring the
  contents of ~ilc[local] sub-events.  Consider the following sequence of two
  events.
  ~bv[]
  (encapsulate
   ()
   (defun f (x) x)
   (local (defthm f-identity
            (equal (f x) x))))

  (encapsulate
   ()
   (defun f (x) x)
   (local (defthm false-claim
            (equal (f x) (not x)))))
  ~ev[]
  You might be surprised to learn that the second is actually redundant, even
  though ~c[false-claim] is clearly not a theorem; indeed, its negation is a
  theorem!  The following two points may soften the blow.  First, this behavior
  is as specified above (and is specified more precisely below): the contents
  of ~il[local] events are ignored when checking redundancy of
  ~ilc[encapsulate] events.  Second, this behavior is sound, because the
  logical meaning of an ~ilc[encapsulate] event is taken from the events that
  it exports, which do not include events that are ~il[local] to the
  ~c[encapsulate] event.

  Some users, however, want to use ~ilc[encapsulate] events for testing in a
  way that is thwarted by this ignoring of ~il[local] sub-events.  Consider
  the following sort of example.
  ~bv[]
  (encapsulate ()
               (local (defthm test1 ...)))

  (encapsulate ()
               (local (defthm test2 ...)))
  ~ev[]
  Since the contents of local events are ignored when checking redundancy of an
  ~c[encapsulate] event, the second form just above is indeed redundant,
  presumably not as expected by whomever wrote these two tests.  A solution is
  to add distinct non-local forms, for example as follows.
  ~bv[]
  (encapsulate ()
               (value-triple \"test1\")
               (local (defthm test1 ...)))

  (encapsulate ()
               (value-triple \"test2\")
               (local (defthm test2 ...)))
  ~ev[]
  A different solution is to use ~ilc[make-event] for testing, as follows.
  ~bv[]
  (make-event (er-progn (defthm test1 ...)
                        (value '(value-triple nil))))
  (make-event (er-progn (defthm test2 ...)
                        (value '(value-triple nil))))
  ~ev[]
  Also see community books ~c[misc/eval.lisp], ~c[make-event/eval-check.lisp],
  and ~c[make-event/eval-tests.lisp] for more ways to test in books.

  The precise criterion for redundancy of ~ilc[encapsulate] ~il[events] is that
  the existing and proposed ~c[encapsulate] events contain the same signatures
  and the same number of top-level events ~-[] let ~c[k] be that number ~-[]
  and for each ~c[i < k], the ~c[i]th top-level events ~c[E1] and ~c[E2] from
  the earlier and current ~c[encapsulate]s have one of the following
  properties.

  o ~c[E1] and ~c[E2] are equal; or

  o ~c[E1] is of the form ~c[(record-expansion E2 ...)]; or else

  o ~c[E1] and ~c[E2] are equal after replacing each ~ilc[local] sub-event by
  ~c[(local (value-triple :elided))], where a sub-event of an event ~c[E] is
  either ~c[E] itself, or a sub-event of a constituent event of ~c[E] in the
  case that ~c[E] is a call of ~ilc[with-output], ~ilc[with-prover-time-limit],
  ~ilc[with-prover-step-limit], ~c[record-expansion], ~ilc[time$], ~ilc[progn],
  ~ilc[progn!], or ~c[encapsulate] itself.~/~/")

(defconst *load-compiled-file-values*
  '(t nil :warn :default :comp))

#+acl2-loop-only
(defmacro include-book (&whole event-form user-book-name
                               &key

; Warning:  If you change the defaults below, be sure to change the
; construction of event-form in include-book-fn!

                               (load-compiled-file ':default)
                               (uncertified-okp 't)
                               (defaxioms-okp 't)
                               (skip-proofs-okp 't)
                               (ttags ':default)
                               dir
                               doc)

; Warning: See the Important Boot-Strapping Invariants before modifying!

  (declare (xargs :guard
                  (member-eq load-compiled-file *load-compiled-file-values*)))

  ":Doc-Section Events

  load the ~il[events] in a file~/
  ~bv[]
  Examples:
  (include-book \"my-arith\")
  (include-book \"/home/smith/my-arith\")
  (include-book \"/../../my-arith\")

  General Form:
  (include-book file :load-compiled-file action
                     :uncertified-okp t/nil      ; [default t]
                     :defaxioms-okp t/nil        ; [default t]
                     :skip-proofs-okp t/nil      ; [default t]
                     :ttags ttags                ; [default nil]
                     :dir directory
                     :doc doc-string)
  ~ev[]
  where ~c[file] is a book name.  ~l[books] for general information,
  ~pl[book-name] for information about book names, and ~pl[pathname] for
  information about file names.  ~c[Action] is one of ~c[t], ~c[nil],
  ~c[:default], ~c[:warn], or ~c[:comp]; these values are explained below, and
  the default is ~c[:default].  The three ~c[-okp] keyword arguments, which
  default to ~c[t], determine whether errors or warnings are generated under
  certain conditions explained below; when the argument is ~c[t], warnings are
  generated.  The ~c[dir] argument, if supplied, is a keyword that represents
  an absolute pathname for a directory (~pl[pathname]), to be used instead of
  the current book directory (~pl[cbd]) for resolving the given ~c[file]
  argument to an absolute pathname.  In particular, by default ~c[:dir :system]
  resolves ~c[file] using the ~c[books/] directory of your ACL2 installation,
  unless your ACL2 executable was built somewhere other than where it currently
  resides; please see the ``Books Directory'' below.  To define other keywords
  that can be used for ~c[dir], ~pl[add-include-book-dir].  ~c[Doc-string] is
  an optional ~il[documentation] string; ~pl[doc-string].  If the book has no
  ~ilc[certificate], if its ~ilc[certificate] is invalid or if the certificate
  was produced by a different ~il[version] of ACL2, a warning is printed and
  the book is included anyway; ~pl[certificate].  This can lead to serious
  errors, perhaps mitigated by the presence of a ~c[.port] file from an earlier
  certification; ~pl[uncertified-books].  If the portcullis of the
  ~il[certificate] (~pl[portcullis]) cannot be raised in the host logical
  ~il[world], an error is caused and no change occurs to the logic.  Otherwise,
  the non-~ilc[local] ~il[events] in file are assumed.  Then the ~il[keep] of
  the ~il[certificate] is checked to ensure that the correct files were read;
  ~pl[keep].  A warning is printed if uncertified ~il[books] were included.
  Even if no warning is printed, ~c[include-book] places a burden on you;
  ~pl[certificate].

  If you use ~il[guard]s, please note ~c[include-book] is executed as though
  ~c[(set-guard-checking nil)] has been evaluated; ~Pl[set-guard-checking].  If
  you want guards checked, please ~pl[ld] and/or ~pl[rebuild].

  The value of ~c[:load-compiled-file] controls whether a compiled file for the
  given ~c[file] is loaded by ~c[include-book].  Note that this keyword applies
  only to the given ~c[file], not to any included sub-books.  In order to skip
  loading all compiled files, for the given ~c[file] as well as all included
  sub-books ~-[] for example, to avoid Lisp errors such as ``Wrong FASL
  version'' ~-[] use ~c[(set-compiler-enabled nil state)]; ~pl[compilation].
  Otherwise, if keyword argument ~c[:load-compiled-file] is missing or its
  value is the keyword ~c[:default], then it is treated as ~c[:warn].  If its
  value is ~c[nil], no attempt is made to load the compiled file for the book
  provided.  In order to load the compiled file, it must be more recent than
  the book's ~il[certificate] (except in raw mode, where it must be more recent
  than the book itself; ~pl[set-raw-mode]).  For non-~c[nil] values of
  ~c[:load-compiled-file] that do not result in a loaded compiled file, ACL2
  proceeds as follows.  Note that a load of a compiled file or expansion file
  aborts partway through whenever an ~ilc[include-book] form is encountered for
  which no suitable compiled or expansion file can be loaded.  For much more
  detail, ~pl[book-compiled-file].
  ~bq[]

  ~c[t]: Cause an error if the compiled file is not loaded.  This same
  requirement is imposed on every ~ilc[include-book] form evaluated during the
  course of evaluation of the present ~c[include-book] form, except that for
  those subsidiary ~c[include-book]s that do not themselves specify
  ~c[:load-compiled-file t], it suffices to load the expansion file
  (~pl[book-compiled-file]).

  ~c[:warn]: An attempt is made to load the compiled file, and a warning is
  printed if that load fails to run to completion.

  ~c[:comp]: A compiled file is loaded as with value ~c[t], except that if a
  suitable ``expansion file'' exists but the compiled file does not, then the
  compiled file is first created.  ~l[book-compiled-file].~eq[]

  The three ~c[-okp] arguments, ~c[:uncertified-okp], ~c[defaxioms-okp],
  and ~c[skip-proofs-okp], determine the system's behavior when
  the book or any subbook is found to be uncertified, when the book
  or any subbook is found to contain ~ilc[defaxiom] events, and when
  the book or any subbook is found to contain ~ilc[skip-proofs] events,
  respectively.  All three default to ~c[t], which means it is ``ok''
  for the condition to arise.  In this case, a warning is printed but
  the processing to load the book is allowed to proceed.  When one of
  these arguments is ~c[nil] and the corresponding condition arises,
  an error is signaled and processing is aborted.  ~st[Exception]:
  ~c[:uncertified-okp] is ignored if the ~c[include-book] is being
  performed on behalf of a ~ilc[certify-book].

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

  ~c[Include-book] is similar in spirit to ~ilc[encapsulate] in that it is
  a single event that ``contains'' other ~il[events], in this case the
  ~il[events] listed in the file named.  ~c[Include-book] processes the
  non-~ilc[local] event forms in the file, assuming that each is
  admissible.  ~ilc[Local] ~il[events] in the file are ignored.  You may
  use ~c[include-book] to load several ~il[books], creating the logical
  ~il[world] that contains the definitions and theorems of all of
  them.

  If any non-~ilc[local] event of the book attempts to define a ~il[name]
  that has already been defined ~-[] and the book's definition is not
  syntactically identical to the existing definition ~-[] the attempt to
  include the book fails, an error message is printed, and no change
  to the logical ~il[world] occurs.  ~l[redundant-events] for the
  details.

  When a book is included, the default ~il[defun-mode]
  (~pl[default-defun-mode]) for the first event is always ~c[:]~ilc[logic].
  That is, the default ~il[defun-mode] ``outside'' the book ~-[] in the
  environment in which ~c[include-book] was called ~-[] is irrelevant to the
  book.  ~il[Events] that change the ~il[defun-mode] are permitted within a
  book (provided they are not in ~ilc[local] forms).  However, such changes
  within a book are not exported, i.e., at the conclusion of an
  ~c[include-book], the ``outside'' default ~il[defun-mode] is always the same
  as it was before the ~c[include-book].

  Unlike every other event in ACL2, ~c[include-book] puts a burden on
  you.  Used improperly, ~c[include-book] can be unsound in the sense
  that it can create an inconsistent extension of a consistent logical
  ~il[world].  A certification mechanism is available to help you
  carry this burden ~-[] but it must be understood up front that even
  certification is no guarantee against inconsistency here.  The
  fundamental problem is one of file system security.
  ~l[certificate] for a discussion of the security issues.

  At the beginning of execution of an ~c[include-book] form, even before
  executing ~il[portcullis] ~il[command]s, the value of
  ~ilc[acl2-defaults-table] is restored to the value it had at startup.  After
  execution of an ~c[include-book] form, the value of ~ilc[acl2-defaults-table]
  is restored to what it was immediately before that ~c[include-book] form was
  executed.  ~l[acl2-defaults-table].

  ~b[Books Directory.]  We refer to the ``books directory'' of an executable
  image as the full pathname string of the directory associated with
  ~c[include-book] keyword option ~c[:dir :system] for that image.  By default,
  it is the ~c[books/] subdirectory of the directory where the sources reside
  and the executable image is thus built (except for ACL2(r) ~-[] ~pl[real]
  ~-[], where it is ~c[books/nonstd/]).  If those books reside elsewhere, the
  environment variable ~c[ACL2_SYSTEM_BOOKS] can be set to the ~c[books/]
  directory under which they reside (a Unix-style pathname, typically ending in
  ~c[books/] or ~c[books], is permissible).  In most cases, your ACL2
  executable is a small script in which you can set this environment variable
  just above the line on which the actual ACL2 image is invoked, for example:
  ~bv[]
  export ACL2_SYSTEM_BOOKS
  ACL2_SYSTEM_BOOKS=/home/acl2/4-0/acl2-sources/books
  ~ev[]
  If you follow suggestions in the installation instructions, these books will
  be the ACL2 community books; ~pl[community-books].

  This concludes the guided tour through ~il[books].  ~l[set-compile-fns] for a
  subtle point about the interaction between ~c[include-book] and on-the-fly
  ~il[compilation].  ~l[certify-book] for a discussion of how to certify a
  book.~/

  :cited-by Programming"

; Warning: See the Important Boot-Strapping Invariants before modifying!

  (list 'include-book-fn
        (list 'quote user-book-name)
        'state
        (list 'quote load-compiled-file)
        (list 'quote :none)
        (list 'quote uncertified-okp)
        (list 'quote defaxioms-okp)
        (list 'quote skip-proofs-okp)
        (list 'quote ttags)
        (list 'quote doc)
        (list 'quote dir)
        (list 'quote event-form)))

#+acl2-loop-only
(defmacro make-event (&whole event-form
                             form
                             &key
                             expansion? check-expansion on-behalf-of)

; Essay on Make-event

; This essay incorporates by reference :doc make-event and :doc
; make-event-details.  That is, one should start by reading those documentation
; topics.  This is a place to add details that seem of interest only to the
; implementors, not to ACL2 users.

; When we lay down a command landmark for a command for which expansion has
; taken place, we need to record that expansion somehow for subsequent calls of
; certify-book, in order to recover portcullis commands.  Thus,
; add-command-landmark and make-command-tuple have an argument for the
; expansion (which could be nil, indicating that no expansion took place).

; We use record-expansion (as described in :doc make-event-details) in order to
; support redundancy of encapsulate, as implemented by redundant-encapsulatep
; and its subroutines.  Here is a summary of the issue.  Consider: (encapsulate
; ((foo (x) t)) ... (make-event <form>)).  We have several goals.
; + Be able to execute this form a second time and have it be redundant.
; + If this form is redundant yet in a book, it cannot cause a new expansion
;   result for the make-event or the encapsulate, and include-book has to do
;   the right thing even, if possible, in raw mode.
; + We want to store a proper expansion of an encapsulate.
; + We want to recognize redundancy without having to execute the encapsulate.
; + If an encapsulate form is redundant then its stored version is identical
;   to the stored version of the earlier form for which it is redundant.
; The last of these properties is important because otherwise unsoundness could
; result!  Suppose for example that a book bar.lisp contains (local
; (include-book "foo")), where foo.lisp contains an encapsulate that causes a
; later encapsulate in bar.lisp to be redundant.  What should we know at the
; point we see the later encapsulate?  We should know that the event logically
; represented by the encapsulate is the same as the one logically represented
; by the earlier encapsulate, so we certainly do not want to re-do its
; expansion at include-book time.  Thus, when an encapsulate is redundant, we
; store the expanded version of the earlier encapsulate as the expansion of the
; current unexpanded encapsulate, unless the two are identical.  But how do we
; expand a non-redundant encapsulate?  We expand it by replacing every
; sub-event ev by (record-expansion ev exp), when ev has an expansion exp.
; Then, we recognize a subsequent encapsulate as redundant with this one if
; their signatures are equal and each of the subsequent encapsulate's events,
; ev2, is either the same as the corresponding event ev1 of the old encapsulate
; or else ev1 is of the form (record-expansion ev2 ...).

; We elide local forms arising from make-event expansions when writing to book
; certificates, in order to save space.  See elide-locals.

; Note that when :puff (specifically puff-command-block) is applied to an
; include-book form, it uses the expansion-alist from the book's certificate if
; there is an up-to-date certificate.

 ":Doc-Section Events

  evaluate (expand) a given form and then evaluate the result~/

  ~c[Make-event] is a utility for generating ~il[events].  It provides a
  capability not offered by Lisp macros (~pl[defmacro]), as it allows access to
  the ACL2 ~ilc[state] and logical ~il[world].  In essence, the expression
  ~c[(make-event form)] replaces itself with the result of evaluating ~c[form],
  say, ~c[ev], as though one had submitted ~c[ev] instead of the ~c[make-event]
  call.  For example, ~c[(make-event (quote (defun f (x) x)))] is equivalent to
  the event ~c[(defun f (x) x)].

  We break this documentation into the following sections.

  ~st[Introduction]~nl[]
  ~st[Detailed Documentation]~nl[]
  ~st[Error Reporting]~nl[]
  ~st[Restriction to Event Contexts]~nl[]
  ~st[Examples Illustrating How to Access State]~nl[]
  ~st[Advanced Expansion Control]

  We begin with an informal introduction, which focuses on examples and
  introduces the key notion of ``expansion phase''.

  ~st[Introduction]

  ~c[Make-event] is particularly useful for those who program using the ACL2
  ~ilc[state]; ~pl[programming-with-state].  That is because the evaluation of
  ~c[form] may read and even modify the ACL2 ~ilc[state].

  Suppose for example that we want to define a constant ~c[*world-length*],
  that is the length of the current ACL2 ~il[world].  A ~c[make-event] form can
  accomplish this task, as follows.
  ~bv[]
    ACL2 !>(length (w state))
    98883
    ACL2 !>(make-event
            (list 'defconst '*world-length* (length (w state))))

    Summary
    Form:  ( DEFCONST *WORLD-LENGTH* ...)
    Rules: NIL
    Time:  0.00 seconds (prove: 0.00, print: 0.00, other: 0.00)

    Summary
    Form:  ( MAKE-EVENT (LIST ...))
    Rules: NIL
    Time:  0.01 seconds (prove: 0.00, print: 0.00, other: 0.01)
     *WORLD-LENGTH*
    ACL2 !>*world-length*
    98883
    ACL2 !>(length (w state))
    98890
    ACL2 !>
  ~ev[]
  How did this work?  First, evaluation of the form
  ~c[(list 'defconst '*world-length* (length (w state)))] returned the event
  form ~c[(defconst *world-length* 98883)].  Then that event form was
  automatically submitted to ACL2.  Of course, that changed the ACL2 logical
  ~il[world], which is why the final value of ~c[(length (w state))] is greater
  than its initial value.

  The example above illustrates how the evaluation of a ~c[make-event] call
  takes place in two phases.  The first phase evaluates the argument of the
  call, in this case ~c[(list 'defconst '*world-length* (length (w state)))],
  to compute an event form, in this case ~c[(defconst *world-length* 98883)].
  We call this evaluation the ``expansion'' phase.  Then the resulting event
  form is evaluated, which in this case defines the constant
  ~c[*world-length*].

  Now suppose we would like to introduce such a ~ilc[defconst] form any time we
  like.  It is common practice to define macros to automate such tasks.  Now we
  might be tempted simply to make the following definition.
  ~bv[]
  ; WRONG!
  (defmacro define-world-length-constant (name state)
    (list 'defconst name (length (w state))))
  ~ev[]
  But ACL2 rejects such a definition, because a macro cannot take the ACL2
  state as a parameter; instead, the formal parameter to this macro named
  ~c[\"STATE\"] merely represents an ordinary object.  You can try to
  experiment with other such direct methods to define such a macro, but they
  won't work.

  Instead, however, you can use the approach illustrated by the ~c[make-event]
  example above to define the desired macro, as follows.
  ~bv[]
  (defmacro define-world-length-constant (name)
    `(make-event (list 'defconst ',name (length (w state)))))
  ~ev[]
  Here are example uses of this macro.
  ~bv[]
    ACL2 !>(define-world-length-constant *foo*)

    Summary
    Form:  ( DEFCONST *FOO* ...)
    Rules: NIL
    Time:  0.00 seconds (prove: 0.00, print: 0.00, other: 0.00)

    Summary
    Form:  ( MAKE-EVENT (LIST ...))
    Rules: NIL
    Time:  0.00 seconds (prove: 0.00, print: 0.00, other: 0.00)
     *FOO*
    ACL2 !>*foo*
    98891
    ACL2 !>:pe *foo*
              2:x(DEFINE-WORLD-LENGTH-CONSTANT *FOO*)
                 \
    >             (DEFCONST *FOO* 98891)
    ACL2 !>(length (w state))
    98897
    ACL2 !>(define-world-length-constant *bar*)

    Summary
    Form:  ( DEFCONST *BAR* ...)
    Rules: NIL
    Time:  0.00 seconds (prove: 0.00, print: 0.00, other: 0.00)

    Summary
    Form:  ( MAKE-EVENT (LIST ...))
    Rules: NIL
    Time:  0.01 seconds (prove: 0.00, print: 0.00, other: 0.01)
     *BAR*
    ACL2 !>*bar*
    98897
    ACL2 !>:pe *bar*
              3:x(DEFINE-WORLD-LENGTH-CONSTANT *BAR*)
                 \
    >             (DEFCONST *BAR* 98897)
    ACL2 !>(length (w state))
    98903
    ACL2 !>
  ~ev[]

  Finally, we note that the expansion phase can be used for computation that
  has side effects, generally by modifying state.  Here is a modification of
  the above example that does not change the world at all, but instead saves
  the length of the world in a state global.
  ~bv[]
  (make-event
   (pprogn (f-put-global 'my-world-length (length (w state)) state)
           (value '(value-triple nil))))
  ~ev[]
  Notice that this time, the value returned by the expansion phase is not an
  event form, but rather, is an error triple (~pl[error-triples]) whose value
  component is an event form, namely, the event form ~c[(value-triple nil)].
  Evaluation of that event form does not change the ACL2 world
  (~pl[value-triple]).  Thus, the sole purpose of the ~c[make-event] call above
  is to change the ~il[state] by associating the length of the current logical
  world with the state global named ~c['my-world-length].  After evaluating
  this form, ~c[(@ my-world-length)] provides the length of the ACL2 world, as
  illustrated by the following transcript.
  ~bv[]
    ACL2 !>:pbt 0
              0:x(EXIT-BOOT-STRAP-MODE)
    ACL2 !>(length (w state))
    98883
    ACL2 !>(make-event
            (pprogn (f-put-global 'my-world-length (length (w state)) state)
                    (value '(value-triple nil))))

    Summary
    Form:  ( MAKE-EVENT (PPROGN ...))
    Rules: NIL
    Time:  0.01 seconds (prove: 0.00, print: 0.00, other: 0.01)
     NIL
    ACL2 !>(length (w state))
    98883
    ACL2 !>:pbt 0
              0:x(EXIT-BOOT-STRAP-MODE)
    ACL2 !>
  ~ev[]

  When ~c[make-event] is invoked by a book, it is expanded during book
  certification but not, by default, when the book is included.  So for the
  example ~c[(define-world-length-constant *foo*)] given above, if that form is
  in a book, then the value of ~c[*foo*] will be the length of the world at the
  time this form was invoked during book certification, regardless of world
  length at ~ilc[include-book] time.  (The expansion is recorded in the book's
  ~il[certificate], and re-used.)  To overcome this default, you can specified
  keyword value ~c[:CHECK-EXPANSION t].  This will cause an error if the
  expansion is different, but it can be useful for side effects.  For example,
  if you insert the following form in a book, then the length of the world will
  be printed when the form is encountered, whether during ~ilc[certify-book] or
  during ~ilc[include-book].
  ~bv[]
  (make-event
   (pprogn (fms \"Length of current world: ~~x0~~|\"
                (list (cons #\\0 (length (w state))))
                *standard-co* state nil)
           (value '(value-triple nil)))
   :check-expansion t)
  ~ev[]~/

  ~st[Detailed Documentation]

  ~bv[]
  Examples:

  ; Trivial example: evaluate (quote (defun foo (x) x)) to obtain
  ; (defun foo (x) x), which is then evaluated.
  (make-event (quote (defun foo (x) x)))

  ; Evaluate (generate-form state) to obtain (mv nil val state), and
  ; then evaluate val.  (Generate-form is not specified here, but
  ; imagine for example that it explores the state and then generates
  ; some desired definition or theorem.)
  (make-event (generate-form state))

  ; As above, but make sure that if this form is in a book, then when
  ; we include the book, the evaluation of (generate-form state)
  ; should return the same value as it did when the book was
  ; certified.
  (make-event (generate-form state)
              :CHECK-EXPANSION t)

  ; As above (where the :CHECK-EXPANSION value can be included or
  ; not), where if there is an error during expansion, then the error
  ; message will explain that expansion was on behalf of the indicated
  ; object, typically specified as the first argument.
  (make-event (generate-form state)
              :ON-BEHALF-OF (generate-form state))

  General Form:
  (make-event form :CHECK-EXPANSION chk :ON-BEHALF-OF obj :EXPANSION? form)
  ~ev[]
  where ~c[chk] is ~c[nil] (the default), ~c[t], or the intended ``expansion
  result'' from the evaluation of ~c[form] (as explained below); and if
  supplied, ~c[obj] is an arbitrary ACL2 object, used only in reporting errors
  in expansion, i.e., in the evaluation of form.  The ~c[:EXPANSION?] keyword
  is discussed in the final section, on Advanced Expansion Control.

  We strongly recommend that you browse some ~c[.lisp] files in the community
  books directory ~c[books/make-event/].  You may even find it helpful, in
  order to understand ~c[make-event], to do so before continuing to read this
  documentation.  You may also find it useful to browse community book
  ~c[books/misc/eval.lisp], which contains definitions of macros
  ~c[must-succeed] and ~c[must-fail] that are useful for testing and are used
  in many books in the ~c[books/make-event/] directory, especially
  ~c[eval-tests.lisp].  Another example, ~c[books/make-event/defrule.lisp],
  shows how to use macros whose calls expand to ~c[make-event] forms, which in
  turn can generate ~il[events].  For more examples, see file
  ~c[books/make-event/Readme.lsp].  Other than the examples, the explanations
  here should suffice for most users.  If you want explanations of subtler
  details, ~pl[make-event-details].

  Note that ~c[make-event] may only be used at the ``top level'' or where an
  event is expected.  See the section ``Restriction to Event Contexts'', below.

  ~c[Make-event] is related to Lisp macroexpansion in the sense that its
  argument is evaluated to obtain an expansion result, which is evaluated
  again.  Let us elaborate on each of these notions in turn: ``is evaluated,''
  ``expansion result'', and ``evaluated again.''  The final section, on
  Advanced Expansion Control, will generalize these processes in a way that we
  ignore for now.~bq[]

  ``is evaluated'' ~-[] The argument can be any expression, which is evaluated
  as would be any expression submitted to ACL2's top level loop.  Thus,
  ~ilc[state] and user-defined ~ilc[stobj]s may appear in the form supplied to
  ~c[make-event].  Henceforth, we will refer to this evaluation as
  ``expansion.''  Expansion is actually done in a way that restores ACL2's
  built-in ~ilc[state] global variables, including the logical ~il[world], to
  their pre-expansion values (with a few exceptions ~-[]
  ~pl[make-event-details] ~-[] and where we note that changes to user-defined
  ~ilc[state] global variables (~pl[assign]) are preserved).  So, for example,
  events might be evaluated during expansion, but they will disappear from the
  logical ~il[world] after expansion returns its result.  Moreover, proofs are
  enabled by default at the start of expansion (~pl[ld-skip-proofsp]) if
  keyword ~c[:CHECK-EXPANSION] is supplied and has a non-~c[nil] value.

  ``expansion result'' ~-[] The above expansion may result in an ordinary
  (non-~ilc[state], non-~ilc[stobj]) value, which we call the ``expansion
  result.''  Or, expansion may result in a multiple value of the form
  ~c[(mv erp val state)], or, more generally,
  ~c[(mv erp val state stobj-1 ... stobj-k)] where each ~c[stobj-i] is a
  ~il[stobj]; then the expansion result is ~c[val] unless ~c[erp] is not
  ~c[nil], in which case there is no expansion result, and the original
  ~c[make-event] evaluates to a soft error.  In either case (single or multiple
  value), either ~c[val] is an embedded event form (~pl[embedded-event-form]),
  or else the original ~c[make-event] evaluates to a soft error, printed as
  described under ``Error Reporting'' below.

  ``evaluated again'' ~-[] the expansion result is evaluated in place of the
  original ~c[make-event].

  ~eq[]The expansion process can invoke subsidiary calls of ~c[make-event], and
  the expansion result can (perhaps after macroexpansion) be a call of
  ~c[make-event].  It can be useful to track all these ~c[make-event] calls.
  The ~il[state] global variable ~c[make-event-debug] may be set to a
  non-~c[nil] value, for example ~c[(assign make-event-debug t)], in order to
  see a trace of the expansion process, where a level is displayed (as in
  ``~c[3>]'') to indicate the depth of subsidiary expansions.

  Expansion of a ~c[make-event] call will yield an event that replaces the
  original ~c[make-event] call.  In particular, if you put a ~c[make-event]
  form in a book, then in essence it is replaced by its expansion result,
  created during the proof pass of the ~ilc[certify-book] process.  We now
  elaborate on this idea of keeping the original expansion.

  A ~c[make-event] call generates a ``~c[make-event] replacement'' that may be
  stored by the system.  In the simplest case, this replacement is the
  expansion result.  When a book is certified, these replacements are stored in
  a book's certificate (technically, in the ~c[:EXPANSION-ALIST] field).  Thus,
  although the book is not textually altered during certification, one may
  imagine a ``book expansion'' corresponding to the original book, in which
  events are substituted by replacements that were generated during the proof
  phase of certification.  A subsequent ~ilc[include-book] will then include
  the book expansion corresponding to the indicated book.  When a book is
  compiled during ~ilc[certify-book], it is actually the corresponding book
  expansion, stored as a temporary file, that is compiled instead.  That
  temporary file is deleted after compilation unless one first evaluates the
  form ~c[(assign keep-tmp-files t)].  Note however that all of the original
  forms must still be legal ~il[events]; ~pl[embedded-event-form].  So for
  example, if the first event in a book is ~c[(local (defmacro my-id (x) x))],
  and is followed by ~c[(my-id (make-event ...))], the final
  ``~c[include-book]'' pass of ~ilc[certify-book] will fail because ~c[my-id]
  is not defined when the ~c[my-id] call is encountered.

  A ~c[make-event] replacement might not be the expansion when either of the
  keyword arguments ~c[:CHECK-EXPANSION] or ~c[:EXPANSION?] is supplied.  We
  deal with the latter in the final section, on Advanced Expansion Control.  If
  ~c[:CHECK-EXPANSION t] is supplied and the expansion is ~c[exp], then the
  replacement is obtained from the original ~c[make-event] call, by
  substituting ~c[exp] for ~c[t] as the value of keyword ~c[:CHECK-EXPANSION].
  Such a ~c[make-event] call ~-[] during the second pass of an
  ~ilc[encapsulate] or during event processing on behalf of ~ilc[include-book]
  ~-[] will do the expansion again and check that the expansion result is equal
  to the original expansion result, ~c[exp].  In the unusual case that you know
  the expected expansion result, ~c[res], you can specify
  ~c[:CHECK-EXPANSION res] in the first place, so that the check is also done
  during the initial evaluation of the ~c[make-event] form.  IMPORTANT BUT
  OBSCURE DETAIL: That expansion check is only done when processing events, not
  during a preliminary load of a book's compiled file.  The following paragraph
  elaborates.

  (Here are details on the point made just above, for those who use the
  ~c[:CHECK-EXPANSION] argument to perform side-effects on the ~il[state].
  When you include a book, ACL2 generally loads a compiled file before
  processing the events in the book; ~pl[book-compiled-file].  While it is true
  that a non-~c[nil] ~c[:CHECK-EXPANSION] argument causes ~ilc[include-book] to
  perform expansion of the ~c[make-event] form during event processing it does
  ~em[not] perform expansion when the compiled file (or expansion file; again,
  ~pl[book-compiled-file]) is loaded.)

  ACL2 performs the following space-saving optimization: when the expansion
  result is a ~ilc[local] event, then the ~c[make-event] replacement is
  ~c[(local (value-triple :ELIDED))].

  The notion of ``expansion'' and ``replacement'' extend to the case that a
  call of ~c[make-event] is found in the course of macroexpansion.  The
  following example illustrates this point.
  ~bv[]
  (encapsulate
   ()
   (defmacro my-mac ()
     '(make-event '(defun foo (x) x)))
   (my-mac))
  :pe :here
  ~ev[]
  The above call of ~ilc[pe] shows that the form ~c[(my-mac)] has a
  ~c[make-event] expansion (and replacement) of ~c[(DEFUN FOO (X) X)]:
  ~bv[]
  (ENCAPSULATE NIL
               (DEFMACRO MY-MAC
                         NIL
                         '(MAKE-EVENT '(DEFUN FOO (X) X)))
               (RECORD-EXPANSION (MY-MAC)
                                 (DEFUN FOO (X) X)))
  ~ev[]

  ~st[Error Reporting]

  Suppose that expansion produces a soft error as described above.  That is,
  suppose that the argument of a ~c[make-event] call evaluates to a multiple
  value ~c[(mv erp val state ...)] where ~c[erp] is not ~c[nil].  If ~c[erp] is
  a string, then that string is printed in the error message.  If ~c[erp] is
  a ~ilc[cons] pair whose ~ilc[car] is a string, then the error prints
  ~c[\"~~@0\"] with ~c[#\\0] bound to that ~c[cons] pair; ~pl[fmt].  Any other
  non-~c[nil] value of ~c[erp] causes a generic error message to be printed.

  ~st[Restriction to Event Contexts]

  A ~c[make-event] call must occur either at the top level, or during
  ~c[make-event] expansion, or as an argument of an event constructor.  We
  explain in more detail below.  This restriction is imposed to enable ACL2 to
  track expansions produced by ~c[make-event].

  The following examples illustrate this restriction.
  ~bv[]
  ; Legal:
  (progn (with-output
          :on summary
          (make-event '(defun foo (x) x))))

  ; Illegal:
  (mv-let (erp val state)
          (make-event '(defun foo (x) x))
          (mv erp val state))
  ~ev[]

  More precisely: a ~c[make-event] call that is not itself evaluated during
  ~c[make-event] expansion is subject to the following requirement.  After
  macroexpansion has taken place, such a ~c[make-event] call must be in an
  ``event context'', defined recursively as follows.  (All but the first two
  cases below correspond to similar cases for constructing events;
  ~pl[embedded-event-form].)
  ~bq[]

  o A form submitted at the top level, or more generally, supplied to a call of
  ~ilc[ld], is in an event context.

  o A form occurring at the top level of a book is in an event context.

  o If ~c[(]~ilc[LOCAL]~c[ x1)] is in an event context, then so is ~c[x1].

  o If ~c[(]~ilc[SKIP-PROOFS]~c[ x1)] is in an event context, then so is
  ~c[x1].

  o If ~c[(]~ilc[MAKE-EVENT]~c[ x ...)] is in an event context and its
  expansion ~c[x1] is an embedded event form, then ~c[x1] is in an event
  context.

  o If ~c[(]~ilc[WITH-OUTPUT]~c[ ... x1)],
  ~c[(]~ilc[WITH-PROVER-STEP-LIMIT]~c[ ... x1 ...)], or
  ~c[(]~ilc[WITH-PROVER-TIME-LIMIT]~c[ ... x1)] is in an event context, then so
  is ~c[x1].

  o For any call of ~ilc[PROGN] or ~ilc[PROGN!], each of its arguments is in an
  event context.

  o For any call of ~ilc[ENCAPSULATE], each of its arguments except the
  first (the signature list) is in an event context.

  o If ~c[(RECORD-EXPANSION x1 x2)] is in an event context, then ~c[x1] and
  ~c[x2] are in event contexts.  Note: ~c[record-expansion] is intended for use
  only by the implementation, which imposes the additional restriction that
  ~c[x1] and its subsidiary ~c[make-event] calls (if any) must specify a
  ~c[:CHECK-EXPANSION] argument that is a ~il[consp].
  ~eq[]

  Low-level remark, for system implementors.  There is the one exception to
  the above restriction: a single ~ilc[state-global-let*] form immediately
  under a ~c[progn!] call.  For example:
  ~bv[]
  (progn! (state-global-let* <bindings> (make-event ...)))
  ~ev[]
  However, the following form may be preferable (~pl[progn!]):
  ~bv[]
  (progn! :STATE-GLOBAL-BINDINGS <bindings> (make-event ...))
  ~ev[]
  Also ~pl[remove-untouchable] for an interesting use of this exception.

  ~st[Examples Illustrating How to Access State]

  You can modify the ACL2 ~il[state] by doing your state-changing computation
  during the expansion phase, before expansion returns the event that is
  submitted.  Here are some examples.

  First consider the following.  Notice that expansion modifies state global
  ~c[my-global] during ~c[make-event] expansion, and then expansion returns a
  ~ilc[defun] event to be evaluated.
  ~bv[]
  (make-event
    (er-progn (assign my-global (length (w state)))
              (value '(defun foo (x) (cons x x)))))
  ~ev[]
  Then we get:
  ~bv[]
    ACL2 !>(@ my-global)
    72271
    ACL2 !>:pe foo
     L        1:x(MAKE-EVENT (ER-PROGN # #))
                 \
    >L            (DEFUN FOO (X) (CONS X X))
    ACL2 !>
  ~ev[]

  Here's a slightly fancier example, where the computation affects the
  ~ilc[defun].  In a new session, execute:
  ~bv[]
  (make-event
    (er-progn (assign my-global (length (w state)))
              (value `(defun foo (x) (cons x ,(@ my-global))))))
  ~ev[]
  Then:
  ~bv[]
    ACL2 !>(@ my-global)
    72271
    ACL2 !>:pe foo
     L        1:x(MAKE-EVENT (ER-PROGN # #))
                 \
    >L            (DEFUN FOO (X) (CONS X 72271))
    ACL2 !>
  ~ev[]
  Note that ACL2 ~il[table] ~il[events] may avoid the need to use ~il[state]
  globals.  For example, instead of the example above, consider this example in
  a new session.
  ~bv[]
  (make-event
    (let ((world-len (length (w state))))
      `(progn (table my-table :STORED-WORLD-LENGTH ,world-len)
              (defun foo (x) (cons x ,world-len)))))
  ~ev[]
  Then:
  ~bv[]
    ACL2 !>(table my-table)
     ((:STORED-WORLD-LENGTH . 72271))
    ACL2 !>:pe foo
              1:x(MAKE-EVENT (LET # #))
                 \
    >L            (DEFUN FOO (X) (CONS X 72271))
    ACL2 !>
  ~ev[]

  By the way, most built-in ~il[state] globals revert after expansion.  But
  your own global (like ~c[my-global] above) can be set during expansion, and
  the new value will persist.

  ~st[Advanced Expansion Control]

  We conclude this ~il[documentation] section by discussing three kinds of
  additional control over ~c[make-event] expansion.  These are all illustrated
  in community book ~c[books/make-event/make-event-keywords-or-exp.lisp].
  The discussion below is split into the following three parts.

  (1) The value produced by expansion may have the form ~c[(:DO-PROOFS exp)],
  which specifies ~c[exp] as the expansion result, to be evaluated without
  skipping proofs even when including a book.

  (2) The value produced by expansion may have the form
  ~c[(:OR exp-1 ... exp-k)], which specifies that the first form ~c[exp-i] to
  evaluate without error is the expansion result.

  (3) The keyword argument ~c[:EXPANSION?] can serve to eliminate the storing
  of ~c[make-event] replacements, as described above for the ``book expansion''
  of a book.

  We now elaborate on each of these.

  (1) ~c[:DO-PROOFS] ``call'' produced by expansion.

  We have discussed the expansion result produced by the expansion phase of
  evaluating a ~c[make-event] call.  However, if the expansion phase produces
  an expression of the form ~c[(:DO-PROOFS exp)], then the expansion result is
  actually ~c[exp].  The ~c[:DO-PROOFS] wrapper indicates that even if proofs
  are currently being skipped (~pl[ld-skip-proofsp]), then evaluation of
  ~c[exp] should take place with proofs not skipped.  For example, proofs will
  be performed when evaluating the ~c[make-event] expansion, namely the
  indicated ~c[defthm] event, in the following example.
  ~bv[]
  (set-ld-skip-proofsp t state)
  (make-event '(:DO-PROOFS
                (defthm app-assoc (equal
                                   (append (append x y) z)
                                   (append x y z)))))
  ~ev[]

  Note that such use of ~c[:DO-PROOFS] causes proofs to be performed when
  evaluating the expansion while including an uncertified book.  But when
  including a certified book, then unless ~c[:CHECK-EXPANSION] is supplied a
  non-~c[nil] value, the ~c[make-event] replacement will just be the expansion,
  which does not include the ~c[:DO-PROOFS] wrapper and hence will be evaluated
  with proofs skipped.

  (2) ~c[:OR] ``call'' produced by expansion.

  There may be times where you want to try different expansions.  For example,
  the community book ~c[books/make-event/proof-by-arith.lisp] attempts to admit
  a given event, which we'll denote ~c[EV], by trying events of the following
  form as ~c[BOOK] varies over different community books.
  ~bv[]
  (encapsulate
   ()
   (local (include-book BOOK :DIR :SYSTEM))
   EV)
  ~ev[]
  A naive implementation of this macro would evaluate all such
  ~ilc[encapsulate] events until one succeeds, and then return that successful
  event as the expansion.  Then that event would need to be evaluated again!
  With some hacking one could avoid that re-evaluation by using
  ~ilc[skip-proofs], but that won't work if you are trying to create a
  certified book without skipped proofs.  Instead, the implementation creates
  an expansion of the form ~c[(:OR ev-1 ev-2 ... ev-k)], where the list
  ~c[(ev-1 ev-2 ... ev-k)] enumerates the generated encapsulate events.  In
  general, for this ``disjunctive case'' of a result from expansion, each
  ~c[ev-i] is evaluated in sequence, and the first that succeeds without error
  is considered to be the expansion result ~-[] and a repeat evaluation is
  avoided.  If evaluation of each ~c[ev-i] results in an error, then so does
  the ~c[make-event] call.

  This special use of ~c[:OR] in a value produced by expansion is only
  supported at the top level.  That is, the result can be
  ~c[(:OR ev-1 ev-2 ... ev-k)] but then each ~c[ev-i] must be a legal expansion
  result, without such further use of ~c[:OR] ~-[] except, ~c[ev-i] may be
  ~c[(:DO-PROOFS ev-i')], where ~c[ev-i'] then would serve as the expansion
  rather than ~c[ev-i].

  (3) The ~c[:EXPANSION?] keyword argument.

  If keyword argument ~c[:EXPANSION?] has a non~c[nil] value, then the
  ~c[:CHECK-EXPANSION] keyword must be omitted or have value ~c[nil] or ~c[t],
  hence not a cons pair.

  The idea of the ~c[:EXPANSION?] keyword is to give you a way to avoid storing
  expansion results in a book's ~il[certificate].  Roughly speaking, when the
  expansion result matches the value of ~c[:EXPANSION?], then no expansion
  result is stored for the event by book certification; then when the book is
  later included, the value of ~c[:EXPANSION?] is used as the expansion, thus
  bypassing the expansion phase.  One could say that the event is its own
  make-event replacement, but it is more accurate to say that there is no
  make-event replacement at all, since nothing is stored in the certificate for
  this event.  Below, we elaborate on make-event replacements when
  ~c[:EXPANSION] is used and also discuss other properties of this keyword.

  We modify the notion of ``expansion result'' for ~c[make-event] forms to
  comprehend the use of the ~c[:EXPANSION?] keyword.  For that purpose, let's
  consider a call of ~c[make-event] to be ``reducible'' if it has an
  ~c[:EXPANSION?] keyword with non-~c[nil] value, ~c[exp], and its
  ~c[:CHECK-EXPANSION] keyword is missing or has value ~c[nil], in which case
  the ``reduction'' of this ~c[make-event] call is defined to be ~c[exp].  The
  expansion result as originally defined is modified by the following
  ``recursive reduction'' process: recur through the original expansion,
  passing through calls of ~ilc[local], ~ilc[skip-proofs], ~ilc[with-output],
  ~ilc[with-prover-step-limit], and ~ilc[with-prover-time-limit], and
  replacing (recursively) any reducible call of ~c[make-event] by its
  reduction.  Furthermore, we refer to two forms as ``reduction equivalent'' if
  their recursive reductions are equal.  Note that the recursive reduction
  process does not pass through ~ilc[progn] or ~ilc[encapsulate], but that
  process is applied to the computation of expansions for their subsidiary
  ~ilc[make-event] calls.

  To explain further the effect of ~c[:EXPANSION? exp], we split into the
  following two cases.

  o Case 1: Evaluation is not taking place when including a book or evaluating
  the second pass of an ~ilc[encapsulate] event; more precisely, the value of
  ~c[(ld-skip-proofsp state)] is not the symbol ~c[INCLUDE-BOOK].  There are
  two subcases.
  ~bq[]

  - Case 1a: The expansion result is not reduction-equivalent to ~c[exp].  Then
  the ~c[make-event] call is processed as though the ~c[:EXPANSION?] keyword
  had been omitted.

  - Case 2a: The expansion result is reduction-equivalent to ~c[exp].  Then
  there is no ~c[make-event] replacement for this call of ~c[make-event]; no
  replacement will be put into the ~il[certificate] file for a book containing
  this ~c[make-event] call.  When that book is subsequently included, the
  original form will be evaluated in the manner described in the next
  case.~eq[]

  o Case 2: Evaluation is taking place when including a book or evaluating the
  second pass of an ~ilc[encapsulate] event; more precisely, the value of
  ~c[(ld-skip-proofsp state)] is the symbol ~c[INCLUDE-BOOK].  Then the
  expansion is ~c[exp].  The expansion phase is skipped unless
  ~c[:CHECK-EXPANSION] is ~c[t].

  The ~c[:EXPANSION?] keyword can be particularly useful in concert with the
  disjunctive (``~c[:OR]'') case (2) discussed above.  Suppose that expansion
  produces a value as discussed in (2) above, ~c[(:OR exp-1 ... exp-k)].  If
  one of these expressions ~c[exp-i] is more likely than the others to be the
  expansion, then you may wish to specify ~c[:EXPANSION? exp-i], as this will
  avoid storing a ~c[make-event] replacement in that common case.  This could
  be useful if the expressions are large, to avoid enlarging the
  ~il[certificate] file for a book containing the ~c[make-event] call.

  It is legal to specify both ~c[:EXPANSION? exp] and ~c[:CHECK-EXPANSION t].
  When either ~c[(ld-skip-proofsp state)] is the symbol ~c[INCLUDE-BOOK], or
  evaluation is taking place in raw Lisp, then this combination is treated the
  same as if ~c[:EXPANSION?] is omitted and the value of ~c[:CHECK-EXPANSION]
  is ~c[exp].  Otherwise, this combination is treated the same as
  ~c[:CHECK-EXPANSION t], modified to accommodate the effect of ~c[:EXPANSION?]
  as discussed above: if the expansion is indeed the value of ~c[:EXPANSION?],
  then no ~c[make-event] replacement is generated."

  (declare (xargs :guard t))
; Keep this in sync with the -acl2-loop-only definition.
  `(make-event-fn ',form
                  ',expansion?
                  ',check-expansion
                  ',on-behalf-of
                  ',event-form
                  state))

(defdoc make-event-details

  ":Doc-Section Make-event

  details on ~ilc[make-event] expansion~/

  The normal user of ~c[make-event] can probably ignore this section, but we
  include it for completeness.  We assume that the reader has read and
  understood the basic documentation for ~c[make-event] (~pl[make-event]), but
  we begin below with a summary of expansion.~/

  ~st[Introduction]

  Here is a summary of how we handle expansion involving ~c[make-event] forms.

  ~c[(make-event form :check-expansion nil)]

  This shows the ~c[:check-expansion] default of ~c[nil], and is typical user
  input.  We compute the expansion ~c[exp] of ~c[form], which is the expansion
  of the original ~c[make-event] expression and is evaluated in place of that
  expression.

  ~c[(make-event form :check-expansion t)]

  The user presumably wants it checked that the expansion doesn't change in the
  future, in particular during ~ilc[include-book].  If the expansion of
  ~c[form] is ~c[exp], then we will evaluate ~c[exp] to obtain the value as
  before, but this time we record that the expansion of the original
  ~c[make-event] expression is ~c[(make-event form :check-expansion exp)]
  rather than simply ~c[exp].

  ~c[(make-event form :check-expansion exp) ; exp a cons]

  This is generated for the case that ~c[:check-expansion] is ~c[t], as
  explained above.  Evaluation is handled as described in that above case,
  except here we check that the expansion result is the given ~c[exp].
  (Actually, the user is also allowed supply such a form.)  The original
  ~c[make-event] expression does not undergo any expansion (intuitively, it
  expands to itself).

  Now let us take a look at how we expand ~ilc[progn] forms (~ilc[encapsulate]
  is handled similarly).

  ~c[(progn ... (make-event form :check-expansion nil) ...)]

  The expansion is obtained by replacing the ~c[make-event] form as follows.
  Let ~c[exp] be the expansion of ~c[form],  Then replace the above
  ~c[make-event] form, which we denote as ~c[F], by
  ~c[(record-expansion F exp)].  Here, ~c[record-expansion] is a macro that
  returns its second argument.

  ~c[(progn ... (make-event form :check-expansion t) ...)]

  The expansion is of the form ~c[(record-expansion F exp)] as in the ~c[nil]
  case above, except that this time ~c[exp] is
  ~c[(make-event form :check-expansion exp')], where ~c[exp'] is the expansion
  of ~c[form].

  ~c[(progn ... (make-event form :check-expansion exp) ...) ; exp a cons]

  No expansion takes place unless expansion takes place for at least one of the
  other subforms of the ~c[progn], in which case each such form ~c[F] is
  replaced by ~c[(record-expansion F exp)] where ~c[exp] is the expansion of
  ~c[F].

  ~st[Detailed semantics]

  In our explanation of the semantics of ~c[make-event], we assume familiarity
  with the notion of ``embedded event form'' (~pl[embedded-event-form]).

  Let's say that the ``actual embedded event form'' corresponding to a given
  form is the underlying call of an ACL2 event: that is, ~ilc[LOCAL]s are
  dropped when ~c[ld-skip-proofsp] is ~c['include-book], and macros are
  expanded away, thus leaving us with a ~ilc[progn], a ~ilc[make-event], or an
  event form (possibly ~ilc[encapsulate]), any of which might have surrounding
  ~ilc[local], ~ilc[skip-proofs], or ~ilc[with-output] calls.

  Thus, such an actual embedded event form can be viewed as having the form
  ~c[(rebuild-expansion wrappers base-form)] where ~c[base-form] is a
  ~c[progn], a ~c[make-event], or an event form (possibly ~c[encapsulate]), and
  ~c[wrappers] are (as in ACL2 source function ~c[destructure-expansion]) the
  result of successively removing the event form from the result of
  macroexpansion, leaving a sequence of ~c[(local)], ~c[(skip-proofs)], and
  ~c[(with-output ...)] forms.  In this case we say that the form
  ``destructures into'' the indicated ~c[wrappers] and ~c[base-form], and that
  it can be ``rebuilt from'' those ~c[wrappers] and ~c[base-form].

  Elsewhere we define the notion of the ``expansion result'' from an evaluation
  (~pl[make-event]), and we mention that when expansion concludes, the ACL2
  logical ~il[world] and most of the ~c[state] are restored to their
  pre-expansion values.  Specifically, after evaluation of the argument of
  ~c[make-event] (even if it is aborted), the ACL2 logical world is restored to
  its pre-evaluation value, as are all state global variables in the list
  ~c[*protected-system-state-globals*].  Thus, assignments to
  user-defined state globals (~pl[assign]) do persist after expansion, since
  they are not in that list.

  We recursively define the combination of evaluation and expansion of an
  embedded event form, as follows.  We also simultaneously define the notion of
  ``expansion takes place,'' which is assumed to propagate upward (in a sense
  that will be obvious), such that if no expansion takes place, then the
  expansion of the given form is considered to be itself.  It is useful to keep
  in mind a goal that we will consider later: Every ~c[make-event] subterm of
  an expansion result has a ~c[:check-expansion] field that is a ~ilc[consp],
  where for this purpose ~c[make-event] is viewed as a macro that returns its
  ~c[:check-expansion] field.  (Implementation note: The latest expansion of a
  ~ilc[make-event], ~ilc[progn], ~ilc[progn!], or ~ilc[encapsulate] is stored
  in state global ~c['last-make-event-expansion], except that if no expansion
  has taken place for that form then ~c['last-make-event-expansion] has value
  ~c[nil].)~bq[]

  If the given form is not an embedded event form, then simply cause a soft
  error, ~c[(mv erp val state)] where ~c[erp] is not ~c[nil].  Otherwise:

  If the evaluation of the given form does not take place (presumably because
  ~ilc[local] events are being skipped), then no expansion takes place.
  Otherwise:

  Let ~c[x] be the actual embedded event form corresponding to the given
  form, which destructures into wrappers ~c[W] and base-form ~c[B].  Then the
  original form is evaluated by evaluating ~c[x], and its expansion is as
  follows.

  If ~c[B] is ~c[(make-event form :check-expansion val)], then expansion
  takes place if and only if ~c[val] is not a ~c[consp] and no error occurs,
  as now described.  Let ~c[R] be the expansion result from protected
  evaluation of ~c[form], if there is no error.  ~c[R] must be an embedded
  event form, or it is an error.  Then evaluate/expand ~c[R], where if
  ~c[val] is not ~c[nil] then state global ~c['ld-skip-proofsp] is
  initialized to ~c[nil].  (This initialization is important so that
  subsequent expansions are checked in a corresponding environment, i.e.,
  where proofs are turned on in both the original and subsquent
  environments.)  It is an error if this evaluation causes an error.
  Otherwise, the evaluation yields a value, which is the result of evaluation
  of the original ~c[make-event] expression, as well as an expansion,
  ~c[E_R].  Let ~c[E] be rebuilt from ~c[W] and ~c[E_R].  The expansion of
  the original form is ~c[E] if ~c[val] is ~c[nil], and otherwise is the
  result of replacing the original form's ~c[:check-expansion] field with
  ~c[E], with the added requirement that if ~c[val] is not ~c[t] (thus, a
  ~c[consp]) then ~c[E] must equal ~c[val] or else we cause an error.

  If ~c[B] is either ~c[(progn form1 form2 ...)] or
  ~c[(encapsulate sigs form1 form2 ...)], then after evaluating ~c[B], the
  expansion of the original form is the result of rebuilding from ~c[B], with
  wrappers ~c[W], after replacing each ~c[formi] in ~c[B] for which expansion
  takes place by ~c[(record-expansion formi formi')], where ~c[formi'] is the
  expansion of ~c[formi].  Note that these expansions are determined as the
  ~c[formi] are evaluated in sequence (where in the case of ~c[encapsulate],
  this determination occurs only during the first pass).  Except, if no
  expansion takes place for any ~c[formi], then the expansion of the original
  form is itself.

  Otherwise, the expansion of the original form is itself.

  ~eq[]Similarly to the ~ilc[progn] and ~ilc[encapsulate] cases above, book
  certification causes a book to be replaced by its so-called ``book
  expansion.''  There, each event ~c[ev] for which expansion took place during
  the proof pass of certification ~-[] say, producing ~c[ev'] ~-[] is replaced
  by ~c[(record-expansion ev ev')].

  Implementation Note.  The book expansion is actually implemented by way of
  the ~c[:expansion-alist] field of its ~il[certificate], which associates
  0-based positions of top-level forms in the book (not including the initial
  ~ilc[in-package] form) with their expansions.  Thus, the book's source file
  is not overwritten; rather, the certificate's expansion-alist is applied when
  the book is included or compiled.  End of Implementation Note.

  It is straightforward by computational induction to see that for any
  expansion of an embedded event form, every ~c[make-event] sub-event has a
  ~ilc[consp] ~c[:check-expansion] field.  Here, by ``sub-event'' we mean to
  expand macros; and we also mean to traverse ~c[progn] and ~c[encapsulate]
  forms as well as ~c[:check-expansion] fields of ~c[make-event] forms.  Thus,
  we will only see ~c[make-event] forms with ~c[consp] ~c[:check-expansion]
  fields in the course of ~c[include-book] forms, the second pass of
  ~c[encapsulate] forms, and raw Lisp.  This fact guarantees that an event form
  will always be treated as its original expansion.

  ~st[Notes on ttags]

  ~l[defttag] for documentation of the notion of ``trust tag'' (``ttag'').  We
  note here that even if an event ~c[(defttag tag-name)] for non-~c[nil]
  ~c[tag-name] is admitted only during the expansion phase of a
  ~ilc[make-event] form, then such expansion will nevertheless still cause
  ~c[tag-name] to be recorded in the logical ~il[world] (assuming that the
  ~c[make-event] form is admitted).  So in order to certify such a book, a
  suitable ~c[:ttags] argument must be supplied; ~pl[certify-book].

  ACL2 does provide a way to avoid the need for ~c[:ttags] arguments in such
  cases.  The idea is to certify a book twice, where the results of
  ~c[make-event] expansion are saved from the first call of ~ilc[certify-book]
  and provided to the second call.  ~l[set-write-acl2x].

  Finally, we discuss a very unusual case where certification does not involve
  trust tags but a subsequent ~ilc[include-book] does involve trust tags: a
  ~c[make-event] call specifying ~c[:check-expansion t], whose expansion
  generates a ~ilc[defttag] event during ~ilc[include-book] but not
  ~ilc[certify-book].  Consider the following book.
  ~bv[]
  (in-package \"ACL2\")
  (make-event
   (er-progn
    (if (@ skip-notify-on-defttag) ; non-nil when including a certified book
        (pprogn
         (fms \"Value of (@ skip-notify-on-defttag): ~~x0~~|\"
              (list (cons #\0 (@ skip-notify-on-defttag)))
              *standard-co* state nil)
         (encapsulate
          ()
          (defttag :foo)
          (value-triple \"Imagine something bad here!\")))
      (value nil))
    (value '(value-triple :some-value)))
   :check-expansion t)
  ~ev[]
  This book certifies successfully without the need for a ~c[:ttags] argument
  for ~ilc[certify-book].  Indeed, the above book's ~il[certificate] does not
  specify ~c[:foo] as a trust tag associated with the book, because no
  ~c[defttag] event was executed during book certification.  Unfortunately, if
  we try to include this book without specifying a value of ~c[:ttags] that
  allows ~c[:foo], book inclusion will cause executing of the above
  ~ilc[defttag].  If that inclusion happens in the context of certifying some
  superior book and the appropriate ~c[:ttags] arguments have not been
  provided, that certification will fail.~/")

(defdoc using-tables-efficiently
 ":Doc-Section Table

  Notes on how to use tables efficiently~/

  (Thanks to Jared Davis for contributing this ~il[documentation] topic, to
  which we have made only minor modifications.)

  Suppose your book contains ~ilc[table] ~il[events], or macros that expand
  into ~c[table] events, of the following form:
  ~bv[]
     (table my-table 'my-field <computation>)
  ~ev[]
  Then ~c[<computation>] will be evaluated ~em[twice] during ~ilc[certify-book]
  and ~em[again] every time you include the book with ~ilc[include-book].  In
  some cases this overhead can be avoided using ~ilc[make-event].

  See also community book ~c[books/make-event/defconst-fast.lisp] for an
  analogous trick involving ~ilc[defconst].~/

  As an example, suppose we want to store numbers in a table only if they
  satisfy some computationally expensive predicate.  We'll introduce a new
  book, ~c[number-table.lisp], and create a table to store these numbers:
  ~bv[]
    (table number-table 'data nil)
  ~ev[]
  Instead of implementing a ``computationally expensive predicate,'' we'll
  write a function that just prints a message when it is called and accepts
  even numbers:
  ~bv[]
  (defun expensive-computation (n)
    (prog2$ (cw \"Expensive computation on ~~x0.~~%\" n)
            (evenp n)))
  ~ev[]
  Now we'll implement a macro, ~c[add-number], which will add its argument to
  the table only if it satisfies the expensive predicate:
  ~bv[]
  (defmacro add-number (n)
    `(table number-table 'data
            (let ((current-data
                   (cdr (assoc-eq 'data (table-alist 'number-table world)))))
              (if (expensive-computation ,n)
                  (cons ,n current-data)
                current-data))))
  ~ev[]
  Finally, we'll call ~c[add-number] a few times to finish the book.
  ~bv[]
  (add-number 1)
  (add-number 2)
  (add-number 3)
  ~ev[]
  When we now invoke ~c[(certify-book \"number-table\")], we see the expensive
  predicate being called twice for each number: once in Step 2, the main pass,
  then again in Step 3, the admissibility check.  Worse, the computation is
  performed again for each number when we use ~ilc[include-book] to load
  ~c[number-table], e.g.,
  ~bv[]
     ACL2 !>(include-book \"number-table\")
     Expensive computation on 1.
     Expensive computation on 2.
     Expensive computation on 3.
  ~ev[]
  To avoid these repeated executions, we can pull the test out of the ~c[table]
  event using ~ilc[make-event].  Here's an alternate implementation of
  ~c[add-number] that won't repeat the computation:
  ~bv[]
  (defmacro add-number (n)
    `(make-event
      (if (expensive-computation ,n)
          '(table number-table 'data
                  (cons ,n (cdr (assoc 'data
                                       (table-alist 'number-table world)))))
        '(value-triple :expensive-computation-failed))))
  ~ev[]
  When we recertify ~c[number-table.lisp], we'll see the expensive computation
  is still called once for each number in Step 2, but is no longer called
  during Step 3.  Similarly, the ~ilc[include-book] no longer shows any calls
  of the expensive computation.~/

  :cite make-event")

(defmacro record-expansion (x y)

; This funny macro simply returns its second argument.  However, we use it in
; the implementation to replace a given embedded event form x by its make-event
; expansion y, while retaining the information that y came from expanding x.

  (declare (ignore x))
  y)


; Essay on Soundness Threats

; Several of ACL2's rich set of features have the potential to compromise
; soundness unless we take suitable care, including:

; * defaxiom
; * hidden defpkg events (known-package-alist)
; * skip-proofs (skip-proofs and set-ld-skip-proofsp)
; * illegal certification world: uncertified books, non-events (including
;   redefinition), trust tags (defttag)
; * acl2-defaults-table
; * local [not yet explained here, but there's lots we could say -- see release
;   notes for related soundness bugs!]

; Here we briefly discuss these soundness threats and how we deal with them,
; pointing to other essays for further details.  Many of these issues are
; caused by LOCAL, which can introduce axioms that ultimately disappear.

; To see the potential problem with defaxiom, imagine an event such as
; (encapsulate () (local (defaxiom temp <formula>)) (defthm foo <formula>)).
; Such an event would leave us in an ACL2 logical world for which <formula> is
; stored under the name foo as through it were a logical consequence of the
; axioms in that logical world, which presumably it is not.  Our solution is to
; disallow defaxiom events in the scope of LOCAL.  This is a bit tricky since
; the LOCAL may not be lexically apparent, as when a defaxiom occurs inside a
; book that is locally included.  We therefore track LOCAL by binding state
; global variable 'in-local-flg to t (see the #+acl2-loop-only definition of
; LOCAL).

; The "hidden defpkg" problem is discussed in the Essay on Hidden Packages and
; is briefly summarized in :doc topic hidden-death-package.  The basic problem
; is that a defpkg event introduces axioms, yet it may be introduced
; temporarily through a local include-book.  The problem is thus similar to the
; defaxiom problem discussed just above, and a solution would be to disallow
; defpkg events in the scope of LOCAL.  But that solution would be harsh: For
; example, community book books/arithmetic/top.lisp defines packages and yet we
; would like to be able to include this book locally when proving arithmetic
; facts.  Our solution is to store all packages, even such "hidden" packages,
; in a world global 'known-package-alist.  We are careful to track such
; packages during the first pass (proof pass) of encapsulate and certify-book.
; In the case of certify-book, we write out such defpkg events to the
; portcullis of the certificate so that they are not hidden when executing a
; subsequent corresponding include-book.

; The Essay on Skip-proofs describes our handling of skip-proofs in some
; detail, but here is a summary.  We want to claim correctness for a system of
; books that is validated using certify-book without any keyword parameters.
; We thus want to require a non-nil value of keyword parameter :skip-proofs-okp
; for any book that depends on a skip-proofs event, whether that dependency is
; in the book's certification world, is in the book itself, or is
; (hereditarily) in an included book.  We thus maintain a world global
; 'skip-proofs-seen with value t whenever the world depends on a skip-proofs,
; as explained in the above essay.

; Certification worlds are checked for legality by
; chk-acceptable-certify-book1, which collects uncertified books (using
; collect-uncertified-books) from the existing include-book-alist, checks if
; any redefinition was done, and (if not doing the Pcertify or Convert step of
; provisional certification) checks that pcert-books is empty.  We of course
; miss uncertified locally-included books this way, but the only relevance of
; such books is whether they employed skip-proofs, ttags, or defaxioms, and
; this information is ultimately stored in the certificate of a parent book
; that is non-locally included in the certification world.  We track locally
; included provisionally certified books under encapsulates, but as with
; uncertified books, we are not concerned about any locally included
; provisionally certified book under a certified book.

; The acl2-defaults-table stores the default defun-mode, and hence can affect
; soundness.  However, chk-acceptable-certify-book1 checks that the default
; defun mode is logic at certification time, and we take various measures to
; avoid other potential pitfalls (probably identifiable by tags-searches
; through the source code for acl2-defaults-table and for default-defun-mode).

; When additional, tricky soundness threats are identified, it would be good to
; describe them here, along with how we deal with them.

; End of Essay on Soundness Threats

; Essay on Skip-proofs

; The skip-proofs event allows a modular, top-down style of proof.  Skip-proofs
; differs from defaxiom: skip-proofs is intended for use when proof obligations
; are believed to be theorems but it is convenient to defer their proofs, while
; defaxiom is to be used for extending the first-order theory.  Therefore,
; while we disallow local defaxiom events (which really do not make sense; are
; we extending the theory or not?), it does make sense to allow local
; skip-proofs events.  Indeed, if we were to disallow local skip-proofs events
; then we would be ruling out the top-down, modular style of proof outlined in
; Kaufmann's article in the case studies book.

; But we then must track skip-proofs events in support of our correctness
; story.  Our claim is that when a certified book has an empty portcullis and
; all of :SKIPPED-PROOFSP, :AXIOMSP, and :TTAGS are NIL in its certificate,
; then it is sound to extend a history by including such a book without error.

; In Version_2.5 we did such tracking using world global include-book-alist.
; That tracking proved inadequate, however.  Consider the following books "top"
; and "sub".

;  ; book "top"
;  (in-package "ACL2")
;  (encapsulate
;   ()
;   (local (include-book "sub"))
;   (defthm bad nil
;     :rule-classes nil))

;  ; book "sub"
;  (in-package "ACL2")
;  (skip-proofs
;   (defthm bad nil
;     :rule-classes nil))

; In Version_2.5, if you certify these books in the initial logical world and
; then (include-book "top"), then you will not see a "Skip-proofs" warning when
; you do the include-book, because the value of :SKIPPED-PROOFSP in the
; cert-annotations of the certificate of "foo" is nil.

; Version_2.6 through Version_3.4 more carefully tracked include-books for the
; presence of supporting skip-proofs events, including skip-proofs that are
; local inside an encapsulate, using a state global, 'include-book-alist-state.
; When constructing a book's certificate, the value of
; 'include-book-alist-state was bound to nil initially and then updated by
; include-book, and its final value was used to create the post-alist of the
; certificate.  (We do not have to worry about analogous handling of :AXIOMSP
; because defaxioms are never allowed in a local context.)

; But that approach entailed, at certification time, looking in certificates of
; already-included books for skip-proofs information.  This was inefficient for
; very large certificates such as those found in the work at Centaur
; Technology.  So starting after Version_3.4 we are adopting a different
; approach.  We no longer have state global 'skipped-proofsp.  Instead, we
; focus only on maintaining world global 'skip-proofs-seen, consulting
; 'ld-skip-proofsp when we call install-event.

; We maintain the invariant that skip-proofs-seen is a form evaluated with
; proofs skipped in support of the construction of the current ACL2 logical
; world, if such exists (otherwise skip-proofs-seen is nil).  This "form" can
; be (:include-book full-book-name) if full-book-name logically supports the
; current ACL2 world (perhaps locally) and contains a skip-proofs form.  When
; we install an event, we set world global 'skip-proofs-seen (if it is not
; already set) if the event is evaluated with a non-nil value of state global
; 'ld-skip-proofsp, unless we are inside an include-book or the second pass of
; an encapsulate.  (Note that the certificate of a book already carries the
; information of whether skip-proofs was invoked during cerification, and we
; use that information when including a book.)  We may also avoid setting
; 'skip-proofs-seen if the event has no logical content, for example, a
; deflabel event.  However, we avoid updating 'skip-proofs-seen in the cases of
; encapsulate and include-book, since they manage this global themselves, as
; follows.  Encapsulate checks the value of 'skip-proofs-seen after its first
; pass and installs that value at the end of its second pass.  Include-book
; sets 'skip-proofs-seen based on its certificate (its so-called cert-obj),
; which provides skip-proofs information at the top level and also in its
; post-alist (which is set based on world global include-book-alist-all).  Note
; that certify-book does not set skip-proofs-seen in the resulting world, but
; since certify-book is not a valid embedded event form for a certification
; world, that is not a problem.

; Up through Version_3.4, we updated world globals 'skip-proofs-seen and
; 'redef-seen in maybe-add-command-landmark intead of as indicated above (in
; particular, instead of using install-event).  But with progn!, this is
; misguided -- these should be updated at the event level, not the command
; level -- as the following example shows.

; (progn! (set-ld-redefinition-action '(:doit . :overwrite) state)
;         (defun foo (x) (cons x x))
;         (set-ld-redefinition-action nil state))

; Of course, this isn't exactly a soundness bug, since one needs an active
; trust tag in order to evaluate progn!.  Nevertheless, we would like to avoid
; such a simple way to prove nil whenever there is any active trust tag!

; Finally, we note a related problem with Version_2.5 that was fixed in
; Version_2.6.  Suppose that foo.lisp and bar.lisp both have this unique
; form after (in-package "ACL2"):

; (defthm bad nil
;   :rule-classes nil)

; Now suppose we do this in a fresh session:

; (encapsulate ()
;              (local (include-book "foo"))
;              (defthm bad nil
;                :rule-classes nil))

; Then (certify-book "bar" 1) succeeded in Version_2.5, and in subsequent
; sessions, if we evaluated (include-book "bar"), that succeeded without
; warning or error.

; End of Essay on Skip-proofs

#+acl2-loop-only
(defmacro skip-proofs (x)
  ":Doc-Section Other

  skip proofs for a given form ~-[] a quick way to introduce unsoundness~/
  ~bv[]
  Example Form:
  (skip-proofs
    (defun foo (x)
      (if (atom x) nil (cons (car x) (foo (reverse (cdr x)))))))

  General Form:
  (skip-proofs form)
  ~ev[]
  where ~c[form] is processed as usual except that the proof obligations
  usually generated are merely assumed.

  Normally ~c[form] is an event; ~pl[events].  If you want to put
  ~c[skip-proofs] around more than one event, consider the following
  (~pl[progn]): ~c[(skip-proofs (progn event1 event2 ... eventk))].

  WARNING: ~c[Skip-proofs] allows inconsistent ~il[events] to be admitted to
  the logic.  Use it at your own risk!~/

  Sometimes in the development of a formal model or proof it is convenient to
  skip the proofs required by a given event.  By embedding the event in a
  ~c[skip-proofs] form, you can avoid the proof burdens generated by the event,
  at the risk of introducing unsoundness.  Below we list four illustrative
  situations in which you might find ~c[skip-proofs] useful.

  1. The termination argument for a proposed function definition is
  complicated.  You presume you could admit it, but are not sure that
  your definition has the desired properties.  By embedding the
  ~ilc[defun] event in a ~c[skip-proofs] you can ``admit'' the
  function and experiment with theorems about it before undoing
  (~pl[ubt]) and then paying the price of its admission.  Note however that you
  might still have to supply a measure.  The set of formals used in some valid
  measure, known as the ``measured subset'' of the set of formals, is used by
  ACL2's induction heuristics and therefore needs to be suitably specified.
  You may wish to specify the special measure of ~c[(:? v1 ... vk)], where
  ~c[(v1 ... vk)] enumerates the measured subset.

  2. You intend eventually to verify the ~il[guard]s for a definition but do
  not want to take the time now to pursue that.  By embedding the
  ~ilc[verify-guards] event in a ~c[skip-proofs] you can get the system to
  behave as though the ~il[guard]s were verified.

  3. You are repeatedly recertifying a book while making many experimental
  changes.  A certain ~ilc[defthm] in the book takes a very long time to prove
  and you believe the proof is not affected by the changes you are making.  By
  embedding the ~ilc[defthm] event in a ~c[skip-proofs] you allow the theorem
  to be assumed without proof during the experimental recertifications.

  4. You are constructing a proof top-down and wish to defer the proof of a
  ~ilc[defthm] until you are convinced of its utility.  You can embed the
  ~c[defthm] in a ~c[skip-proofs].  Of course, you may find later (when you
  attempt prove the theorem) that the proposed ~c[defthm] is not a theorem.

  Unsoundness or Lisp errors may result if the presumptions underlying a use of
  ~c[skip-proofs] are incorrect.  Therefore, ~c[skip-proofs] must be considered
  a dangerous (though useful) tool in system development.

  Roughly speaking, a ~ilc[defthm] embedded in a ~c[skip-proofs] is
  essentially a ~ilc[defaxiom], except that it is not noted as an axiom
  for the purposes of functional instantiation
  (~pl[lemma-instance]).  But a skipped ~ilc[defun] is much more subtle since
  not only is the definitional equation being assumed but so are formulas
  relating to termination and type.  The situation is also difficult to
  characterize if the ~c[skip-proofs] ~il[events] are within the scope of an
  ~ilc[encapsulate] in which constrained functions are being introduced.  In
  such contexts no clear logical story is maintained; in particular,
  constraints aren't properly tracked for definitions.  A proof script
  involving ~c[skip-proofs] should be regarded as work-in-progress, not as a
  completed proof with some unproved assumptions.  A ~c[skip-proofs] event
  represents a promise by the author to admit the given event without further
  axioms.  In other words, ~c[skip-proofs] should only be used when the belief
  is that the proof obligations are indeed theorems in the existing ACL2
  logical ~il[world].

  ACL2 allows the certification of ~il[books] containing ~c[skip-proofs]
  ~il[events] by providing the keyword argument ~c[:skip-proofs-okp t] to the
  ~ilc[certify-book] command.  This is contrary to the spirit of certified
  ~il[books], since one is supposedly assured by a valid ~il[certificate] that
  a book has been ``blessed.''  But certification, too, takes the view of
  ~c[skip-proofs] as ``work-in-progress'' and so allows the author of the book
  to promise to finish.  When such ~il[books] are certified, a warning to the
  author is printed, reminding him or her of the incurred obligation.  When
  ~il[books] containing ~c[skip-proofs] are included into a session, a warning
  to the user is printed, reminding the user that the book is in fact
  incomplete and possibly inconsistent.  This warning is in fact an error if
  ~c[:skip-proofs-okp] is ~c[nil] in the ~ilc[include-book] form;
  ~pl[include-book].

  We conclude with a technical note.  ~c[Skip-proofs] works by binding the
  ~ilc[ld] special ~ilc[ld-skip-proofsp] to ~c[t] unless it is already bound to
  a non-~c[nil] value; ~pl[ld-skip-proofsp].~/"

  `(state-global-let*
    ((ld-skip-proofsp (or (f-get-global 'ld-skip-proofsp state)
                          t))
     (inside-skip-proofs

; See the comment inside install-event for a discussion of the use of this
; binding.

      t))
    ,x))

#+acl2-loop-only
(defmacro local (x)

; Warning: See the Important Boot-Strapping Invariants before modifying!

; Keep this in sync with chk-embedded-event-form: if we skip the check on x
; there, we should skip evaluation of x here.

  ":Doc-Section Events

  hiding an event in an encapsulation or book~/
  ~bv[]
  Examples:
  (local (defthm hack1
           (implies (and (acl2-numberp x)
                         (acl2-numberp y)
                         (equal (* x y) 1))
                    (equal y (/ x)))))

  (local (defun double-naturals-induction (a b)
           (cond ((and (integerp a) (integerp b) (< 0 a) (< 0 b))
                  (double-naturals-induction (1- a) (1- b)))
                 (t (list a b)))))~/

  General Form:
  (local ev)
  ~ev[]
  where ~c[ev] is an event form.  If the current default ~il[defun-mode]
  (~pl[default-defun-mode]) is ~c[:]~ilc[logic] and ~ilc[ld-skip-proofsp] is
  ~c[nil] or ~c[t], then ~c[(local ev)] is equivalent to ~c[ev].  But if
  the current default ~il[defun-mode] is ~c[:]~ilc[program] or if
  ~ilc[ld-skip-proofsp] is ~c[']~ilc[include-book], then ~c[(local ev)] is a
  ~c[no-op].  Thus, if such forms are in the event list of an
  ~ilc[encapsulate] event or in a book, they are processed when the
  encapsulation or book is checked for admissibility in ~c[:]~ilc[logic] mode
  but are skipped when extending the host ~il[world].  Such ~il[events] are thus
  considered ``local'' to the verification of the encapsulation or
  book.  The non-local ~il[events] are the ones ``exported'' by the
  encapsulation or book.  ~l[encapsulate] for a thorough
  discussion.  Also ~pl[local-incompatibility] for a discussion of
  a commonly encountered problem with such event hiding:  you can't
  make an event local if its presence is required to make sense of a
  non-local one.

  Note that ~il[events] that change the default ~il[defun-mode], and in fact any
  ~il[events] that set the ~ilc[acl2-defaults-table], are disallowed inside
  the scope of ~c[local].  ~l[embedded-event-form]."

; Warning: See the Important Boot-Strapping Invariants before modifying!

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

#+acl2-loop-only
(defmacro defchoose (&whole event-form &rest def)

; Warning: See the Important Boot-Strapping Invariants before modifying!

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

  ":Doc-Section Events

  define a Skolem (witnessing) function~/
  ~bv[]
  Examples:
  (defchoose choose-x-for-p1-and-p2 (x) (y z)
    (and (p1 x y z)
         (p2 x y z)))

  (defchoose choose-x-for-p1-and-p2 x (y z) ; equivalent to the above
    (and (p1 x y z)
         (p2 x y z)))

  ; The following is as above, but strengthens the axiom added to pick a sort
  ; of canonical witness, as described below.
  (defchoose choose-x-for-p1-and-p2 x (y z)
    (and (p1 x y z)
         (p2 x y z))
    :strengthen t)

  (defchoose choose-x-and-y-for-p1-and-p2 (x y) (z)
    (and (p1 x y z)
         (p2 x y z)))~/

  General Form:
  (defchoose fn
             (bound-var1 ... bound-varn)
             (free-var1 ... free-vark)
             body
             :doc doc-string
             :strengthen b),
  ~ev[]
  where ~c[fn] is the symbol you wish to define and is a new symbolic
  name (~pl[name]), ~c[(bound-var1 ... bound-varn)] is a list of
  distinct `bound' variables (see below), ~c[(free-var1 ... free-vark)]
  is the list of formal parameters of ~c[fn] and is disjoint from the
  bound variables, and ~c[body] is a term.  The use of ~c[lambda-list]
  keywords (such as ~c[&optional]) is not allowed.  The ~il[documentation]
  string argument, ~c[:doc doc-string], is optional; for a description of the
  form of ~c[doc-string] ~pl[doc-string].  The ~c[:strengthen] keyword argument
  is optional; if supplied, it must be ~c[t] or ~c[nil].

  The system treats ~c[fn] very much as though it were declared in the
  ~il[signature] of an ~ilc[encapsulate] event, with a single axiom exported as
  described below.  If you supply a ~c[:use] hint (~pl[hints]), ~c[:use fn], it
  will refer to that axiom.  No rule (of class ~c[:]~ilc[rewrite] or otherwise;
  ~pl[rule-classes]) is created for ~c[fn].

  ~c[Defchoose] is only executed in ~il[defun-mode] ~c[:]~ilc[logic];
  ~pl[defun-mode].  Also ~pl[defun-sk].

  In the most common case, where there is only one bound variable, it is
  permissible to omit the enclosing parentheses on that variable.  The effect
  is the same whether or not those parentheses are omitted.  We describe this
  case first, where there is only one bound variable, and then address the
  other case.  Both cases are discussed assuming ~c[:strengthen] is ~c[nil],
  which is the default.  We deal with the case ~c[:strengthen t] at the end.

  The effect of the form
  ~bv[]
  (defchoose fn bound-var (free-var1 ... free-vark)
    body)
  ~ev[]
  is to introduce a new function symbol, ~c[fn], with formal parameters
  ~c[(free-var1 ... free-vark)].  Now consider the following axiom, which
  states that ~c[fn] picks a value of ~c[bound-var] so that the body will be
  true, if such a value exists:
  ~bv[]
  (1)   (implies body
                 (let ((bound-var (fn free-var1 ... free-vark)))
                   body))
  ~ev[]
  This axiom is ``clearly conservative'' under the conditions expressed above:
  the function ~c[fn] simply picks out a ``witnessing'' value of ~c[bound-var]
  if there is one.  For a rigorous statement and proof of this conservativity
  claim, ~pl[conservativity-of-defchoose].

  Next consider the case that there is more than one bound variable, i.e.,
  there is more than one bound-var in the following.
  ~bv[]
  (defchoose fn
             (bound-var1 ... bound-varn)
             (free-var1 ... free-vark)
             body)
  ~ev[]
  Then ~c[fn] returns a multiple value with ~c[n] components, and formula (1)
  above is expressed using ~ilc[mv-let] as follows:
  ~bv[]
  (implies body
           (mv-let (bound-var1 ... bound-varn)
                   (fn free-var1 ... free-vark)
                   body))
  ~ev[]

  We now discuss the case that ~c[:strengthen t] is supplied.  For simplicity
  we return to our simplest case, with ~c[defchoose] applied to function
  ~c[fn], a single free variable ~c[y], and a single bound variable
  ~c[bound-var].  The idea is that if we pick the ``smallest'' witnessing
  ~c[bound-var] for two different free variables ~c[y] and ~c[y1], then either
  those two witnesses are the same, or else one is less than the other, in
  which case the smaller one is a witness for its free variable but not for the
  other.  (See comments in source function ~c[defchoose-constraint-extra] for
  more details.)  Below, ~c[body1] is the result of replacing ~c[y] by ~c[y1]
  in ~c[body].
  ~bv[]
  (2)   (or (equal (fn y) (fn y1))
            (let ((bound-var (fn y)))
              (and body
                   (not body1)))
            (let ((bound-var (fn y1)))
              (and body1
                   (not body))))
  ~ev[]
  An important application of this additional axiom is to be able to define a
  ``fixing'' function that picks a canonical representative of each equivalence
  class, for a given equivalence relation.  The following events illustrate
  this point.
  ~bv[]
  (encapsulate
   ((equiv (x y) t))
   (local (defun equiv (x y) (equal x y)))
   (defequiv equiv))

  (defchoose efix (x) (y)
    (equiv x y)
    :strengthen t)

  (defthm equiv-implies-equal-efix-1
    (implies (equiv y y1)
             (equal (efix y) (efix y1)))
    :hints ((\"Goal\" :use efix))
    :rule-classes (:congruence))

  (defthm efix-fixes
    (equiv (efix x) x)
    :hints ((\"Goal\" :use ((:instance efix (y x))))))
  ~ev[]

  If there is more than one bound variable, then (2) is modified in complete
  analogy to (1) to use ~ilc[mv-let] in place of ~ilc[let].

  Comment for logicians:  As we point out in the documentation for
  ~ilc[defun-sk], ~c[defchoose] is ``appropriate,'' by which we mean that
  it is conservative, even in the presence of ~c[epsilon-0] induction.
  For a proof, ~l[conservativity-of-defchoose].~/"

; Warning: See the Important Boot-Strapping Invariants before modifying!

  (list 'defchoose-fn
        (list 'quote def)
        'state
        (list 'quote event-form)))

(deflabel conservativity-of-defchoose
  :doc
  ":Doc-Section defchoose

  proof of conservativity of ~ilc[defchoose]~/

  This documentation topic provides underlying theory.  It is of theoretical
  interest only; it has no relationship to the effective use of ACL2.~/

  The argument below for the conservativity of ~il[defchoose] replaces the
  terse and somewhat misleading reference to a forcing argument in Appendix B
  of the paper by ACL2 authors Kaufmann and Moore, ``Structured Theory
  Development for a Mechanized Logic'' (Journal of Automated Reasoning 26,
  no. 2 (2001), pp. 161-203).

  Our basic idea is to to take a (countable) first-order structure for ACL2, M,
  together with a function symbol, f, introduced by ~il[defchoose], and find a
  way to expand M with an interpretation of f (without changing the universe of
  M) so that e0-induction continues to hold in the expansion.  A remark at the
  end of this documentation topic shows why care is necessary.  A concept
  called ``forcing'', originally introduced by Paul Cohen for set theory, has
  long since been adapted by logicians (in a simplified form) to model theory.
  This simplified model-theoretic forcing provides the means for making our
  careful expansion.

  The forcing argument presented below is intended to be completely
  self-contained for those familiar with basic first-order logic and ACL2.  No
  background in forcing (model-theoretic or otherwise) is expected, though we
  do expect a rudimentary background in first-order logic and familiarity with
  the following.

  Preliminaries.  We write s[p<-p0] to denote the result of extending or
  modifying the assignment s by binding p to p0.  Now let A be a subset of the
  universe U of a first-order structure M.  A is said to be ``first-order
  definable with parameters'' in M if for some formula phi, variable x, and
  assignment s binding the free variables of phi except perhaps for x, A = {a
  \\in U: M |= phi[s[x<-a]].  Note that we are writing ``\\in'' to denote set
  membership.  Finally, we indicate the end of a proof (or of a theorem
  statement, when the proof is omitted) with the symbol ``-|''.

  We gratefully acknowledge very helpful feedback from John Cowles, who found
  several errors in a draft of this note and suggested the exercises.  We also
  thank Ruben Gamboa for helpful feedback, and we thank Jim Schmerl for an
  observation that led us directly to this proof in the first place.

  We are given a consistent first-order theory T, extending the ACL2
  ground-zero theory, that satisfies the e0-induction scheme.  We wish to show
  that the extension of T by the following arbitrary defchoose event is
  conservative, where g is a new function symbol.
  ~bv[]
       (defchoose g <bound-vars> <free-vars> <body>)
  ~ev[]
  Note that by ``the extension of T'' here we mean the extension of T by not
  only the new defchoose axiom displayed just below, but also the addition of
  e0-induction axioms for formulas in the language with the new defchoose
  function symbol, g.
  ~bv[]
       <body> -> (LET <free-vars> = g(<bound-vars>) in <body>)
  ~ev[]
  By definition of conservativity, since proofs are finite, it clearly suffices
  to consider an arbitrary finite subset of T.  Then by the completeness,
  soundness, and downward Lowenheim-Skolem theorems of first-order logic, it
  suffices to show that an arbitrary countable model of T can be expanded
  (i.e., by interpreting the new symbol g without changing the universe of the
  model) to a model of the corresponding defchoose axiom above, in which all
  e0-induction axioms hold in the language of that model.

  Below, we will carry out a so-called ~em[forcing] construction, which
  allows us to expand any countable model M of T to a model M[G] that satisfies
  e0-induction and also satisfies the above axiom generated from the above
  defchoose event.  The ideas in this argument are standard in model theory; no
  novelty is claimed here.

  Fix a countable model M of a theory T that satisfies e0-induction and extends
  the ACL2 ground-zero theory.  Also fix the above defchoose axiom, where g is
  not in the language of T.

  We start by defining a partial order P as follows.  Let Nb and Nf be the
  lengths of <bound-vars> and <free-vars>, respectively.  P consists of all fn in
  M such that the following formula is true in M.  Roughly speaking, it says that
  fn is a finite function witnessing the above requirement for g.
  ~bv[]
         alistp(fn) &
         no-duplicatesp-equal(strip-cars(fn)) &
         (forall <bound-vars>, <free-vars> .
            (member-equal(cons(<bound-vars>,<free-vars>), fn) ->
             (length(<bound-vars>) = Nb &
              length(<free-vars>)  = Nf &
              ((exists <free-vars> . <body>) -> <body>))))
  ~ev[]
  P is ordered by subset, i.e., we say that p2 ~em[extends] p1 if p1 is a
  subset (not necessarily proper) of p2 (more precisely, M |=
  subsetp-equal(p1,p2)).

  Remark.  The original argument in Appendix B of the aforementioned paper can
  essentially be salvaged, as we now show.  The key observation is that the
  particular choice of P is nearly irrelevant for the argument that follows
  below.  In particular, we can instead define P to consist of finite one-one
  functions with domain contained in the set of natural numbers.  More
  precisely, consider the following definitions.
  ~bv[]
       (defun function-p (fn)
         (declare (xargs :guard t))
         (and (alistp fn)
              (no-duplicatesp-equal (strip-cars fn))))

       (defun nat-listp (l)
         (declare (xargs :guard t))
         (cond ((atom l)
                (eq l nil))
               (t (and (natp (car l))
                       (nat-listp (cdr l))))))

       (defun nat-function-p (x)
         (and (function-p x)
              (nat-listp (strip-cars x))))
  ~ev[]
  and define inverse as follows.
  ~bv[]
       (defun inverse (fn)
         (declare (xargs :guard (alistp fn)))
         (if (endp fn)
             nil
           (cons (cons (cdar fn) (caar fn))
                 (inverse (cdr fn)))))
  ~ev[]
  Then P may instead be defined to consist of those fn for which
  nat-function-p(fn) & function-p(inverse(fn)).  With this alternate definition
  of P, the argument below then goes through virtually unchanged, and we get an
  expansion M[G] of M in which there is a definable enumeration of the
  universe.  The conservativity of defchoose then follows easily because the
  function being introduced can be defined explicitly using that enumeration
  (namely, always pick the least witness in the sense of the enumeration).

  End of Remark.

  Next we present the relevant forcing concepts from model theory.

  A ~em[dense] subset of P is a subset D of P such that for every p \\in P,
  there is d \\in D such that d extends p.  A subset G of P is ~em[generic]
  with respect to a collection Ds of dense subsets of P, also written ``G is
  Ds-generic,'' if G is closed under subset (if p2 \\in G and p2 extends p1
  then p1 \\in G), G is pairwise compatible (the union-equal of any two
  elements of G is in G), and every set in Ds has non-empty intersection with
  G.

  For p \\in P, we say that a subset D of P is ~em[dense beyond] p if for all
  p1 extending p there exists p2 extending p1 such that p2 \\in D.  This notion
  makes sense even for D not a subset of P if we treat elements of D not in P
  as nil.

  Proposition 1.  For any partial order P and countable collection Ds of dense
  subsets of P, there is a Ds-generic subset of P.

  Proof.  Let Ds = {D0,D1,D2,...}.  Define a sequence <p_0,p_1,...> such that
  for all i, p_i \\in Di and p_(i+1) extends p_i.  Let G = {p \\in P: for some
  i, pi extends p}.  Then G is Ds-generic. -|

  Note that P is first-order definable (with parameters) in M.  Let Df be the
  set of dense subsets of P that are first-order definable (with parameters) in
  M.  A standard argument shows there are only countably many first-order
  definitions with parameters in a countable model M ~-[] for example, we can
  Goedel number all terms and then all formulas ~-[] hence, Df is countable.

  By Proposition 1, let G be Df-generic.  Notice that for any list x of length
  Nb in M, the set of elements f of P for which x is in the domain of f is
  dense and first-order definable.  We may thus define a function g0 as
  follows: g0(x_1,...,x_Nb) = y if there is some element of G containing the
  pair ((x_1 ... x_Nb) . y).  It is easy to see that g0 is a total function on
  M.  Let L be the language of T and let L[g] be the union of L with a set
  containing a single new function symbol, g.  Let M[G] be the expansion of M
  to L[g] obtained by interpreting g to be g0 (see also Proposition 5 below).

  So now we have fixed M, P, Df, G, and g0, where G is Df-generic.

  Proposition 2.  Let Df be the set of dense subsets of P that are first-order
  definable (with parameters) in M.  Suppose that p \\in G and D \\in Df.  Then for
  some q \\in G extending p, q \\in D.

  Proof.  Let D0 be the set of p' \\in D that either extend p or have no
  extension in D that extends p.  We leave it as a straightforward exercise to
  show that D0 is dense, and D0 is clearly first-order definable (with
  parameters) in M.  So by genericity of G, we may pick q \\in D0 such that q
  \\in G.  Thus q \\in D.  By definition of generic, some extension q1 of both
  p and q belongs to G.  Pick q2 \\in D extending q1; thus q has an extension
  in D that extends p (namely, q2), so by definition of D0, q extends p. -|

  Definition of forcing.  Let phi(x1,...,xk) be a first-order formula in L[g]
  and let p \\in P.  We define a formula of L, denoted ``p ||- phi'' (``p
  forces phi''), by recursion on phi (in the metatheory) as follows.  (Here, we
  view ``or'' and ``forall'' as abbreviations.)

  ~bq[]
    If phi is atomic, then let phi'(A) be the result of replacing, inside-out,
    each subterm of the form g(x_1,...,x_Nb) with the term (cdr (assoc-equal
    (list x_1 ... x_Nb) A)), where A is neither p nor a variable occurring in
    phi.  Then p ||- phi is defined as follows: ``The set {A \\in P: A extends
    p and phi'(A)} is dense beyond p''.  That is, p ||- phi is the following
    formula:
  ~bv[]
      (forall p1 \\in P extending p)
       (exists p2 \\in P extending p1) phi'(p2).
  ~ev[]
    p ||- ~~phi is:  (forall p' \\in P extending p) ~~(p' ||- phi)

    p ||- phi_1 & phi_2 is: (p ||- phi_1) & (p ||- phi_2)

    p ||- (exists x) phi is:  (exists x) (p ||- phi)
  ~eq[]

  We will need the following definition later.

  Definition.  p ||-w phi (p ~em[weakly forces] phi) is an abbreviation for p
  ||- ~~~~phi.

  The following exercises were suggested by John Cowles as a means for gaining
  familiarity with the definition of forcing.

  Exercise 1. Consider the formula (phi_1 OR phi_2) as an abbreviation for
  ~~(~~phi_1 & ~~phi_2), Show that p ||- (phi_1 OR phi_2) is equivalent to the
  following.
  ~bv[]
       (forall p' \\in P extending p) (exists p'' \\in P extending p')
        ((p'' ||- phi_1) OR (p'' ||- phi_2))
  ~ev[]

  Exercise 2. Consider the formula (forall x)phi as an abbreviation for
  ~~(exists x)~~phi, Show that p ||- (forall x)phi is equivalent to the following.
  ~bv[]
       (forall x)
        (forall p1 \\in P extending p)
         (exists p2 \\in P extending p1) (p2 ||- phi).
  ~ev[]

  Exercise 3. Prove that p ||-w phi is equivalent to the following.
  ~bv[]
       (forall p' \\in P extending p)
        (exists p'' \\in P extending p') (p'' ||- phi).
  ~ev[]

  Exercise 4. Let phi be a formula of L[g].  Prove:
       M |= (p ||-  phi)[s[p<-p0]] implies
       M |= (p ||-w phi)[s[p<-p0]].

  Exercise 5. Let phi be a formula of L[g].  Prove:
       M |= (p ||-  ~~phi)[s[p<-p0]] iff
       M |= (p ||-w ~~phi)[s[p<-p0]].

  [End of exercises.]

  The definition of forcing stipulates how to view ``p ||- phi(x1,...,xk)'' as
  a new formula theta(p,x1,...,xk).  That is, ``||-'' transforms formulas, so
  for any first-order formula phi, ``p ||- phi'' is just another first-order
  formula.  That observation shows that a formula such as ((p ||- phi) OR (p
  ||- ~~phi)) is really just another first-order formula.  The following
  proposition thus follows easily.

  Proposition 3. For any formula phi of L[g], {p0: M |= ((p ||- phi) OR (p ||-
  ~~phi))[s[p<-p0]]]} is a dense subset of P, which (since it is first-order
  definable with parameters in M) intersects G. -|

  The following proposition is easily proved by a structural induction on phi,
  and is left to the reader.

  Proposition 4. Let phi be a formula of L[g].  Suppose ~c[p0 \in P],
  ~c[p1 \in P],~nl[]
  M |= (p ||- phi)[s[p<-p0]] and p1 extends p0.  Then~nl[]
  M |= (p ||- phi)[s[p<-p1]]. -|

  We will also need the following.

  Proposition 5. The following is dense for any finite set S of Nb-tuples: {p
  \\in P: for some <x_1 ... x_Nb> \\in S, (list x_1 ... x_Nb) \\in
  strip-cars(p)}.  Thus, the function g0 is a total function. -|

  The next lemma tells us that the sentences true in M[G] are those that are
  forced by an element of G.

  Truth Lemma.  Let phi be a formula in L[g], let s be an assignment to the
  free variables of phi, and let p be a variable not in the domain of s.  Then
  M[G] |= phi[s] iff for some p0 \\in G, M |= (p ||- phi)[s[p<-p0]].

  Proof.  The proof is by induction on the structure of phi.  First suppose phi
  is atomic.  Let D* be the set of elements p0 \\in P such that every
  assoc-equal evaluation from the definition of forcing phi returns a pair when
  A is bound to p0.  (Intuitively, this means that p0 is a sufficiently large
  approximation from any G containing p0 to make sense of phi in M[G].)  We
  make the following claim.
  ~bv[]
  (*)   For all p0 \\in G such that p0 \\in D*,
        M[G] |= phi[s] iff M |= (p ||- phi)[s[p<-p0]].
  ~ev[]

  To prove the claim, fix p0 in both G and D*, and recall the function g0
  constructed from G in the definition of M[G].  Suppose that t_1, ..., t_Nb
  are terms and g(t_1, ..., t_Nb) is a subterm of phi.  Then s assigns a value
  in M to each of the t_i.  Let a_i be the value assigned by s to t_i.  Then
  g0(a_1, ..., a_Nb) = (cdr (assoc-equal (list a_1 ... a_Nb) p0)), as the
  assoc-equal is a pair (since p0 \\in D*) and has the indicated value (because
  p0 \\in G).  It follows by the definition of formula phi' in the definition
  of forcing:
  ~bv[]
       M[G] |= phi[s]  iff  M |= phi'(p)[s[p<-p0]]
  ~ev[]
  Moreover, because p0 \\in D* it is clear that this holds if p0 is replaced by
  an arbitrary extension of p0.  Then (*) easily follows.

  By Proposition 5, D* is dense, so there is some p0 in the intersection of D*
  and G.  The forward direction of the conclusion then follows by (*).  The
  reverse direction is clear from (*) by application of Proposition 2 to D* and
  Proposition 4.

  Next, suppose M[G] |= ~~phi[x].  Then it is not the case that M[G] |= phi, so
  by the inductive hypothesis, there is no p0 \\in G for which M |= (p ||-
  phi)[s[p<-p0]].  By Proposition 3, there is p0 \\in G for which M |= (p ||-
  ~~phi)[s[p<-p0]].  For the other direction, suppose it is not the case that
  M[G] |= ~~phi[s].  So M[G] |= phi[s], and by the inductive hypothesis, there
  is p0 \\in G for which M |= (p ||- phi)[s[p<-p0]].  It follows that there is
  no p1 \\in G for which M |= (p ||- ~~phi)[s[p<-p1]], since from such p1 we can
  find a common extension p2 of p0 and p1 (since G is generic), and since p2
  extends p0 then by Proposition 4, M |= (p ||- phi)[s[p<-p2]], contradicting
  (by definition of forcing) M |= (p ||- ~~phi)[s[p<-p1]] since p2 extends p1.

  The case (phi_1 & phi_2) follows easily from the inductive hypothesis.  For
  the forward direction, apply Proposition 4 and the observation that by
  genericity, if p0 \\in G and p1 \\in G then p0 and p1 they have a common
  extension in G.

  Finally, the case (exists x) phi follows trivially from the inductive
  hypothesis. -|

  Truth Lemma Corollary.  The Truth Lemma holds with ||-w replacing ||-.

  Proof.  This is clear by applying the Truth Lemma to ~~~~phi. -|

  Here is our main theorem.  Recall that all first-order theories in our ACL2
  context satisfy the e0-induction scheme.

  Theorem.  M[G] satisfies e0-induction.

  Proof.  We consider an arbitrary instance of e0-induction in L[g], stated
  using a strict well-founded relation <| and a formula phi.  We write phi(y)
  to indicate that y may be among the free variables of phi, and phi(y<-x) to
  denote the result of substituting x for y in phi.
  ~bv[]
    theta(y):   (forall y) [((forall x <| y) phi(y<-x)) -> phi(y)]
             -> (forall y) phi(y)
  ~ev[]
  Our goal is to prove that theta holds in M[G].

  Below, we abuse notation by leaving assignments implicit and by writing ``p
  ||- phi(y0)'' to signify that the formula (p ||- phi(y)) is true in M under
  the extension of the explicit assignment that binds y to y0.  We believe that
  the intended meaning will be clear.

  Consider the following set D.
  ~bv[]
    D = {p \\in P: either p ||-w phi(y0) for all y0,
                  or else
                  for some y0, p ||- ~~phi(y0) and
                               for all y1 <| y0 p ||-w phi(y1)}.
  ~ev[]
  The set D is clearly first-order definable (with parameters) in M.  We claim
  that D is a dense subset of P.  For suppose p0 \\in P; we find p1 \\in D
  extending p0, as follows.  If p0 ||-w phi(y0) for all y0, then we may take p1
  to be p0.  Otherwise, by definition of ||-w and ||-, there is some y0 such
  that for some extension p0' of p0, p0' ||- ~~phi(y0).  Pick a <|-minimal such
  y0, and correspondingly pick p1 so that p1 extends p0 and p1 ||- ~~phi(y0).
  In order to show that p1 \\in D, it remains to show that for all y1 <| y0,
  p1 ||-w phi(y1), i.e., there is no q extending p1 such that q ||- ~~phi(y1).
  This is indeed the case since otherwise q and y1 would contradict the
  <|-minimality of y0.

  Applying the genericity of G and just-proved density of D, pick p0 \\in G
  such that p0 \\in D.  If p0 ||-w phi(y0) for all y0, then by the Truth Lemma
  Corollary, M[G] |= phi(y0) for all y0, and thus M[G] |= theta.  Otherwise,
  since p0 \\in D we may choose y0 such that p0 ||- ~~phi(y0) and for all y1 <|
  y0, p0 ||-w phi(y1).  By the Truth Lemma and its corollary, since p0 \\in G
  we have:
  ~bv[]
  (1)   M[G] |= ~~phi(y0).
  (2)   For all y1 <| y0, M[G] |= phi(y1).
  ~ev[]
  It follows that the antecedent of theta is false in M[G], as witnessed by y =
  y0; thus M[G] |= theta. -|

  Remark.  We close by returning, as promised above, to the question of why so
  much care is necessary in constructing an expansion of M.  We assume
  familiarity here with the notion of a ``non-standard'' natural number of M,
  i.e., one that is greater than the interpretation of any term that has the
  form (+ 1 1 1 ... 1).  Here is a very simple example that illustrates the
  need for some care.  Consider the following event, which introduces a
  function foo with the following property: for all x, if natp(x) then
  natp(foo(x)).
  ~bv[]
       (defchoose foo (y) (x)
         (implies (natp x) (natp y)))
  ~ev[]
  Certainly we can build a model of the above property from a model M of the
  ground-zero theory, by interpreting foo so that for all x for which M
  satisfies natp(x), foo(x) is also a natp in M.  But suppose we start with a
  non-standard model M of the ground-zero theory, and we happen to define
  foo(x) to be 1 for all non-standard natural numbers x and 0 for all other x.
  The resulting expansion of M will not satisfy the e0-induction scheme or even
  the ordinary natural number induction scheme: foo(0)=0 holds in that
  expansion as does the implication foo(n)=0 => foo(n+1)=0 for every natural
  number n of M, standard or not; and yet foo(k)=0 fails for every non-standard
  natural number k of M.")

#+acl2-loop-only
(defmacro defattach (&whole event-form &rest args)

; Warning: See the Important Boot-Strapping Invariants before modifying!

; See the Essay on Defattach.

; Developer note.  A substantial test suite is stored at this UT CS file:
; /projects/acl2/devel-misc/books-devel/examples/defattach/test.lisp

  ":Doc-Section Events

  execute constrained functions using corresponding attached functions~/

  This ~il[documentation] topic is organized into the following sections:

  ~st[Introductory example.]~nl[]
  ~st[Syntax and semantics of defattach.]~nl[]
  ~st[Three primary uses of defattach.]~nl[]
  ~st[Miscellaneous remarks, with discussion of possible user errors.]

  Please ~pl[encapsulate] if you intend to use ~c[defattach] but are not
  already familiar with the use of ~c[encapsulate] to introduce constrained
  functions.

  See community book ~c[books/misc/defattach-example.lisp] for a small example.
  it illustrates how ~c[defattach] may be used to build something like
  ``higher-order'' programs, in which constrained functions may be refined to
  different executable functions.  More uses of ~c[defattach] may be found in
  the ACL2 source code, specifically, file ~c[boot-strap-pass-2.lisp].

  The argument ~c[:skip-checks t] enables easy experimentation with
  ~c[defattach], by permitting use of ~c[:]~ilc[program] mode functions and the
  skipping of semantic checks.  Also permitted is ~c[:skip-checks nil] (the
  default) and ~c[:skip-checks :cycles], which turns off only the update of the
  extended ancestor relation (see below) and hence the check for cycles in this
  relation; see below.  We do not make any logical claims when the value of
  ~c[:skip-checks] is non-~c[nil]; indeed, a trust tag is required in this
  case (~pl[defttag]).  Remark for those who use the experimental HONS
  extension (~pl[hons-and-memoization]): the interaction of memoization and
  attachments is not tracked for attachments introduced with a non-~c[nil]
  value of ~c[:skip-checks].  For more discussion of ~c[:skip-checks t],
  ~pl[defproxy]; we do not discuss ~c[:skip-checks] further, here.

  ~st[Introductory example.]

  We begin with a short log illustrating the use of ~c[defattach].  Notice that
  after evaluating the event ~c[(defattach f g)], a call of the constrained
  function ~c[f] is evaluated by instead calling ~c[g] on the arguments.

  ~bv[]
  ACL2 !>(encapsulate
          ((f (x) t :guard (true-listp x)))
          (local (defun f (x) x))
          (defthm f-property
            (implies (consp x) (consp (f x)))))
  [... output omitted ...]
   T
  ACL2 !>(defun g (x)
           (declare (xargs :guard (or (consp x) (null x))))
           (cons 17 (car x)))
  [... output omitted ...]
   G
  ACL2 !>(f '(3 4)) ; undefined function error


  ACL2 Error in TOP-LEVEL:  ACL2 cannot ev the call of undefined function
  F on argument list:

  ((3 4))

  To debug see :DOC print-gv, see :DOC trace, and see :DOC wet.

  ACL2 !>(defattach f g)
  [... output omitted ...]
   :ATTACHMENTS-RECORDED
  ACL2 !>(f '(3 4)) ; f is evaluated using g
  (17 . 3)
  ACL2 !>(trace$ f g)
   ((F) (G))
  ACL2 !>(f '(3 4)) ; f is evaluated using g
  1> (ACL2_*1*_ACL2::F (3 4))
    2> (ACL2_*1*_ACL2::G (3 4))
      3> (G (3 4))
      <3 (G (17 . 3))
    <2 (ACL2_*1*_ACL2::G (17 . 3))
  <1 (ACL2_*1*_ACL2::F (17 . 3))
  (17 . 3)
  ACL2 !>(defattach f nil) ; unattach f (remove its attachment)
  [... output omitted ...]
   :ATTACHMENTS-RECORDED
  ACL2 !>(f '(3 4)) ; undefined function error once again
  1> (ACL2_*1*_ACL2::F (3 4))


  ACL2 Error in TOP-LEVEL:  ACL2 cannot ev the call of undefined function
  F on argument list:

  ((3 4))

  To debug see :DOC print-gv, see :DOC trace, and see :DOC wet.

  ACL2 !>
  ~ev[]

  ~st[Syntax and semantics of defattach.]

  The log above shows that the event ~c[(defattach f g)] allows ~c[g] to be
  used for evaluating calls of ~c[f].  From a logical perspective, the
  evaluation takes place in the addition to the current session of an
  ``attachment equation'' axiom (universally quantified over all ~c[x]) for
  each ~c[defattach] event:
  ~bv[]
  (equal (f x) (g x)) ;;; attachment equation axiom for (defattach f g)
  ~ev[]

  Below we explain ~c[defattach] in some detail.  But it is important to keep
  in mind that evaluation with the attachment equations takes place in an
  extension of the logical theory of the session.  ACL2 guarantees that this
  so-called ``evaluation theory'' remains consistent, assuming the absence of
  ~ilc[defaxiom] ~il[events] from the user.  This guarantee is a consequence of
  a more general guarantee: an ACL2 logical ~il[world] exists in which (loosely
  speaking) the attachment equation for ~c[(defattach f g)], as
  ~c[(defun f (...) (g ...))], takes the place of the original defining event
  for ~c[f], for each ~c[defattach] event.  This more general guarantee holds
  even if there are ~ilc[defaxiom] events, though as explained below, no
  function symbol that syntactically supports a ~c[defaxiom] formula is allowed
  to get an attachment.  A deeper discussion of the logical issues is
  available (but not intended to be read by most users) in a long comment in
  the ACL2 source code labeled ``Essay on Defattach.''

  ~bv[]
  Example Forms:
  (defattach f g)   ; call g in place of calling constrained function f
  (defattach (f g)) ; same as just above
  (defattach (f g :hints ((\"Goal\" :in-theory (enable foo)))))
                    ; equivalent to first form above, except with hints for the
                    ; proof that the guard of f implies the guard of g
  (defattach (f g :hints ((\"Goal\" :in-theory (enable foo)))
                  :otf-flg t))
                    ; as above, except with an :otf-flg of t for the proof that
                    ; the guard of f implies the guard of g
  (defattach (f g)
             :hints ((\"Goal\" :use my-thm)))
                    ; equivalent to first form above, except with hints for the
                    ; proof that the constraints on f hold for g
  (defattach (f g)
             :hints ((\"Goal\" :use my-thm))
             :otf-flg t)
                    ; as above, except with an :otf-flg of t for the proof that
                    ; the constraints on f hold for g
  (defattach (f g)
             (h j)) ; Attach g to f and attach j to h
  (defattach (f g :attach nil)
             (h j)) ; Same as just above, including the same proof obligations,
                    ; except for one difference: because of :attach nil, calls
                    ; of f will not be evaluated, i.e., there will be no
                    ; executable attachment of g to f
  (defattach (f nil)
             (h j)) ; Attach j to h and unattach f
  (defattach (f g :hints ((\"Goal\" :in-theory (enable foo))))
             (h j :hints ((\"Goal\" :in-theory (enable bar))))
             :hints ((\"Goal\" :use my-thm)))
                    ; Attach g to f and attach j to h, with hints:
                    ; - For proving that the guard of f implies the guard of g,
                    ;   enable foo;
                    ; - For proving that the guard of h implies the guard of j,
                    ;   enable bar; and
                    ; - For proving that the constraints on f and h hold for
                    ;   g and j (respectively), use theorem my-thm.


  (defattach f nil)   ; remove the attachment of f, if any (e.g., g above)
  (defattach (f nil)) ; same as just above~/

  General Forms:
  (defattach f g)   ; single attach or, if g is nil, unattach
  (defattach (f1 g1 :kwd val ...)
             ...
             (fk gk :kwd' val' ...)
             :kwd'' val'' ...)
  ~ev[]
  where each indicated keyword-value pair is optional and each keyword is one
  of ~c[:ATTACH], ~c[:HINTS], ~c[:OTF-FLG], or ~c[:INSTRUCTIONS].  The
  value of each ~c[:ATTACH] keyword is either ~c[t] or ~c[nil], with default
  ~c[t] except that the value of ~c[:ATTACH] at the ``top level,'' after each
  entry ~c[(fi gi ...)], is the default for each ~c[:ATTACH] keyword supplied
  in such an entry.  We discuss the ~c[:ATTACH] keyword later in this
  ~il[documentation] topic.  The associated values for the other keywords have
  the usual meanings for the proof obligations described below: the guard proof
  obligation for keywords within each ~c[(fi gi ...)] entry, and the constraint
  proof obligation for keywords at the top level.  No keyword may occur twice
  in the same context, i.e., within the same ~c[(fi gi ...)] entry or at the
  top level; and ~c[:INSTRUCTIONS] may not occur in the same context with
  ~c[:HINTS] or ~c[:OTF-FLG].

  The first General Form above is simply an abbreviation for the form
  ~c[(defattach (f g))], which is an instance of the second General Form above.
  For the second General Form we say that ~c[gi] is ``attached to'' ~c[fi] (by
  the ~c[defattach] event) if ~c[gi] is not ~c[nil], and otherwise we say that
  ~c[fi] is ``unattached'' (by the ~c[defattach] event).  It is also convenient
  to refer to ~c[<fi,gi>] as an ``attachment pair'' (of the event) if ~c[gi] is
  not ~c[nil].  We may refer to the set of ~c[fi] as the ``attachment nest'' of
  each ~c[fi].

  We start with a brief introduction to the first General Form in the case that
  ~c[g] is not ~c[nil].  This form arranges that during evaluation, with
  exceptions noted below, every call of the constrained function symbol ~c[f]
  will in essence be replaced by a call of the function symbol ~c[g] on the
  same arguments.  We may then refer to ~c[g] as the ``attachment of'' ~c[f],
  or say that ``~c[g] is attached to ~c[f].''  Notable exceptions, where we do
  not use attachments during evaluation, are for macroexpansion, evaluation of
  ~ilc[defconst] and ~ilc[defpkg] terms, evaluation during ~ilc[table] events,
  some ~il[stobj] operations including all ~il[stobj updates], and especially
  evaluation of ground terms (terms without free variables) during proofs.
  However, even for these cases we allow the use of attachments in the first
  argument of ~ilc[prog2$] and, more generally, the next-to-last
  (i.e., second) argument of ~ilc[return-last] when its first argument is not
  of the form ~c['m] for some macro, ~c[m].

  To see why attachments are disallowed during evaluation of ground terms
  during proofs (except for the ~ilc[prog2$] and ~ilc[return-last] cases
  mentioned above), consider the following example.
  ~bv[]
  (defstub f (x) t)
  (defun g (x) (+ 3 x))
  (defattach f g)
  ~ev[]
  If the form ~c[(f 2)] is submitted at the ACL2 prompt, the result will be
  ~c[5] because the attachment ~c[g] of ~c[f] is called on the argument,
  ~c[2].  However, during a proof the term ~c[(f 2)] will not be simplified to
  ~c[5], since that would be unsound, as there are no axioms about ~c[f] that
  would justify such a simplification.

  For the case that ~c[g] is ~c[nil] in the first General Form above, the
  result is the removal of the existing attachment to ~c[f], if any.  After
  this removal, calls of ~c[f] will once again cause errors saying that ``ACL2
  cannot ev the call of undefined function ~c[f] ...''.  In this case not only
  is the previous attachment to ~c[f] removed; moreover, for every function
  symbol ~c[f'] in the attachment nest of ~c[f] in the ~c[defattach] event that
  introduced the existing attachment to ~c[f], then ~c[f'] is unattached.  (An
  example near the end of this ~il[documentation] topic shows why this
  unattachment needs to be done.) Such removal takes place before the current
  ~c[defattach] is processed, but is restored if the new event fails to be
  admitted.

  We focus henceforth on the second General Form.  There must be at least one
  attachment, i.e., ~c[i] must be at least 1.  All keywords are optional; their
  role is described below.  The ~c[fi] must be distinct constrained function
  symbols, that is, function symbols all introduced in ~il[signature]s of
  ~ilc[encapsulate] ~il[events] (or macros such as ~ilc[defstub] that generate
  ~ilc[encapsulate] events).  Each non-~c[nil] ~c[gi] is a
  ~c[:]~ilc[logic]-mode function symbol that has had its guards verified, with
  the same ~il[signature] as ~c[fi] (though formal parameters for ~c[fi] and
  ~c[gi] may have different names).  (Note: The macro ~c[defattach!], defined
  in community book ~c[books/misc/defattach-bang], avoids this restriction.)
  This event generates proof obligations and an ordering check, both described
  below.  The effect of this event is first to remove any existing attachments
  for all the function symbols ~c[fi], as described above for the first General
  Form, and then to attach each ~c[gi] to ~c[fi].

  Proof obligations must be checked before making attachments.  For this
  discussion we assume that each ~c[gi] is non-~c[nil] (otherwise first remove
  all attachment pairs ~c[<fi,gi>] for which ~c[gi] is nil).  Let ~c[s] be the
  functional substitution mapping each ~c[fi] to ~c[gi].  For any term ~c[u],
  we write ~c[u\\s] for the result of applying ~c[s] to ~c[u]; that is,
  ~c[u\\s] is the ``functional instance'' obtained by replacing each ~c[fi] by
  ~c[gi] in ~c[u].  Let ~c[G_fi] and ~c[G_gi] be the guards of ~c[fi] and
  ~c[gi], respectively.  Let ~c[G_fi'] be the result of replacing each formal
  of ~c[fi] by the corresponding formal of ~c[gi] in ~c[G_fi].  ACL2 first
  proves, for each ~c[i] (in order), the formula ~c[(implies G_fi' G_gi)\\s].
  If this sequence of proofs succeeds, then the remaining formula to prove is
  the functional instance ~c[C\\s] of the conjunction ~c[C] of the constraints
  on the symbols ~c[fi]; ~pl[constraint].  This last proof obligation is thus
  similar to the one generated by functional instantiation (~pl[constraint]).
  As with functional instantiation, ACL2 stores the fact that such proofs have
  been done so that they are avoided in future events (~pl[lemma-instance]).
  Thus, you will likely avoid some proofs with the sequence
  ~bv[]
  (defattach f g)
  (defattach f nil)
  (defattach f g)
  (defattach f nil)
  ...
  ~ev[]
  rather than the sequence:
  ~bv[]
  (defattach f g)
  :u
  (defattach f g)
  :u
  ...
  ~ev[]

  It remains to describe an ordering check.  We begin with the following
  motivating example.
  ~bv[]
  (defstub f (x) t) ; constrained function with no constraints
  (defun g (x) (declare (xargs :guard t)) (not (f x)))
  (defattach f g) ; ILLEGAL!
  ~ev[]
  Were the above ~c[defattach] event to succeed, the evaluation theory
  (discussed above) would be inconsistent: ~c[(f x)] equals ~c[(g x)] by the
  new attachment equation, which in turn equals ~c[(not (f x))] by definition
  of ~c[g].  The evaluation would therefore be meaningless.  Also, from a
  practical perspective, there would be an infinite loop resulting from any
  call of ~c[f].

  We consider a function symbol ~c[g] to be an ``extended immediate ancestor
  of'' a function symbol ~c[f] if either of the following two criteria is
  met: (a) ~c[g] occurs in the formula that introduces ~c[f] (i.e., definition
  body or constraint) and ~c[g] is introduced by an event different
  from (earlier than) the event introducing ~c[f]; or (b) ~c[g] is attached to
  ~c[f].  For a proposed ~c[defattach] event, we check that this relation has
  no cycles, where for condition (b) we include all attachment pairs that would
  result, including those remaining from earlier ~c[defattach] events.

  Of course, a special case is that no function symbol may be attached to
  itself.  Similarly, no function symbol may be attached to any of its
  ``siblings'' ~-[] function symbols introduced by the same event ~-[] as
  siblings are considered equivalent for purposes of the acyclicity check.

  ~st[Three primary uses of defattach.]~nl[]

  We anticipate three uses of ~c[defattach]:

  (1) Constrained function execution

  (2) Sound modification of the ACL2 system

  (3) Program refinement

  We discuss these in turn.

  (1) The example at the beginning of this ~il[documentation] illustrates
  constrained function execution.

  (2) ACL2 is written essentially in itself.  Thus, there is an opportunity to
  attaching to system functions.  For example, encapsulated
  function ~c[too-many-ifs-post-rewrite], in the ACL2 source code, receives an
  attachment of ~c[too-many-ifs-post-rewrite-builtin], which implements a
  heuristic used in the rewriter.  To find all such examples, search the source
  code for the string `-builtin'.

  Over time, we expect to continue replacing ACL2 source code in a similar
  manner.  We invite the ACL2 community to assist in this ``open architecture''
  enterprise; feel free to email the ACL2 implementors if you are interested in
  such activity.

  (3) Recall that for an attachment pair ~c[<f,g>], a proof obligation is
  (speaking informally) that ~c[g] satisfies the constraint on ~c[f].  Yet more
  informally speaking, ~c[g] is ``more defined'' than ~c[f]; we can think of
  ~c[g] as ``refining'' ~c[f].  With these informal notions as motivation, we
  can view defattach as providing refinement though the following formal
  observation: the evaluation theory extends the theory of the ACL2 session,
  specifically by the addition of all attachment equations.  For the
  logic-inclined, it may be useful to think model-theoretically: The class of
  models of the evaluation theory is non-empty but is a subset of the class of
  models of the current session theory.

  ~st[Miscellaneous remarks, with discussion of possible user errors.]

  We conclude with remarks on some details.

  A ~c[defattach] event is never redundant (~pl[redundant-events]); in that
  sense it is analogous to ~ilc[in-theory].

  As mentioned above, the use of attachments is disabled for evaluation of
  ground terms during proofs.  However, attachments can be used on code during
  the proof process, essentially when the ``program refinement'' is on theorem
  prover code rather than on functions we are reasoning about.  The attachment
  to ~c[too-many-ifs-post-rewrite] described above provides one example of such
  attachments.  Meta functions and clause-processor functions can also have
  attachments, with the restriction that no common ancestor with the evaluator
  can have an attachment; ~pl[evaluator-restrictions].

  For an attachment pair ~c[<f,g>], evaluation of ~c[f] never consults the
  ~il[guard] of ~c[f].  Rather, control passes to ~c[g], whose guard is checked
  if necessary.  The proof obligation related to guards, as described above,
  guarantees that any legal call of ~c[f] is also a legal call of ~c[g].  Thus
  for guard-verified code that results in calls of ~c[f] in raw Lisp, it is
  sound to replace these calls with corresponding calls of ~c[g].

  ~c[Defattach] events are illegal inside any ~ilc[encapsulate] event with a
  non-empty ~il[signature] unless they are ~il[local] to the ~ilc[encapsulate].

  We next discuss a restriction based on a notion of a function symbol
  syntactically supporting an event.  Function symbol ~c[f] is ~em[ancestral]
  in event ~c[E] if either ~c[f] occurs in ~c[E], or (recursively) ~c[f] occurs
  in an event ~c[E'] that introduces some function symbol ~c[g] that is
  ancestral in ~c[E].  We require that no function symbol ancestral in the
  formula of a ~ilc[defaxiom] event may have an attachment.  Theoretical
  reasons are discussed in comments in the ACL2 source code, but here we give a
  little example showing the need for some such restriction: without it, we
  show how to prove ~c[nil]!
  ~bv[]
  (defn g1 () 1)
  (defn g2 () 2)
  (defstub f1 () t)
  (defstub f2 () t)
  (defund p (x)
    (declare (ignore x))
    t)
  (defevaluator evl evl-list
    ((p x)))
  (defaxiom f1-is-f2
    (equal (f1) (f2)))
  (defun meta-fn (x)
    (cond ((equal (f1) (f2))
           x)
          (t *nil*)))
  (defthm bad-meta-rule
    (equal (evl x a)
           (evl (meta-fn x) a))
    :rule-classes ((:meta :trigger-fns (p))))
  (defattach f1 g1)
  (defattach f2 g2)
  (defthm contradiction
    nil
    :hints ((\"Goal\" :use ((:instance (:theorem (not (p x)))
                                     (x t)))))
    :rule-classes nil)
  ~ev[]

  To see all attachments: ~c[(all-attachments (w state))].  (Note that
  attachments introduced with a non-~c[nil] value of ~c[:skip-checks] will be
  omitted from this list.)

  Next we discuss the ~c[:ATTACH] keyword.  There is rarely if ever a reason to
  specify ~c[:ATTACH T], but the following (admittedly contrived) example shows
  why it may be necessary to specify ~c[:ATTACH NIL].  First we introduce three
  new function symbols.
  ~bv[]
    (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))))
  ~ev[]
  Now suppose we want to attach the function ~ilc[acl2-numberp] to both ~c[f]
  and ~c[h].
  ~bv[]
    (defattach (f acl2-numberp) (h acl2-numberp))
  ~ev[]
  Such an attempt fails, because the following constraint is generated but is
  not a theorem: ~c[(EQUAL (ACL2-NUMBERP X) (G X))].  Clearly we also need to
  attach to ~c[g] as well.
  ~bv[]
    (defattach (f acl2-numberp) (h acl2-numberp) (g acl2-numberp))
  ~ev[]
  But this fails for a different reason, as explained by the error message:
  ~bv[]
    ACL2 Error in ( DEFATTACH (F ACL2-NUMBERP) ...):  It is illegal to
    attach to function symbol G, because it was introduced with DEFUN.
    See :DOC defattach.
  ~ev[]
  That is: logically, we need to attach ~c[acl2-numberp] to ~c[g], but we
  cannot actually attach to ~c[g] because it was introduced with ~ilc[defun],
  not with ~ilc[encapsulate].  So we specify ~c[:ATTACH NIL] for the attachment
  to ~c[g], saying that no actual attachment should be made to the code for
  ~c[g], even though for logical purposes we should consider that ~c[g] has
  been given the indicated attachment.
  ~bv[]
    (defattach (f acl2-numberp) (h acl2-numberp) (g acl2-numberp :attach nil))
  ~ev[]
  Finally, we can check that ~c[f], ~c[g], and ~c[h] execute as expected.
  ~bv[]
      ACL2 !>(assert-event (and (f 3)
                         (not (f t))
                         (g 3)
                         (not (g t))
                         (h 3)
                         (not (h t))))
       :PASSED
      ACL2 !>
  ~ev[]

  We conclude with an example promised above, showing why it is necessary in
  general to unattach all function symbols in an existing attachment nest when
  unattaching any one of those function symbols.  Consider the following
  example.
  ~bv[]
  (defstub f1 () t)
  (encapsulate ((f2 () t))
    (local (defun f2 () (f1)))
    (defthm f2=f1 (equal (f2) (f1))))
  (encapsulate ((f3 () t))
    (local (defun f3 () (f1)))
    (defthm f3=f1 (equal (f3) (f1))))
  (defun four () (declare (xargs :guard t)) 4)
  (defun five () (declare (xargs :guard t)) 5)
  (defattach (f1 four) (f2 four))
  (defattach (f1 five) (f3 five))
  ~ev[]
  The second ~c[defattach] replaces erases the existing attachment pair
  ~c[<f1,four>] before installing the new attachment pairs ~c[<f1,five>] and
  ~c[<f3,five>].  After the second defattach, both ~c[(f1)] and ~c[(f3)]
  evaluate to 5.  Now suppose that the attachment pair ~c[<f2,four>] were not
  erased.  Then we would have ~c[(f1)] evaluating to 5 and ~c[(f2)] evaluating
  to 4, contradicting the constraint ~c[f2=f1].  The evaluation theory would
  thus be inconsistent, and at a more concrete level, the user might well be
  surprised by evaluation results if the code were written with the assumption
  specified in the constraint ~c[f2=f1].~/"

  (list 'defattach-fn
        (list 'quote args)
        'state
        (list 'quote event-form)))

; Now we define defattach in raw Lisp.

#-acl2-loop-only
(progn

(defun attachment-symbol (x)

; Here we assume that the only use of the symbol-value of *1*f is to indicate
; that this value is the function attached to f.

  (*1*-symbol x))

(defun set-attachment-symbol-form (fn val)
  `(defparameter ,(attachment-symbol fn) ',val))

(defmacro defattach (&rest args)
  (cond
   ((symbolp (car args))
    (set-attachment-symbol-form (car args) (cadr args)))
   (t
    (let (ans)
      (dolist (arg args)
        (cond ((keywordp arg)
               (return))
              (t (push (set-attachment-symbol-form
                        (car arg)
                        (cond ((let ((tail (assoc-keyword :attach
                                                          (cddr arg))))
                                 (and tail (null (cadr tail))))
                               nil)
                              (t (cadr arg))))
                       ans))))
      (cons 'progn ans)))))
)

; Note:  Important Boot-Strapping Invariants

; If any of the above forms are modified, be sure to change the
; setting of *initial-event-defmacros* as described there.  Each of
; the defmacros above (except those excused) is of a rigid form
; recognized by the function primordial-event-macro-and-fn.  For
; example, there are no declarations and the bodies used above are
; simple enough to be translatable by boot-translate before the world
; is created.

; More subtly, except for local, each macro generates a call of a
; corresponding -fn function on some actuals computed from the macros
; args: THE FORMALS OF THE -fn FUNCTIONS CAN BE DETERMINED BY LOOKING
; AT THE ACTUALS!  For example, we can see that the 'formals for
; 'in-theory-fn, whenever it gets defined, will be '(expr state doc
; event-form).  The function primordial-event-macro-and-fn1 computes
; the formals from the actuals.  Don't change the expressions above,
; don't even change the formals to the defmacros, and don't change the
; formals of the -fns unless you understand this!

; End of *initial-event-defmacros* discussion.


; GETPROP - an efficient applicative property list replacement.

; We provide here a property list facility with applicative
; semantics.  The two primitive operations are putprop and
; getprop.  A ``world-alist'' is a list of ``triples'' of the
; form (symbol key . val).  Putprop conses triples on to a given
; world-alist.  Getprop take a symbol and key and looks for the
; first member of the given world-alist with the given symbol and
; key, returning the corresponding val, or a default if no such
; triple is found.

; In the ``usual case'', the cost of a getprop will be no more than
; the cost of a couple of get's in Common Lisp, rather than a search
; linear in the length of the given world-alist.  The efficiency is
; based upon the strange ``world-name'' extra argument of getprop.
; Formally, world-name is to be regarded as a parameter of getprop
; that is simply ignored.  Practically speaking, getprop uses this
; hint to check whether the given world-alist is in fact currently and
; validly represented by a set of properties on property lists.  To do
; this, getprop checks that as the 'acl2-world-pair property of the
; given world-name, there is a pair whose car is (eq) the given
; world-alist.  If this is the case, then the cdr of the pair, say
; world-key, is a gensymed symbol.  The world-key property of any
; given symbol, symb, is an alist containing exactly those pairs (key
; . val) such that (symb key . val) is in world-alist.  That is, to
; find the key property of symb it is sufficient to assoc-eq for key
; up the alist obtained by (get symb world-key).

; For a more thorough description of the issues concerning
; installation of worlds, see the discussion in interface-raw.lisp,
; under the section heading EXTENDING AND RETRACTING PROPERTY LIST
; WORLDS.

; To use getprop and putprop effectively, one must think clearly in
; terms of the usual order of Lisp evaluation.  Getprop is only fast
; on worlds that have been ``installed'' as by extend-world or
; retract-world.

(deflabel worldp) ; reserving this symbol for later use

(defun plist-worldp (alist)
  (declare (xargs :guard t))

; The following shortcut speeds up this function's execution.  It seems
; slightly risky: if we can somehow get the installed world to be eq to a world
; in a theorem (say, by honsing both), and if that world does not actually
; satisfy the logical definition of plist-worldp, then we could prove nil.
; Initially we included community book books/centaur/doc, creating a world of
; length 359,153 (in a post-4.3 development version), and it took about 1/50
; second to do this check without the above shortcut; so performance didn't
; seem too critical an issue here.  However, the regression slowed down
; significantly without the shortcut.  Here are statistics from HONS
; regressions using identical books, on the same unloaded machine.

; With shortcut:
; 15634.000u 1057.650s 53:22.39 521.2%  0+0k 352216+1367056io 1789pf+0w

; Without shortcut:
; 16414.440u 1048.600s 57:20.82 507.5%  0+0k 354128+1367184io 1696pf+0w

; So we have decided to keep the shortcut, since we really do expect this
; simple property to hold of any ACL2 world.

  #-acl2-loop-only
  (cond ((eq alist (w *the-live-state*))
         (return-from plist-worldp t)))

  (cond ((atom alist) (eq alist nil))
        (t
         (and (consp (car alist))
              (symbolp (car (car alist)))
              (consp (cdr (car alist)))
              (symbolp (cadr (car alist)))
              (plist-worldp (cdr alist))))))

(defthm plist-worldp-forward-to-assoc-eq-equal-alistp
  (implies (plist-worldp x)
           (assoc-eq-equal-alistp x))
  :rule-classes :forward-chaining)

(defdoc getprop
  ":Doc-Section ACL2::ACL2-built-ins

  access fast property lists~/

  ~bv[]
  General form:
  (getprop symb key default world-name world-alist)
  ~ev[]

  See community book ~c[books/misc/getprop.lisp] for an example that
  illustrates the use of ACL2 utilities ~ilc[getprop] and ~c[putprop] to take
  advantage of under-the-hood Lisp (hashed) property lists.

  To see the ACL2 definition of this function, ~pl[pf].~/~/")

(defun putprop (symb key value world-alist)

  ":Doc-Section ACL2::ACL2-built-ins

  update fast property lists~/

  ~bv[]
  General form:
  (putprop symbol key value world-alist)
  ~ev[]

  See community book ~c[books/misc/getprop.lisp] for an example that
  illustrates the use of ACL2 utilities ~ilc[getprop] and ~c[putprop] to take
  advantage of under-the-hood Lisp (hashed) property lists.

  To see the ACL2 definition of this function, ~pl[pf].~/~/"

  (declare (xargs :guard (and (symbolp symb)
                              (symbolp key)
                              (plist-worldp world-alist))))
  (cons (cons symb (cons key value)) world-alist))

; Occasionally you will find comments of the form:

; On Metering

; Occasionally in this code you will see forms protected by
; #+acl2-metering.  If you (push :acl2-metering *features*) and then
; recompile the affected forms, you will get some additional printing
; that indicates random performance meters we have found useful.

; The following two definitions support a particularly common style of
; metering we do.  Suppose you have a typical tail recursive fn for
; exploring a big list

; (defun scan (lst)
;   (cond (test
;          finish)
;         (t
;          (scan (cdr lst)))))

; We often meter it with:

; (defun scan (lst)
;   (cond (test
;          #+acl2-metering (meter-maid 'scan 100)
;          finish)
;         (t
;          #+acl2-metering (setq meter-maid-cnt (1+ meter-maid-cnt))
;          (scan (cdr lst)))))

; Where (meter-maid 'scan 100) tests meter-maid-cnt against 100 and if
; it is bigger prints a msg about 'scan.  In any case, meter-maid
; resets cnt to 0.  This style of metering is not very elegant because
; meter-maid-cnt ought to be initialized cleanly to 0 "at the top" and
; protected against error aborts (i.e., by binding it).  But to do
; that we'd have to recode many of our tail recursive functions so
; they had preludes and lets.  With our meter-maid style, we can just
; insert the metering text into the existing text and preserve the
; tail recursion and lack of initialization.  Not often in metered
; runs do we abort (leaving meter-maid-cnt artificially high) and that
; results (at worst) in a spurious report on the next metered call.

#-acl2-loop-only
(defparameter meter-maid-cnt 0)

#-acl2-loop-only
(defun meter-maid (fn maximum &optional arg1 arg2 cnt)
  (cond ((> (or cnt meter-maid-cnt) maximum)
         (cond
          (arg2
           (format t "~%Meter:  ~s on ~s and ~s used ~s cycles.~%"
                   fn arg1 arg2 (or cnt meter-maid-cnt)))
          (arg1
           (format t "~%Meter:  ~s on ~s used ~s cycles.~%"
                   fn arg1 (or cnt meter-maid-cnt)))
          (t (format t "~%Meter:  ~s used ~s cycles.~%"
                     fn (or cnt meter-maid-cnt))))))
  (setq meter-maid-cnt 0))

; If we ever find this value stored under a property, then getprop acts as
; though no value was found.  Thus, this value had better never be stored as a
; "legitimate" value of the property.  To belabor this point:  we have here a
; fundamental difference between our getprop and Lisp's get.

(defconst *acl2-property-unbound* :acl2-property-unbound)

(defun getprop-default (symb key default)
  (declare (xargs :guard t))
  (prog2$
   (and (consp default)
        (eq (car default) :error)
        (consp (cdr default))
        (stringp (cadr default))
        (null (cddr default))
        (hard-error 'getprop
                    "No property was found under symbol ~x0 for key ~x1.  ~@2"
                    (list (cons #\0 symb)
                          (cons #\1 key)
                          (cons #\2 (cadr default)))))
   default))

#-acl2-loop-only
(defun-one-output sgetprop1 (symb key default world-alist inst-world-alist
                                  inst-gensym)
  (do ((tl world-alist (cdr tl)))
      ((null tl)
       (getprop-default symb key default))
      (cond ((eq tl inst-world-alist)
             (return-from
              sgetprop1
              (let ((temp (assoc-eq key (get symb inst-gensym))))
                (cond (temp
                       (cond
                        ((cdr temp)
                         (let ((ans (car (cdr temp))))
                           (if (eq ans *acl2-property-unbound*)
                               (getprop-default symb key default)
                               ans)))
                        (t (getprop-default symb key default))))
                      (t (getprop-default symb key default))))))
            ((and (eq symb (caar tl))
                  (eq key (cadar tl)))
             (return-from
              sgetprop1
              (let ((ans (cddar tl)))
                (if (eq ans *acl2-property-unbound*)
                    (getprop-default symb key default)
                    ans)))))))

; The following code, not generally loaded, is used to augment fgetprop to
; determine the frequency with which we access properties.  See the
; fgetprop-stats comment in fgetprop for a description of how to use
; this code.

; (defvar fgetprop-stats nil)
;
; (defvar analyzed-fgetprop-stats nil)
;
; (compile
;  (defun update-fgetprop-stats (sym key)
;    (let* ((sym-entry (assoc sym fgetprop-stats :test #'eq))
;           (key-entry (assoc key (cdr sym-entry) :test #'eq)))
;      (cond (key-entry (setf (cdr key-entry) (1+ (cdr key-entry))))
;            (sym-entry (setf (cdr sym-entry) (cons (cons key 1) (cdr sym-entry))))
;            (t (setq fgetprop-stats
;                     (cons (cons sym (list (cons key 1))) fgetprop-stats)))))))
;
; (compile
;  (defun analyze-fgetprop-stats nil
;    (format t "Properties accessed and access counts:~%")
;    (loop
;     for x in (sort (let ((prop-alist nil))
;                      (loop
;                       for pair in fgetprop-stats
;                       do
;                       (loop
;                        for x in (cdr pair)
;                        do
;                        (let ((temp (assoc (car x) prop-alist :test #'eq)))
;                          (cond (temp (setf (cdr temp) (+ (cdr temp) (cdr x))))
;                                (t (setq prop-alist
;                                         (cons (cons (car x) (cdr x))
;                                               prop-alist)))))))
;                      prop-alist)
;                    #'(lambda (x y) (> (cdr x) (cdr y))))
;     do
;     (format t "~A~50T~9D~%" (car x) (cdr x)))
;    (terpri t)
;    (setq analyzed-fgetprop-stats
;          (sort
;           (loop
;            for pair in fgetprop-stats
;            collect
;            (let* ((other-cutoff 1)
;                   (others
;                    (loop
;                     for x in (cdr pair) when (<= (cdr x) other-cutoff)
;                     sum (cdr x))))
;              (list* (car pair)
;                     (loop for x in (cdr pair) sum (cdr x))
;                     (let ((temp
;                            (sort (loop
;                                   for x in (cdr pair)
;                                   when
;                                   (or (= others 0)
;                                       (= others other-cutoff) ;i.e., just 1 other
;                                       (> (cdr x) other-cutoff))
;                                   collect x)
;                                  #'(lambda (x y)(> (cdr x) (cdr y))))))
;                       (if (> others other-cutoff)
;                           (append temp
;                                   (list (cons "all other" others)))
;                         temp)))))
;           #'(lambda (x y) (> (cadr x) (cadr y)))))
;    (format t "Analyzed fgetprop-stats~%")
;    (loop
;     for trip in analyzed-fgetprop-stats
;     do
;     (format t "~S~45T~9D~%" (car trip) (cadr trip))
;     (loop
;      for pair in (cddr trip)
;      do
;      (format t " ~A~50T~9D~%" (car pair) (cdr pair))))
;    t))

; Note:  In versions before V2.2 the following defvar was in
; interface-raw.lisp.  But it is used earlier than that in the
; initialization process.

(defun fgetprop (symb key default world-alist)

; This is getprop's meaning when we know the world name is 'current-acl2-world.
; The invariant maintained for the 'current-acl2-world is the same as that
; maintained for other world names with the additional fact that the installed
; alist itself is the value of the state global variable 'current-acl2-world,
; whose raw lisp counterpart is ACL2_GLOBAL_ACL2::CURRENT-ACL2-WORLD, and the
; gensym under which the property alist is stored for each symbol is also kept
; in the raw lisp global *current-acl2-world-key*.  Put another way, (get
; 'current-acl2-world 'acl2-world-pair) returns a pair equal to (cons
; ACL2_GLOBAL_ACL2::CURRENT-ACL2-WORLD *current-acl2-world-key*).

  (declare (xargs :guard (and (symbolp symb)
                              (symbolp key)
                              (plist-worldp world-alist))))

  #+acl2-loop-only
  (cond ((endp world-alist) default)
        ((and (eq symb (caar world-alist))
              (eq key (cadar world-alist)))
         (let ((ans (cddar world-alist)))
           (if (eq ans *acl2-property-unbound*)
               default
               ans)))
        (t (fgetprop symb key default (cdr world-alist))))

; The following two lines are commented out.  They collect the fgetprop-stats.
; Those stats will tell you, for a given run of the system, which properties
; are accessed, the frequency with which they are accessed, and a breakdown by
; symbol of all the properties accessed.  If you wish to collect the
; fgetprop-stats, then load the code above into raw lisp, remove the two
; semi-colons below, reload this defun of fgetprop, and run some experiments.
; Then use (analyze-fgetprop-stats) to print out the results.  It is generally
; advisable to compile all the defuns just loaded.

; #-acl2-loop-only
; (update-fgetprop-stats symb key)

  #-acl2-loop-only
  (cond
   ((eq world-alist
        (symbol-value 'ACL2_GLOBAL_ACL2::CURRENT-ACL2-WORLD))
    (let ((temp
           (assoc-eq key
                     (get symb *current-acl2-world-key*))))
      (cond (temp
             (cond
              ((cdr temp)
               (let ((ans (car (cdr temp))))
                 (if (eq ans *acl2-property-unbound*)
                     (getprop-default symb key default)
                     ans)))
              (t (getprop-default symb key default))))
            (t (getprop-default symb key default)))))
   (t (sgetprop1 symb key default world-alist
                 (symbol-value 'ACL2_GLOBAL_ACL2::CURRENT-ACL2-WORLD)
                 *current-acl2-world-key*))))

(defun sgetprop (symb key default world-name world-alist)

; This is getprop's meaning when we don't know the world-name.

  (declare (xargs :guard (and (symbolp symb)
                              (symbolp key)
                              (symbolp world-name)
                              (plist-worldp world-alist))))

; Note that if default has the form '(:error string) where string is a
; stringp, then in raw Lisp we execute a hard error with context
; 'getprop and string string.  Otherwise (and logically in any case),
; default is what we return when there is no key property of symb.

  #+acl2-loop-only
  (cond ((endp world-alist) default)
        ((and (eq symb (caar world-alist))
              (eq key (cadar world-alist)))
         (let ((ans (cddar world-alist)))
           (if (eq ans *acl2-property-unbound*)
               default
             ans)))
        (t (sgetprop symb key default world-name (cdr world-alist))))
  #-acl2-loop-only
  (let ((pair (get world-name 'acl2-world-pair)))
    (cond (pair (sgetprop1 symb key default world-alist (car pair) (cdr pair)))
          (t (do ((tl world-alist (cdr tl)))
                 ((null tl)
                  (getprop-default symb key default))
                 (cond ((and (eq symb (caar tl))
                             (eq key (cadar tl)))
                        (return-from
                         sgetprop
                         (let ((ans (cddar tl)))
                           (if (eq ans *acl2-property-unbound*)
                               (getprop-default symb key default)
                             ans))))))))))

(defun ordered-symbol-alistp (x)

; An ordered-symbol-alist is an alist whose keys are symbols which are
; in the symbol-< order.

  (declare (xargs :guard t))
  (cond ((atom x) (null x))
        ((atom (car x)) nil)
        (t (and (symbolp (caar x))
                (or (atom (cdr x))
                    (and (consp (cadr x))
                         (symbolp (caadr x))
                         (symbol-< (caar x)
                                   (caadr x))))
                (ordered-symbol-alistp (cdr x))))))

(in-theory (disable symbol-<))

(defthm ordered-symbol-alistp-forward-to-symbol-alistp
  (implies (ordered-symbol-alistp x)
           (symbol-alistp x))
  :rule-classes :forward-chaining)

(defun add-pair (key value l)
  (declare (xargs :guard (and (symbolp key)
                              (ordered-symbol-alistp l))))
  (cond ((endp l)
         (list (cons key value)))
        ((eq key (caar l))
         (cons (cons key value) (cdr l)))
        ((symbol-< key (caar l))
         (cons (cons key value) l))
        (t (cons (car l)
                 (add-pair key value (cdr l))))))

; Delete-assoc

(defun delete-assoc-eq-exec (key alist)
  (declare (xargs :guard (if (symbolp key)
                             (alistp alist)
                           (symbol-alistp alist))))
  (cond ((endp alist) nil)
        ((eq key (caar alist)) (cdr alist))
        (t (cons (car alist) (delete-assoc-eq-exec key (cdr alist))))))

(defun delete-assoc-eql-exec (key alist)
  (declare (xargs :guard (if (eqlablep key)
                             (alistp alist)
                           (eqlable-alistp alist))))
  (cond ((endp alist) nil)
        ((eql key (caar alist)) (cdr alist))
        (t (cons (car alist) (delete-assoc-eql-exec key (cdr alist))))))

(defun delete-assoc-equal (key alist)
  (declare (xargs :guard (alistp alist)))
  (cond ((endp alist) nil)
        ((equal key (caar alist)) (cdr alist))
        (t (cons (car alist) (delete-assoc-equal key (cdr alist))))))

(defmacro delete-assoc-eq (key lst)
  `(delete-assoc ,key ,lst :test 'eq))

(defthm delete-assoc-eq-exec-is-delete-assoc-equal
  (equal (delete-assoc-eq-exec key lst)
         (delete-assoc-equal key lst)))

(defthm delete-assoc-eql-exec-is-delete-assoc-equal
  (equal (delete-assoc-eql-exec key lst)
         (delete-assoc-equal key lst)))

(defmacro delete-assoc (key alist &key (test ''eql))

  ":Doc-Section ACL2::ACL2-built-ins

  remove the first pair from an association list for a given key~/
  ~bv[]
  General Forms:
  (delete-assoc key alist)
  (delete-assoc key alist :test 'eql)   ; same as above (eql as equality test)
  (delete-assoc key alist :test 'eq)    ; same, but eq is equality test
  (delete-assoc key alist :test 'equal) ; same, but equal is equality test
  ~ev[]

  ~c[(Delete-assoc key alist)] returns an alist that is the same as the list
  ~c[alist], except that the first pair in ~c[alist] with a ~ilc[car] of
  ~c[key] is deleted, if there is one; otherwise ~c[alist] is returned.  Note
  that the order of the elements of ~c[alist] is unchanged (though one may be
  deleted).~/

  The ~il[guard] for a call of ~c[delete-assoc] depends on the test.  In all
  cases, the second argument must satisfy ~ilc[alistp].  If the test is
  ~ilc[eql], then either the first argument must be suitable for ~ilc[eql]
  (~pl[eqlablep]) or the second argument must satisfy ~ilc[eqlable-alistp].  If
  the test is ~ilc[eq], then either the first argument must be a symbol or the
  second argument must satisfy ~ilc[symbol-alistp].

  ~l[equality-variants] for a discussion of the relation between
  ~c[delete-assoc] and its variants:
  ~bq[]
  ~c[(delete-assoc-eq key alist)] is equivalent to
  ~c[(delete-assoc key alist :test 'eq)];

  ~c[(delete-assoc-equal key alist)] is equivalent to
  ~c[(delete-assoc key alist :test 'equal)].
  ~eq[]
  In particular, reasoning about any of these primitives reduces to reasoning
  about the function ~c[delete-assoc-equal].~/"

  (declare (xargs :guard (or (equal test ''eq)
                             (equal test ''eql)
                             (equal test ''equal))))
  (cond
   ((equal test ''eq)
    `(let-mbe ((key ,key) (alist ,alist))
              :logic (delete-assoc-equal key alist)
              :exec  (delete-assoc-eq-exec key alist)))
   ((equal test ''eql)
    `(let-mbe ((key ,key) (alist ,alist))
              :logic (delete-assoc-equal key alist)
              :exec  (delete-assoc-eql-exec key alist)))
   (t ; (equal test 'equal)
    `(delete-assoc-equal ,key ,alist))))

(defun getprops1 (alist)

; Each element of alist is of the form (key val1 ... valk), i.e., key is bound
; to a stack of vali's.  We transform each element to (key . val1), i.e., each
; key is bound to the top-most vali.  An empty stack or a top value of
; *acl2-property-unbound* means there is no binding for key.

  (declare (xargs :guard (true-list-listp alist)))
  (cond ((endp alist) nil)
        ((or (null (cdar alist))
             (eq (car (cdar alist)) *acl2-property-unbound*))
         (getprops1 (cdr alist)))
        (t (cons (cons (caar alist) (cadar alist))
                 (getprops1 (cdr alist))))))

(defun getprops (symb world-name world-alist)

; returns all of the properties of symb in world-alist, as a list of
; key-value pairs, sorted according to ordered-symbol-alistp.  We
; respect the *acl2-property-unbound* convention.

  (declare (xargs :guard (and (symbolp symb)
                              (symbolp world-name)
                              (plist-worldp world-alist))
                  :mode :program))
  #+acl2-metering
  (setq meter-maid-cnt (1+ meter-maid-cnt))
  (cond #-acl2-loop-only
        ((eq world-alist (car (get world-name 'acl2-world-pair)))
         #+acl2-metering
         (meter-maid 'getprops 100 symb)
         (sort (getprops1 (get symb (cdr (get world-name 'acl2-world-pair))))
               #'(lambda (x y)
                   (symbol-< (car x) (car y)))))
        ((endp world-alist)
         #+acl2-metering
         (meter-maid 'getprops 100 symb)
         nil)
        ((eq symb (caar world-alist))
         (let ((alist (getprops symb world-name (cdr world-alist))))
           (if (eq (cddar world-alist) *acl2-property-unbound*)
               (if (assoc-eq (cadar world-alist) alist)
                   (delete-assoc-eq (cadar world-alist) alist)
                 alist)
             (add-pair (cadar world-alist)
                       (cddar world-alist)
                       alist))))
        (t (getprops symb world-name (cdr world-alist)))))

(verify-termination-boot-strap getprops (declare (xargs :mode :logic
                                             :verify-guards nil)))

; We don't verify the guards for getprops until we have LOCAL, which really
; means, until LOCAL has STATE-GLOBAL-LET*.

; We disable the following function in order to protect people from getting
; burned by string<-l.

(in-theory (disable string<))

(defthm equal-char-code
  (implies (and (characterp x)
                (characterp y))
           (implies (equal (char-code x) (char-code y))
                    (equal x y)))
  :rule-classes nil
  :hints (("Goal" :use
           ((:instance
             code-char-char-code-is-identity
             (c x))
            (:instance
             code-char-char-code-is-identity
             (c y))))))

(defun has-propsp1 (alist exceptions known-unbound)

; This function is only called from raw lisp code in has-propsp.  Alist is the
; alist of ACL2 properties stored on the property list of some symbol.  As
; such, each element of alist is of the form (prop val1 val2 ... valk) where
; val1 is the most recently stored value of the property prop for that symbol.
; We here check that each val1 is *acl2-property-unbound* (unless prop is among
; exceptions or known-unbound).

  (declare (xargs :guard (and (assoc-eq-equal-alistp alist)
                              (true-listp exceptions)
                              (true-listp known-unbound))))

  (cond ((endp alist) nil)
        ((or (null (cdar alist))
             (eq (cadar alist) *acl2-property-unbound*)
             (member-eq (caar alist) exceptions)
             (member-eq (caar alist) known-unbound))
         (has-propsp1 (cdr alist) exceptions known-unbound))
        (t t)))

(defun has-propsp (symb exceptions world-name world-alist known-unbound)

; We return t iff symb has properties other than those listed in exceptions.

  (declare (xargs :guard (and (symbolp symb)
                              (symbolp world-name)
                              (plist-worldp world-alist)
                              (true-listp exceptions)
                              (true-listp known-unbound))))
  #+acl2-metering
  (setq meter-maid-cnt (1+ meter-maid-cnt))
  (cond #-acl2-loop-only
        ((eq world-alist (car (get world-name 'acl2-world-pair)))
         #+acl2-metering
         (meter-maid 'has-propsp 100 symb)
         (has-propsp1 (get symb (cdr (get world-name 'acl2-world-pair)))
                      exceptions
                      known-unbound))
        ((endp world-alist)
         #+acl2-metering
         (meter-maid 'has-propsp 100 symb)
         nil)
        ((or (not (eq symb (caar world-alist)))
             (member-eq (cadar world-alist) exceptions)
             (member-eq (cadar world-alist) known-unbound))
         (has-propsp symb exceptions world-name (cdr world-alist)
                     known-unbound))
        ((eq (cddar world-alist) *acl2-property-unbound*)
         (has-propsp symb exceptions world-name (cdr world-alist)
                     (cons (cadar world-alist) known-unbound)))
        (t t)))

(defun extend-world (name wrld)

; Logically speaking, this function is a no-op that returns wrld.
; Practically speaking, it changes the Lisp property list
; state so that future getprops on name and wrld will be fast.
; However, wrld must be an extension of the current world installed
; under name, or else a hard error occurs.  Finally, if name is
; 'current-acl2-world, then no changes are made, since we do not want
; the user to smash our world.

  #+acl2-loop-only
  (declare (xargs :guard t)
           (ignore name))
  #+acl2-loop-only
  wrld
  #-acl2-loop-only
  (cond ((eq name 'current-acl2-world)
         wrld)
        (t (extend-world1 name wrld))))

(defun retract-world (name wrld)

; Logically speaking, this function is a no-op that returns wrld.
; Practically speaking, it changes the Lisp property list
; state so that future getprops on name and wrld will be fast.
; However, wrld must be a retraction of the current world installed
; under name, or else a hard error occurs.  Finally, if name is
; 'current-acl2-world, then no changes are made, since we do not want
; the user to smash our world.

  #+acl2-loop-only
  (declare (xargs :guard t)
           (ignore name))
  #+acl2-loop-only
  wrld
  #-acl2-loop-only
  (cond ((eq name 'current-acl2-world)
         wrld)
        (t (retract-world1 name wrld))))

(defun global-val (var wrld)

; If you are tempted to access a global variable value with getprop
; directly, so you can specify your own default value, it suggests
; that you have not initialized the global variable.  See the
; discussion in primordial-world-globals.  Follow the discipline of
; always initializing and always accessing with global-val.

  (declare (xargs :guard (and (symbolp var)
                              (plist-worldp wrld))))
  (getprop var 'global-value
           '(:error "GLOBAL-VAL didn't find a value.  Initialize this ~
                     symbol in PRIMORDIAL-WORLD-GLOBALS.")
           'current-acl2-world wrld))

; Declarations.

(defun function-symbolp (sym wrld)

; Sym must be a symbolp.  We return t if sym is a function symbol and
; nil otherwise.  We exploit the fact that every function symbol has a
; formals property.  Of course, the property may be NIL so when we
; seek it we default to t so we can detect the absence of the
; property.  Of course, if someone were to putprop 'formals t we would
; therefore claim the symbol weren't a function-symbolp.  This fact is
; exploited when we prepare the world for the redefinition of a
; symbol.  If for some reason you change the default, you must change
; it there too.  It would be a good idea to search for 'formals t.

  (declare (xargs :guard (and (symbolp sym)
                              (plist-worldp wrld))))
  (not (eq (getprop sym 'formals t 'current-acl2-world wrld) t)))

; We define translate-declaration-to-guard and accompanying functions in
; program mode, including the-fn, simply so that they take up a little less
; space in the image by avoiding the need to store 'def-bodies and
; 'unnormalized-body properties.

(defun translate-declaration-to-guard/integer (lo var hi)
  (declare (xargs :guard t
                  :mode :program))
  (let ((lower-bound
         (cond ((integerp lo) lo)
               ((eq lo '*) '*)
               ((and (consp lo)
                     (integerp (car lo))
                     (null (cdr lo)))
                (1+ (car lo)))
               (t nil)))
        (upper-bound
         (cond ((integerp hi) hi)
               ((eq hi '*) '*)
               ((and (consp hi)
                     (integerp (car hi))
                     (null (cdr hi)))
                (1- (car hi)))
               (t nil))))
    (cond ((and upper-bound lower-bound)
           (cond ((eq lower-bound '*)
                  (cond ((eq upper-bound '*)
                         (list 'integerp var))
                        (t (list 'and
                                 (list 'integerp var)
                                 (list '<= var upper-bound)))))
                 (t (cond ((eq upper-bound '*)
                           (list 'and
                                 (list 'integerp var)
                                 (list '<= lower-bound var)))
                          (t

; It is tempting to use integer-range-p below.  However, integer-range-p was
; introduced in Version_2.7 in support of signed-byte-p and unsigned-byte-p,
; whose definitions were kept similar to those that had been in the ihs library
; for some time.  Hence, integer-range-p is defined in terms of a strict <
; comparison to the upper integer, which does not fit well with our current
; needs.  (It feels wrong to use (< var (1+ upper-bound)), even though not
; unsound.)

                           (list 'and
                                 (list 'integerp var)
                                 (list '<= lower-bound var)
                                 (list '<= var upper-bound)))))))
          (t nil))))

(defun weak-satisfies-type-spec-p (x)
  (declare (xargs :guard t))
  (and (consp x)
       (eq (car x) 'satisfies)
       (true-listp x)
       (equal (length x) 2)
       (symbolp (cadr x))))

;; RAG - I added entries for 'real and 'complex.  Guards with 'complex
;; have CHANGED SEMANTICS!  Yikes!  Before, the moniker 'complex had
;; the semantics of complex-rationalp.  Now, it has the semantics of
;; complexp.  I added a new declaration, 'complex-rational, to stand
;; for the old semantics of 'complex.

(defun translate-declaration-to-guard1 (x var wrld)

; Wrld is either an ACL2 logical world or a symbol; see
; translate-declaration-to-guard.

  (declare (xargs :guard (or (symbolp wrld)
                             (plist-worldp wrld))
                  :mode :program))
  (cond ((or (eq x 'integer)
             (eq x 'signed-byte))
         (list 'integerp var))
        ((and (consp x)
              (eq (car x) 'integer)
              (true-listp x)
              (equal (length x) 3))
         (translate-declaration-to-guard/integer (cadr x) var (caddr x)))
        ((eq x 'rational) (list 'rationalp var))
        ((eq x 'real) (list 'real/rationalp var))
        ((eq x 'complex) (list 'complex/complex-rationalp var))
        ((and (consp x)
              (eq (car x) 'rational)
              (true-listp x)
              (equal (length x) 3))
         (let ((lower-bound
                (cond ((rationalp (cadr x)) (cadr x))
                      ((eq (cadr x) '*) '*)
                      ((and (consp (cadr x))
                            (rationalp (car (cadr x)))
                            (null (cdr (cadr x))))
                       (list (car (cadr x))))
                      (t nil)))
               (upper-bound
                (cond ((rationalp (caddr x)) (caddr x))
                      ((eq (caddr x) '*) '*)
                      ((and (consp (caddr x))
                            (rationalp (car (caddr x)))
                            (null (cdr (caddr x))))
                       (list (car (caddr x))))
                      (t nil))))
           (cond
            ((and upper-bound lower-bound)
             (cond
              ((eq lower-bound '*)
               (cond
                ((eq upper-bound '*)
                 (list 'rationalp var))
                (t (list 'and
                         (list 'rationalp var)
                         (cond ((consp upper-bound)
                                (list '< var (car upper-bound)))
                               (t (list '<= var upper-bound)))))))
              (t (cond
                  ((eq upper-bound '*)
                   (list 'and
                         (list 'rationalp var)
                         (cond ((consp lower-bound)
                                (list '< (car lower-bound) var))
                               (t (list '<= lower-bound var)))))
                  (t (list 'and
                           (list 'rationalp var)
                           (cond ((consp lower-bound)
                                  (list '< (car lower-bound) var))
                                 (t (list '<= lower-bound var)))
                           (cond ((consp upper-bound)
                                  (list '> (car upper-bound) var))
                                 (t (list '<= var upper-bound)))))))))
            (t nil))))
        ((and (consp x)
              (eq (car x) 'real)
              (true-listp x)
              (equal (length x) 3))
         (let ((lower-bound
                (cond ((real/rationalp (cadr x)) (cadr x))
                      ((eq (cadr x) '*) '*)
                      ((and (consp (cadr x))
                            (real/rationalp (car (cadr x)))
                            (null (cdr (cadr x))))
                       (list (car (cadr x))))
                      (t nil)))
               (upper-bound
                (cond ((real/rationalp (caddr x)) (caddr x))
                      ((eq (caddr x) '*) '*)
                      ((and (consp (caddr x))
                            (real/rationalp (car (caddr x)))
                            (null (cdr (caddr x))))
                       (list (car (caddr x))))
                      (t nil))))
           (cond
            ((and upper-bound lower-bound)
             (cond
              ((eq lower-bound '*)
               (cond
                ((eq upper-bound '*)
                 (list 'real/rationalp var))
                (t (list 'and
                         (list 'real/rationalp var)
                         (cond ((consp upper-bound)
                                (list '< var (car upper-bound)))
                               (t (list '<= var upper-bound)))))))
              (t (cond
                  ((eq upper-bound '*)
                   (list 'and
                         (list 'real/rationalp var)
                         (cond ((consp lower-bound)
                                (list '< (car lower-bound) var))
                               (t (list '<= lower-bound var)))))
                  (t (list 'and
                           (list 'real/rationalp var)
                           (cond ((consp lower-bound)
                                  (list '< (car lower-bound) var))
                                 (t (list '<= lower-bound var)))
                           (cond ((consp upper-bound)
                                  (list '> (car upper-bound) var))
                                 (t (list '<= var upper-bound)))))))))
            (t nil))))
        ((eq x 'bit) (list 'or
                           (list 'equal var 1)
                           (list 'equal var 0)))
        ((and (consp x)
              (eq (car x) 'mod)
              (true-listp x)
              (equal (length x) 2)
              (integerp (cadr x)))
         (translate-declaration-to-guard/integer 0 var (1- (cadr x))))
        ((and (consp x)
              (eq (car x) 'signed-byte)
              (true-listp x)
              (equal (length x) 2)
              (integerp (cadr x))
              (> (cadr x) 0))
         (list 'signed-byte-p (cadr x) var))
        ((eq x 'unsigned-byte)
         (translate-declaration-to-guard/integer 0 var '*))
        ((and (consp x)
              (eq (car x) 'unsigned-byte)
              (true-listp x)
              (equal (length x) 2)
              (integerp (cadr x))
              (> (cadr x) 0))
         (list 'unsigned-byte-p (cadr x) var))
        ((eq x 'atom) (list 'atom var))
        ((eq x 'character) (list 'characterp var))
        ((eq x 'cons) (list 'consp var))
        ((eq x 'list) (list 'listp var))
        ((eq x 'nil)

; We return a translated nil here instead of just nil so as not to
; look like we're saying "This is an unrecognized declaration."

         ''nil)
        ((eq x 'null) (list 'eq var nil))
        ((eq x 'ratio) (list 'and
                             (list 'rationalp var)
                             (list 'not (list 'integerp var))))
        ((eq x 'standard-char) (list 'standard-charp var))
        ((eq x 'string) (list 'stringp var))
        ((and (consp x)
              (eq (car x) 'string)
              (true-listp x)
              (equal (length x) 2)
              (integerp (cadr x))
              (>= (cadr x) 0))
         (list 'and
               (list 'stringp var)
               (list 'equal
                     (list 'length var)
                     (cadr x))))
        ((eq x 'symbol) (list 'symbolp var))
        ((eq x 't) t)
        ((and (weak-satisfies-type-spec-p x)
              (or (symbolp wrld)
                  (eql (length (getprop (cadr x) 'formals nil
                                        'current-acl2-world wrld))
                       1)))
         (list (cadr x) var))
        ((and (consp x)
              (eq (car x) 'member)
              (eqlable-listp (cdr x)))
         (list 'member var (list 'quote (cdr x))))
        (t nil)))

(mutual-recursion

;; RAG - This was modified to change the moniker 'complex to use
;; complexp instead of complex-rationalp.

(defun translate-declaration-to-guard (x var wrld)

; This function is typically called on the sort of x you might write in a TYPE
; declaration, e.g., (DECLARE (TYPE x var1 ... varn)).  Thus, x might be
; something like '(or symbol cons (integer 0 128)) meaning that var is either a
; symbolp, a consp, or an integer in the given range.  X is taken as a
; declaration about the variable symbol var and is converted into an
; UNTRANSLATED term about var, except that we return nil if x is seen not to be
; a valid type-spec for ACL2.

; Wrld is an ACL2 logical world or a symbol (typically, nil), the difference
; being that a symbol indicates that we should do a weaker check.  This extra
; argument was added after Version_3.0 when Dave Greve pointed out that Common
; Lisp only allows the type-spec (satisfies pred) when pred is a unary function
; symbol, not a macro.  Thus, a non-symbol wrld can only strengthen this
; function, i.e., causing it to return nil in more cases.

  (declare (xargs :guard (or (symbolp wrld)
                             (plist-worldp wrld))
                  :mode :program

; See the comment above translate-declaration-to-guard/integer.

;                  :measure (acl2-count x)
                  ))
  (cond ((atom x) (translate-declaration-to-guard1 x var wrld))
        ((eq (car x) 'not)
         (cond ((and (true-listp x)
                     (equal (length x) 2))
                (let ((term (translate-declaration-to-guard (cadr x)
                                                            var
                                                            wrld)))
                  (and term
                       (list 'not term))))
               (t nil)))
        ((eq (car x) 'and)
         (cond ((true-listp x)
                (cond ((null (cdr x)) t)
                      (t (let ((args (translate-declaration-to-guard-lst
                                      (cdr x)
                                      var
                                      wrld)))
                           (cond (args (cons 'and args))
                                 (t nil))))))
               (t nil)))
        ((eq (car x) 'or)
         (cond ((true-listp x)
                (cond ((null (cdr x)) ''nil)
                      (t (let ((args (translate-declaration-to-guard-lst
                                      (cdr x)
                                      var
                                      wrld)))
                           (cond (args (cons 'or args))
                                 (t nil))))))
               (t nil)))
        ((eq (car x) 'complex)
         (cond ((and (consp (cdr x))
                     (null (cddr x)))
                (let ((r (translate-declaration-to-guard (cadr x)
                                                         (list 'realpart var)
                                                         wrld))
                      (i (translate-declaration-to-guard (cadr x)
                                                         (list 'imagpart var)
                                                         wrld)))
                  (cond ((and r i)
                         (list 'and
                               (list 'complex/complex-rationalp var)
                               r
                               i))
                        (t nil))))
               (t nil)))
        (t (translate-declaration-to-guard1 x var wrld))))

(defun translate-declaration-to-guard-lst (l var wrld)

; Wrld is an ACL2 logical world or a symbol; see
; translate-declaration-to-guard.

  (declare (xargs ; :measure (acl2-count l)
                  :guard (and (true-listp l)
                              (consp l)
                              (or (null wrld)
                                  (plist-worldp wrld)))
                  :mode :program))
  (and (consp l)
       (let ((frst (translate-declaration-to-guard (car l) var wrld)))
         (cond ((null frst)
                nil)
               ((endp (cdr l))
                (list frst))
               (t (let ((rst (translate-declaration-to-guard-lst
                              (cdr l)
                              var
                              wrld)))
                    (cond ((null rst) nil)
                          (t (cons frst rst)))))))))

)

(deflabel declare

; Warning: Keep this in sync with acceptable-dcls-alist.

  :doc
  ":Doc-Section ACL2::Programming

  declarations~/
  ~bv[]
  Examples:
  (declare (ignore x y z))
  (declare (ignorable x y z)
           (type integer i j k)
           (type (satisfies integerp) m1 m2))
  (declare (xargs :guard (and (integerp i)
                              (<= 0 i))
                  :guard-hints ((\"Goal\" :use (:instance lemma3
                                                (x (+ i j)))))))~/

  General Form:
  (declare d1 ... dn)
  where, in ACL2, each di is of one of the following forms:

    (ignore v1 ... vn) -- where each vi is a variable introduced in
    the immediately superior lexical environment.  These variables must not
    occur free in the scope of the declaration.

    (ignorable v1 ... vn) -- where each vi is a variable introduced in
    the immediately superior lexical environment.  These variables need not
    occur free in the scope of the declaration.  This declaration can be useful
    for inhibiting compiler warnings.

    (type type-spec v1 ... vn) -- where each vi is a variable introduced in the
    immediately superior lexical environment and type-spec is a type specifier
    (as described in the documentation for ~il[type-spec]).

    (xargs :key1 val1 ... :keyn valn) -- where the legal values of the keyi's
    and their respective vali's are described in the documentation for
    ~il[xargs].  Xargs declarations are only allowed at the top level of
    definitions (defun and defmacro, as shown below).

    (optimize ...) -- for example, ~c[(optimize (safety 3))].  This is allowed
    only at the top level of ~ilc[defun] forms.  See any Common Lisp
    documentation for more information.

  ~ev[]
  Declarations in ACL2 may occur only where ~c[dcl] occurs below:
  ~bv[]
    (DEFUN name args doc-string dcl ... dcl body)
    (DEFMACRO name args doc-string dcl ... dcl body)
    (LET ((v1 t1) ...) dcl ... dcl body)
    (MV-LET (v1 ...) term dcl ... dcl body)
    (FLET ((name args dcl ... dcl body)
           ...))
  ~ev[]
  Of course, if a form macroexpands into one of these (as ~ilc[let*] expands
  into nested ~ilc[let]s and our ~c[er-let*] expands into nested ~ilc[mv-let]s)
  then declarations are permitted as handled by the macros involved.

  ~c[Declare] is defined in Common Lisp.  See any Common Lisp documentation for
  more information.~/")

(deflabel type-spec
  :doc
  ":Doc-Section declare

  type specifiers in declarations~/
  ~bv[]
  Examples:
  The symbol INTEGER in (declare (type INTEGER i j k)) is a type-spec.  Other
  type-specs supported by ACL2 include RATIONAL, COMPLEX, (INTEGER 0 127),
  (RATIONAL 1 *), CHARACTER, and ATOM.  ~terminal[Type :more for a complete listing.]
  ~ev[]~/

  The type-specs and their meanings (when applied to the variable ~c[x]
  as in ~c[(declare (type type-spec x))] are given below.
  ~bv[]
  type-spec              meaning
  (AND type1 ... typek)  (AND (p1 X) ... (pk X))
                         where (pj x) is the meaning for type-spec typej
  ATOM                   (ATOM X)
  BIT                    (OR (EQUAL X 1) (EQUAL X 0))
  CHARACTER              (CHARACTERP X)
  COMPLEX                (AND (COMPLEX-RATIONALP X)
                              (RATIONALP (REALPART X))
                              (RATIONALP (IMAGPART X)))
  (COMPLEX RATIONAL)     same as COMPLEX, above
  (COMPLEX type)         (AND (COMPLEX-RATIONALP X)
                              (p (REALPART X))
                              (p (IMAGPART X)))
                         where (p x) is the meaning for type-spec type
  CONS                   (CONSP X)
  INTEGER                (INTEGERP X)
  (INTEGER i j)          (AND (INTEGERP X)   ; See notes below
                              (<= i X)
                              (<= X j))
  (MEMBER x1 ... xn)     (MEMBER X '(x1 ... xn))
  (MOD i)                same as (INTEGER 0 i-1)
  NIL                    NIL
  (NOT type)             (NOT (p X))
                         where (p x) is the meaning for type-spec type
  NULL                   (EQ X NIL)
  (OR type1 ... typek)   (OR (p1 X) ... (pk X))
                         where (pj x) is the meaning for type-spec typej
  RATIO                  (AND (RATIONALP X) (NOT (INTEGERP X)))
  RATIONAL               (RATIONALP X)
  (RATIONAL i j)         (AND (RATIONALP X)  ; See notes below
                              (<= i X)
                              (<= X j))
  REAL                   (RATIONALP X)       ; (REALP X) in ACL2(r)
  (REAL i j)             (AND (RATIONALP X)  ; See notes below
                              (<= i X)
                              (<= X j))
  (SATISFIES pred)       (pred X) ; Lisp requires a unary function, not a macro
  SIGNED-BYTE            (INTEGERP X)
  (SIGNED-BYTE i)        same as (INTEGER k m) where k=-2^(i-1), m=2^(i-1)-1
  STANDARD-CHAR          (STANDARD-CHARP X)
  STRING                 (STRINGP X)
  (STRING max)           (AND (STRINGP X) (EQUAL (LENGTH X) max))
  SYMBOL                 (SYMBOLP X)
  T                      T
  UNSIGNED-BYTE          same as (INTEGER 0 *)
  (UNSIGNED-BYTE i)      same as (INTEGER 0 (2^i)-1)
  ~ev[]
  ~em[Notes:]

  In general, ~c[(integer i j)] means
  ~bv[]
       (AND (INTEGERP X)
            (<= i X)
            (<= X j)).
  ~ev[]
  But if ~c[i] is the symbol ~c[*], the first inequality is omitted.  If ~c[j]
  is the symbol ~c[*], the second inequality is omitted.  If instead of
  being an integer, the second element of the type specification is a
  list containing an integer, ~c[(i)], then the first inequality is made
  strict.  An analogous remark holds for the ~c[(j)] case.  The ~c[RATIONAL]
  and ~c[REAL] type specifiers are similarly generalized.~/")

(defun the-check (guard x y)
  (declare (xargs :guard (or guard (hard-error
                                    nil
                                    "The object ~xa does not satisfy the ~
                                     declaration ~xb."
                                    (list (cons #\a y)
                                          (cons #\b x))))))
  (declare (ignore x guard))
  y)

(defun the-fn (x y)
  (declare (xargs :guard (translate-declaration-to-guard x 'var nil)

; As noted above the definition of translate-declaration-to-guard/integer, we
; are trying to save a little space in the image.

                  :mode :program))
  (let ((guard (translate-declaration-to-guard x 'var nil)))

; Observe that we translate the type expression, x, wrt the variable var and
; then bind var to y below.  It is logically equivalent to translate wrt to y
; instead and then generate the if-expression below instead of the let.  Why do
; we do that?  Because y (or var) is liable to occur many times in the guard
; and if y is a huge expression we blow ourselves away there.  A good example
; of this comes up if one translates the expression (the-type-set xxx).  When
; we translated the declaration wrt to 'xxx we got an expression in which 'xxx
; occurred five times (using a version of this function present through
; Version_6.1).  By generating the let below, it occurs only once.

; Comment from Version_6.1 and before, probably still mostly relevant today,
; although (the-error type val) has been supplanted using the-check.

;   We have tried an experiment in which we treat the (symbolp y) case
;   specially: translate wrt to y and just lay down the if-expression (if guard
;   y (the-error 'x y)).  The system was able to do an :init, so this did not
;   blow us out of the water -- as we know it does if you so treat all y's.
;   But this IF-expressions in the guard are therefore turned loose in the
;   surrounding term and contribute to the explosion of normalized bodies.  So
;   we have backtracked to this, which has the advantage of keeping the
;   normalized sizes just linearly bigger.

    (cond ((null guard)
           (illegal nil
                    "Illegal-type."
                    (list (cons #\0 x))))
          (t
           `(let ((var ,y))

; The following declaration allows a check at translate time that any part
; (satisfies pred) of x is such that pred is a unary function symbol in the
; current world.  An optimization in dcl-guardian guarantees that this
; declaration won't generate any proof obligations.

; WARNING: Do not change the form of this declaration without visiting the
; corresponding code for the-fn in chk-dcl-lst and dcl-guardian.

              (declare (type (or t ,x) var))
              (the-check ,guard ',x var))))))

#+acl2-loop-only
(defmacro the (x y)

  ":Doc-Section ACL2::ACL2-built-ins

  run-time type check~/

  ~c[(The typ val)] checks that ~c[val] satisfies the type specification
  ~c[typ] (~pl[type-spec]).  An error is caused if the check fails, and
  otherwise, ~c[val] is the value of this expression.  Here are some examples.
  ~bv[]
  (the integer 3)       ; returns 3
  (the (integer 0 6) 3) ; returns 3
  (the (integer 0 6) 7) ; causes an error (see below for exception)
  ~ev[]
  ~l[type-spec] for a discussion of the legal type specifications.

  There is an exception to the rule that failure of the type-check causes an
  error: there is no error when ~il[guard]-checking has been turned off with
  ~c[:set-guard-checking :NONE] or ~c[(with-guard-checking :NONE ...)].
  ~l[set-guard-checking] and ~pl[with-guard-checking].~/

  The following remark is for those who verify guards for their
  functions (~pl[guard] and ~pl[verify-guards]).  We remark that a call of
  ~c[(the TYPE EXPR)] in the body of a function definition generates a guard
  proof obligation that the type, ~c[TYPE], holds for the value of the
  expression, ~c[EXPR].  Consider the following example.
  ~bv[]
  (defun f (x)
    (declare (xargs :guard (p1 x)))
    (if (p2 x)
        (the integer x)
      17))
  ~ev[]
  The ~il[guard] proof obligation generated for the ~c[THE] expression above is
  as follows.
  ~bv[]
  (implies (and (p1 x) (p2 x))
           (let ((var x)) (integerp var)))
  ~ev[]

  ~c[THE] is defined in Common Lisp.  See any Common Lisp documentation
  for more information.~/"

  (declare (xargs :guard (translate-declaration-to-guard x 'var nil)))
  (the-fn x y))

; THEORY PROTO-PRIMITIVES

; Thus far it has been impossible to use the :in-theory hint in
; defthm and defun -- unless one wants to quote a theory -- because
; there are no primitives for getting all the names in the world.
; We here define the necessary basic functions, just so we can
; conveniently disable.  See the extended discussion of theories
; in "other-events.lisp" where deftheory is defined.

; ARRAYS - efficient applicative arrays.

; We provide functions for accessing and updating both one and two
; dimensional arrays, with applicative semantics, but good access time
; to the most recently updated copy and usually constant update time.

; We first describe the one dimensional array data type.  From the
; formal point of view, an array is simply an alist, i.e. a list of
; pairs.  With one exception, the key (i.e., the car) of each pair is
; a nonnegative integer.  However each array must have (at least) one
; pair whose car is :header and whose cdr is a keyword list, whose
; keys include :dimensions, :maximum-length, and :default.  Thus, for
; example, the list '((1 . 2) (:header :dimensions (3) :maximum-length
; 7 :default a) (0 . 6)) represents the sequence #s(6 2 7).  In the
; case of a one dimensional array, the dimension is a list of length
; one which is a nonnegative integer one greater than the maximum
; permitted index.  (Other keywords, e.g. :purpose, for
; identification, are permitted and ignored.)  Formally speakign, to
; find the value of a non-negative integer key in such an alist, we
; search the alist (with the function aref1) for the first pair whose
; car matches the key.  If such a pair is found, then aref1 returns
; the cdr of the pair; otherwise aref1 returns the value associated
; with the :default key.  It is illegal to give aref1 an an index
; equal to or greater than the car of the value associated with the
; :dimensions key.  In the normal case, updating happens by simply
; consing a new pair on to the alist with the function aset1.
; However, when the list resulting from such a cons has length greater
; than the value associated with the :maximum-length key, the alist is
; ``compressed'' back to an alist of minimal length, but with the same
; aref1 search semantics.

; For efficiency, the user is asked to call the array functions with
; an additional argument, a symbol, called the ``name'' of the given
; array.  From the point of view of the formal semantics, the name
; argument is simply and completely ignored.  However, as with the
; implementation of property lists described above, the name provides
; a hint about where to find a ``real'' Common Lisp array that may
; currently represent the given alist, in which case an array access
; can go quite quickly because the real array may be accessed
; directly.

; A further requirement for fast access is that the user initially
; alert the implementation to the desire to make fast accesses by
; calling the function compress1 on the array (and the desired name).
; compress1 then associates with the alist (under the name) a ``real''
; array.  Compress1 returns a list that begins with the header and has
; its other elements in key-ascending order unless otherwise indicated
; by the hearder, with aref1-irrelevant pairs deleted.  If the alist
; is already in this normal form, then no consing is done.  If there
; is already an array associated with the given name, and if it
; happens to have the desired length, then no array allocation is done
; but instead that array is ``stolen''.

; In the usual case, whenever an array is updated (with aset1), the
; ``real'' array which acts as its shadow and supports efficient
; access, is set to support the ``new'' array, and no longer supports
; the ``old'' array.  Thus one must, for efficiency's sake, be
; extremely conscious of the usual order of Common Lisp evaluation.

; For two dimensional arrays, the value of the key :dimensions should
; be a list of two positive integers and the aset2 and aref2 function
; take two indices.

; The following constant was originally introduced in order to
; "require that array indices fit into 32 bits so that some compilers
; can lay down faster code.  In the case of two dimensional arrays, we
; require that the product of legal indices fit into 32 bits."  In
; fact, we now make stronger requirements based on the
; array-total-size-limit and array-dimension-limit of the underlying
; Common Lisp implementation, as enforced by make-array$, whose
; definition follows shortly after this.

(defconst *maximum-positive-32-bit-integer*
  (1- (expt 2 31)))

#-acl2-loop-only
(defconst *our-array-total-size-limit*

; GCL 2.3.8 has a bug that defines array-total-size-limit to be a symbol,
; 'ARRAY-DIMENSION-LIMIT.  (Presumably the intention was to define
; array-total-size-limit to be the value of that symbol.)  So we define our own
; version of array-total-size-limit.

  (if (eql array-total-size-limit 'ARRAY-DIMENSION-LIMIT)
      array-dimension-limit
    array-total-size-limit))

#-acl2-loop-only
(defun-one-output chk-make-array$ (dimensions form)
  (or (let* ((dimensions
              (if (integerp dimensions) (list dimensions) dimensions)))
        (and (true-listp dimensions)
             (do ((tl dimensions (cdr tl)))
                 ((null tl) t)
                 (let ((dim (car dimensions)))
                   (or (and (integerp dim)
                            (<= 0 dim)
                            (< dim array-dimension-limit))
                       (return nil))))
             (< (let ((prod 1))
                  (do ((tl dimensions (cdr tl)))
                      ((null tl))
                      (setq prod (* prod (car dimensions))))
                  prod)
                *our-array-total-size-limit*)))
      (illegal 'make-array$
               "The dimensions of an array must obey restrictions of ~
                the underlying Common Lisp:  each must be a ~
                non-negative integer less than the value of ~
                array-dimension-limit (here, ~x0) and their product ~
                must be less than the value of array-total-size-limit ~
                (here, ~x1).  The call ~x2, which has dimensions ~x3, ~
                is thus illegal."
               (list (cons #\0
                           array-dimension-limit)
                     (cons #\1
                           array-total-size-limit)
                     (cons #\2 form)
                     (cons #\3 dimensions)))))

#-acl2-loop-only
(defmacro make-array$ (&whole form dimensions &rest args)

; Common Lisp implementations are supposed to have limits on the dimensions of
; arrays: array-dimension-limit is a strict bound on each dimension, and
; array-total-size-limit is a strict bound on the product of the dimensions.
; But, we do not want to rely on the implementation to signal an error in such
; cases (as opposed to returning garbage or corrupting the image), let alone
; provide a useful error message.  So we provide this function for creation of
; arrays.

; In case we find the following information useful later, here is a summary of
; the above constants in various 32-bit lisps, observed many years ago as of
; the time you are reading this comment.

; Lisp              array-dimension-limit            array-total-size-limit
; ---------------   ---------------------            ----------------------
; CLISP 2.30          16777216 [2^24]                  16777216 [2^24]
; CMUCL 18e          536870911 [2^29-1]               536870911 [2^29-1]
; SBCL 0.0           536870911 [2^29-1]               536870911 [2^29-1]
; GCL 2.5.0         2147483647 [2^31-1]              2147483647 [2^31-1]
; LISPWORKS 4.2.7      8388607 [2^23-1]                 2096896 [2^21-256]
; Allegro CL 6.2      16777216 [2^24]                  16777216 [2^24]
; MCL 4.2             16777216 [2^24]                  16777216 [2^24]
; OpenMCL Version (Beta: Darwin) 0.13.6 (CCL):
;                     16777216 [2^24]                  16777216 [2^24]

; We go through some effort to find violations at compile time, partly for
; efficiency but mostly in order to provide compile-time feedback when there is
; a problem.

  (declare (ignore args))
  (cond ((integerp dimensions)
         (prog2$ (chk-make-array$ dimensions (kwote form))
                 `(make-array ,@(cdr form))))
        ((and (true-listp dimensions) ; (quote dims)
              (equal (length dimensions) 2)
              (eq (car dimensions) 'quote))
         (prog2$ (chk-make-array$ (cadr dimensions) (kwote form))
                 `(make-array ,@(cdr form))))
        (t `(prog2$ (chk-make-array$ ,dimensions ',form)
                    (make-array ,@(cdr form))))))

; For 1 and 2 dimensional arrays, there may be a property, 'acl2-array, stored
; under a symbol name.  If so, this property has is a list of length four,
; (object actual-array to-go-array header), where object is an alist;
; actual-array, is the current ``real'' array associated with object under
; name; to-go-array is an array of length one whose content is the number of
; additional conses that may be added before compresses is required; and header
; is the first pair beginning with :header in object.  (To-go-array is kept as
; an array rather than as a mere integer in order to avoid number boxing.)
; We use a one-slot cache for efficiency; see the Essay on Array Caching.

#-acl2-loop-only
(progn

; Essay on Array Caching

; We use the following approach, developed by Jared Davis and Sol Swords, to
; speed up ACL2 Arrays by avoiding (get name 'acl2-array) in the common case
; that you are reading/writing from the same array.  We basically just add a
; one-slot cache, stored in the special *acl2-array-cache*.  This is a
; performance win (on CCL, at least) because getting a property seems to be
; more expensive than getting a special.  We could try this on other Lisps too,
; e.g., with these loops:
;
;  (defparameter *foo* 1)
;  (time
;   (loop for i fixnum from 1 to 100000000 do (consp *foo*)))       ; 0.07 secs
;  (time
;   (loop for i fixnum from 1 to 100000000 do (get 'consp 'sally))) ; 1.39 secs
;
; Our approach is simply to use macros in place of direct access to property
; lists, as follows.
;
; (get name 'acl2-array)             --> (get-acl2-array-property name)
; (setf (get name 'acl2-array) prop) --> (set-acl2-array-property name prop)

; Finally, we inline aref1 and aref2.  To see why, consider the following
; timing results.  In each case, we started with ACL2 Version_4.3 built on CCL.
; The four results are based on two dimensions: either loading a patch file or
; not that implements our one-slot cache, and either inlining aref1 or not.
; The test run was the one contributed by Jared Davis and Sol Swords that is
; exhibited in a comment in set-acl2-array-property.

; 16.1 ; no patch
;  8.9 ; patch but no inline
; 11.6 ; no patch, but inline
;  4.3 ; patch and inline

; #+ACL2-PAR note: Unsurpisingly, when we add the semi-necessary locking to the
; array caching scheme (alternatively, we could investigate using a
; compare-and-swap-based mechanism like atomic increments), we experience a
; very large slow down.  In Rager's experiment, it was about 40x slower.  This
; is a terrible performance penalty, so in #+ACL2-PAR, we do not use array
; caching.

(defparameter *acl2-array-cache*

; This special is always the same cons, but its car and cdr may be
; destructively modified.  Its value always has the form (name . prop), where
; name is a symbol and prop is either nil or (get name 'acl2-array).

  (cons nil nil))

(defmacro set-acl2-array-property (name prop)

; Use this macro instead of (setf (get name 'acl2-array) prop).  We update the
; 'acl2-array property of name, and install (name . prop) into the array cache.
; See the Essay on Array Caching.

; We are tempted to handle name as we handle prop, by let-binding name below.
; However, by using ,name directly we have reduced the time from 5.0 seconds to
; 4.3 seconds in the following test from Jared Davis and Sol Swords.

;  (defun count-down (n)
;    (if (zp n)
;        nil
;      (cons (- n 1)
;            (count-down (- n 1)))))
;
;  (defconst *test-array*
;    (compress1 '*test-array*
;               (cons (list :HEADER
;                           :DIMENSIONS (list 100)
;                           :MAXIMUM-LENGTH (+ 100 1)
;                           :DEFAULT 0
;                           :NAME '*test-array*)
;                     (pairlis$ (count-down 100)
;                               (make-list 100)))))
;
;  (let ((arr *test-array*))
;    (time (loop for i fixnum from 1 to 1000000000 do
;                (aref1 '*test-array* arr 10))))

; Therefore, we use ,name directly but add the following compile-time check to
; ensure that ,name refers to the given formal parameter rather than to the
; let-bound prop or cache.

  (when (or (not (symbolp name))
            (eq name 'prop)
            (eq name '*acl2-array-cache*))
    (error "Bad call, ~s: See set-acl2-array-property"
           `(set-acl2-array-property ,name ,prop)))
  #-acl2-par
  `(let ((prop  ,prop)
         (cache *acl2-array-cache*))
     (setf (cdr cache) nil) ; Invalidate the cache in case of interrupts.
     (setf (get ,name 'acl2-array) prop)
     (setf (car cache) ,name)
     (setf (cdr cache) prop))
  #+acl2-par
  `(setf (get ,name 'acl2-array) ,prop))

(defmacro get-acl2-array-property (name)

; Use this macro instead of (get name 'acl2-array).  We get the 'acl2-array
; property for name from the cache if possible, or from the property list if it
; is not cached.  On a cache miss, we update the cache so that it points to the
; newly accessed array.  See the Essay on Array Caching.

; See set-acl2-array-property for an explanation of the following compile-time
; check.

  (when (or (not (symbolp name))
            (eq name 'prop)
            (eq name '*acl2-array-cache*))
    (error "Bad call, ~s: See set-acl2-array-property"
           `(get-acl2-array-property ,name)))
  #-acl2-par
  `(let ((cache *acl2-array-cache*))
     (or (and (eq ,name (car cache))
              (cdr cache))
         (let ((prop (get ,name 'acl2-array)))
           (setf (cdr cache) nil) ; Invalidate the cache in case of interrupts.
           (setf (car cache) ,name)
           (setf (cdr cache) prop))))
  #+acl2-par
  `(get ,name 'acl2-array))

)

(defun bounded-integer-alistp (l n)

; Check that l is a true-list of pairs, (n . x), where each n is
; either :header or a nonnegative integer less than n.

  (declare (xargs :guard t))
  (cond ((atom l) (null l))
        (t (and (consp (car l))
                (let ((key (caar l)))
                  (and (or (eq key :header)
                           (and (integerp key)
                                (integerp n)
                                (>= key 0)
                                (< key n)))
                       (bounded-integer-alistp (cdr l) n)))))))

(defthm bounded-integer-alistp-forward-to-eqlable-alistp
  (implies (bounded-integer-alistp x n)
           (eqlable-alistp x))
  :rule-classes :forward-chaining)

(defun keyword-value-listp (l)

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for true lists whose even-position elements are keywords~/

  ~c[(keyword-value-listp l)] is true if and only if ~c[l] is a list of
  even length of the form ~c[(k1 a1 k2 a2 ... kn an)], where each ~c[ki]
  is a keyword.

  To see the ACL2 definition of this function, ~pl[pf].~/~/"

  (declare (xargs :guard t))
  (cond ((atom l) (null l))
        (t (and (keywordp (car l))
                (consp (cdr l))
                (keyword-value-listp (cddr l))))))

(defthm keyword-value-listp-forward-to-true-listp
  (implies (keyword-value-listp x)
           (true-listp x))
  :rule-classes :forward-chaining)

(defun assoc-keyword (key l)

  ":Doc-Section ACL2::ACL2-built-ins

  look up key in a ~ilc[keyword-value-listp]~/

  If ~c[l] is a list of even length of the form ~c[(k1 a1 k2 a2 ... kn an)],
  where each ~c[ki] is a keyword, then ~c[(assoc-keyword key l)] is the
  first tail of ~c[l] starting with ~c[key] if key is some ~c[ki], and is
  ~c[nil] otherwise.~/

  The ~il[guard] for ~c[(assoc-keyword key l)] is ~c[(keyword-value-listp l)].

  To see the ACL2 definition of this function, ~pl[pf].~/"

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

; The following seems useful, though at this point its use isn't clear.

(defthm keyword-value-listp-assoc-keyword
  (implies (keyword-value-listp l)
           (keyword-value-listp (assoc-keyword key l)))
  :rule-classes ((:forward-chaining
                  :trigger-terms ((assoc-keyword key l)))))

(defthm consp-assoc-equal

; This type-prescription rule (formerly two rules, consp-assoc-eq and
; consp-assoc) may have been partly responsible for a 2.5% real-time regression
; slowdown (3.2% user time) after implementing equality variants, after
; Version_4.2.  In particular, it contributed to a significant slowdown in
; example4 of examples.lisp in community book
; books/workshops/2000/moore-manolios/partial-functions/tjvm.lisp.  So, we are
; disabling it by default, later below.

; We include a corresponding :forward-chaining rule, which seems much less
; expensive, but still allows the event aref1 to be admitted.

  (implies (alistp l)
           (or (consp (assoc-equal name l))
               (equal (assoc-equal name l) nil)))
  :rule-classes (:type-prescription
                 (:forward-chaining :trigger-terms ((assoc-equal name l)))))

#+acl2-loop-only
(defmacro f-get-global (x st)

  ":Doc-Section ACL2::ACL2-built-ins

  get the value of a global variable in ~ilc[state]~/
  ~bv[]
  Examples:
  (+ (f-get-global 'y state) 1)
  (f-put-global 'a
                (aset1 'ascii-map-array
                       (f-get-global 'a state)
                       66
                       'Upper-case-B)
                state)~/

  General Form:
  (f-get-global 'symbol state)
  ~ev[]
  where ~c[symbol] is any symbol to which you have ~ilc[assign]ed a global
  value.

  The macro ~ilc[@] is closely related to ~c[f-get-global]: ~c[(@ var)]
  macroexpands to ~c[(f-get-global 'var state)].

  The macro ~ilc[f-get-global] makes it convenient to set the value of a
  symbol.  The ~c[:]~ilc[ubt] operation has no effect on the ~c[global-table]
  of ~ilc[state].  Thus, you may use these globals to hang onto useful data
  structures even though you may undo back past where you computed and saved
  them.~/"

  (list 'get-global x st))

#-acl2-loop-only
(progn

; With f-get-global and set-difference-eq defined, we are ready to define
; raw Lisp support for defpkg-raw.

(defun our-import (syms pkg)

; We have seen a case in which Allegro CL 8.0 spent about 20% of the time in
; IMPORT, on an include-book (with lots of nested include-books, and 20 defpkg
; forms executed altogether).  That time was reduced to near 0 by using the
; present function, OUR-IMPORT, in place of IMPORT, presumably because
; (according to the profiler) calls to EXCL::INTERNAL-STRING= were avoided,
; probably in favor of hashing.  We saw no significant change in time in GCL,
; however, so we exclude GCL and any non-ANSI (hence maybe no LOOP) Common Lisp
; from this enhancement.  It might be worthwhile to consider other Common Lisp
; implementations besides Allegro CL and GCL.  Perhaps Allegro CL will speed up
; its handling of IMPORT in future implementations (we have sent email to Franz
; Inc. about this), in which case we might consider deleting this function.

  #+(and (not gcl) cltl2)
  (loop for sym in syms do (import (or sym (list sym)) pkg))
  #-(and (not gcl) cltl2)
  (import syms pkg))

(defvar *defpkg-virgins* nil)

(defun check-proposed-imports (name package-entry proposed-imports)
  (cond
   ((equal proposed-imports (package-entry-imports package-entry))

; The package has already been built in Common Lisp and the imports are
; identical.  There is nothing for us to do.

    nil)
   (t

; The package has already been built in Common Lisp but with the wrong imports.
; There is nothing we can do.  We do not want to unintern any symbols in it
; because we may thus render bad some saved logical worlds.  See :DOC
; package-reincarnation-import-restrictions.  In addition, see the Lisp comment
; that is part of that deflabel (but which is not actually part of the
; ACL2 documentation).

    (let* ((old-book-path
            (reverse (unrelativize-book-path
                      (package-entry-book-path package-entry)
                      (f-get-global 'system-books-dir *the-live-state*))))
           (current-book-path
            (reverse
             (append (strip-cars (symbol-value 'acl2::*load-compiled-stack*))
                     (global-val 'include-book-path (w *the-live-state*)))))
           (old-imports (package-entry-imports package-entry))
           (proposed-not-old (set-difference-eq proposed-imports old-imports))
           (old-not-proposed (set-difference-eq old-imports proposed-imports))
           (current-package (f-get-global 'current-package *the-live-state*)))
      (interface-er
       "~%We cannot reincarnate the package ~x0 because it was previously ~
        defined with a different list of imported symbols.~|~%The previous ~
        definition was made ~#1~[at the top level.~|~/in the portcullis of ~
        the last of the book at the end of the following sequence of included ~
        books, which starts with the top-most book at the front of the list ~
        and works down to the book that defined the package.~|~%  ~
        ~F2~|~]~%The proposed definition is being made ~#3~[at the top ~
        level.~|~/in the portcullis of the last of the book at the end of the ~
        following sequence of included books, which starts with the top-most ~
        book at the front of the list and works down to the book that is ~
        trying to define the package.~|~%  ~F4~|~]~%~#5~[The previous ~
        definition imported the following list of symbols that are not ~
        imports of the proposed definition, and is shown with respect to ~
        current package ~x9:~|~%  ~x6.~|~%~/~]~#7~[The proposed definition ~
        imports the following list of symbols not imported by the previous ~
        definition, and is shown with respect to current package ~x9:~|~%  ~
        ~x8.~|~%~/~]See :DOC package-reincarnation-import-restrictions."
       name
       (if old-book-path 1 0)
       old-book-path
       (if current-book-path 1 0)
       current-book-path
       (if old-not-proposed 0 1)
       old-not-proposed
       (if proposed-not-old 0 1)
       proposed-not-old
       current-package
       )))))

(defun-one-output defpkg-raw1 (name imports book-path event-form)
  (let ((package-entry (find-package-entry name *ever-known-package-alist*))
        (pkg (find-package name))
        (global-name (concatenate 'string
                                  acl2::*global-package-prefix*
                                  name))
        (*1*-name (concatenate 'string
                               acl2::*1*-package-prefix*
                               name))
        (proposed-imports (sort-symbol-listp imports)))
    (assert pkg) ; see defpkg-raw

; We bind proposed-imports to the value of the imports argument.  We do not
; want to evaluate it more than once below.  We DO reference, and hence
; evaluate, name more than once below.  But name must be an explicit string
; constant.

    (cond
     (package-entry

; There is nothing for us to do other than to do a check.

      (check-proposed-imports name package-entry proposed-imports)
      name)
     ((not (member-equal name *defpkg-virgins*))

; The package has been built in this Common Lisp but not by defpkg-raw1.  It
; may be new because of the defpackage form in defpkg-raw, in which case it is
; an element of *defpkg-virgins*.  Otherwise, it was defined in Common Lisp
; outside ACL2, and we should cause an error.

      (error
       "~%It is illegal to defpkg ~s because a package of that name ~
        already exists in this lisp.~%"
       name))
     (t
      (assert (not (assoc-equal name *package-alist*)))
      (let* ((incomplete-p t)
             (saved-ever-known-package-alist *ever-known-package-alist*)
             (wrld (w *the-live-state*))
             (not-boot-strap (not (getprop 'boot-strap-flg 'global-value nil
                                           'current-acl2-world
                                           wrld))))
        (setq *defpkg-virgins*
              (remove1-equal name *defpkg-virgins*))
        (unwind-protect
            (progn
              (setq *ever-known-package-alist*
                    (cons (make-package-entry
                           :name name
                           :imports proposed-imports
                           :book-path

; We store a suitable path for use by check-proposed-imports.

                           (and not-boot-strap
                                (append
                                 book-path
                                 (strip-cars
                                  (symbol-value 'acl2::*load-compiled-stack*))
                                 (getprop 'include-book-path 'global-value
                                          nil 'current-acl2-world wrld)))
                           :defpkg-event-form event-form)
                          *ever-known-package-alist*))
              (when proposed-imports

; Without the qualifier above, clisp imports nil if proposed-imports = nil.

                (our-import proposed-imports (find-package name)))

; So at this point we have set the package's imports appropriately.  We now
; handle the dual packages in which the state globals and executable
; counterparts of symbols from pkg will reside.  We do not reinitialize these
; hidden variables if we are recovering from an error or booting.

              (cond
               ((and (not *in-recover-world-flg*)
                     not-boot-strap)
                (cond ((find-package global-name)
                       (do-symbols (sym (find-package global-name))
                                   (makunbound sym)))
                      (t (make-package global-name :use nil)))
                (cond ((find-package *1*-name)
                       nil)
                      (t (make-package *1*-name :use nil)))))
              (setq incomplete-p nil)
              name)
          (when incomplete-p
            (setq *ever-known-package-alist*
                  saved-ever-known-package-alist)
            (do-symbols (sym pkg)
                        (unintern sym))
            (delete-package (find-package name)))))))))

(defun package-has-no-imports (name)
  (let ((pkg (find-package name)))
    (do-symbols (sym pkg)
                (when (not (eq (symbol-package sym) pkg))
                  (return-from package-has-no-imports nil))))
  t)

#-acl2-loop-only
(defmacro maybe-make-package (name)

; When we moved to Version_4.3, with LispWorks once again a supported host
; Lisp, we modified the macro maybe-introduce-empty-pkg-1 to avoid the use of
; defpackage; see the comment in that macro.  Unfortunately, the new approach
; didn't work for CMUCL (at least, for version 19e).  The following example
; shows why; even with an eval-when form specifying :compile-toplevel, the
; compiled code seems to skip the underlying package-creation form, as shown
; below.  Therefore we revert to the use of defpackage for CMUCL, which appears
; not to cause problems.

;   % cat pkg-bug-cmucl.lisp
;
;   (in-package "CL-USER")
;
;   (eval-when (:load-toplevel :execute :compile-toplevel)
;              (cond ((not (find-package "MYPKG"))
;                     (print "*** About to make package ***")
;                     (terpri)
;                     (make-package "MYPKG" :use nil))))
;
;   (defparameter *foo* 'mypkg::x)
;   % /projects/acl2/lisps/cmucl-19e-linux/bin/cmucl
;   CMU Common Lisp 19e (19E), running on kindness
;   With core: /v/filer4b/v11q001/acl2/lisps/cmucl-19e-linux/lib/cmucl/lib/lisp.core
;   Dumped on: Thu, 2008-05-01 11:56:07-05:00 on usrtc3142
;   See <http://www.cons.org/cmucl/> for support information.
;   Loaded subsystems:
;       Python 1.1, target Intel x86
;       CLOS based on Gerd's PCL 2004/04/14 03:32:47
;   * (load "pkg-bug-cmucl.lisp")
;
;   ; Loading #P"/v/filer4b/v41q001/kaufmann/temp/pkg-bug-cmucl.lisp".
;
;   "*** About to make package ***"
;   T
;   * (compile-file "pkg-bug-cmucl.lisp")
;
;   ; Python version 1.1, VM version Intel x86 on 04 JUL 11 09:57:13 am.
;   ; Compiling: /v/filer4b/v41q001/kaufmann/temp/pkg-bug-cmucl.lisp 04 JUL 11 09:56:24 am
;
;   ; Byte Compiling Top-Level Form:
;
;   ; pkg-bug-cmucl.x86f written.
;   ; Compilation finished in 0:00:00.
;
;   #P"/v/filer4b/v41q001/kaufmann/temp/pkg-bug-cmucl.x86f"
;   NIL
;   NIL
;   * (quit)
;   % /projects/acl2/lisps/cmucl-19e-linux/bin/cmucl
;   CMU Common Lisp 19e (19E), running on kindness
;   With core: /v/filer4b/v11q001/acl2/lisps/cmucl-19e-linux/lib/cmucl/lib/lisp.core
;   Dumped on: Thu, 2008-05-01 11:56:07-05:00 on usrtc3142
;   See <http://www.cons.org/cmucl/> for support information.
;   Loaded subsystems:
;       Python 1.1, target Intel x86
;       CLOS based on Gerd's PCL 2004/04/14 03:32:47
;   * (load "pkg-bug-cmucl.x86f")
;
;   ; Loading #P"/v/filer4b/v41q001/kaufmann/temp/pkg-bug-cmucl.x86f".
;
;
;   Error in function LISP::FOP-PACKAGE:  The package "MYPKG" does not exist.
;      [Condition of type SIMPLE-ERROR]
;
;   Restarts:
;     0: [CONTINUE] Return NIL from load of "pkg-bug-cmucl.x86f".
;     1: [ABORT   ] Return to Top-Level.
;
;   Debug  (type H for help)
;
;   (LISP::FOP-PACKAGE)
;   Source: Error finding source:
;   Error in function DEBUG::GET-FILE-TOP-LEVEL-FORM:  Source file no longer exists:
;     target:code/load.lisp.
;   0]

  #-cmu
  `(when (not (find-package ,name))
     (make-package ,name :use nil))
  #+cmu
  `(defpackage ,name (:use)))

(defmacro maybe-introduce-empty-pkg-1 (name)

; It appears that GCL, requires a user::defpackage (non-ANSI case) or
; defpackage (ANSI case; this may be the same as user::defpackage) form near
; the top of a file in order to read the corresponding compiled file.  For
; example, an error occurred upon attempting to load the community books file
; books/data-structures/defalist.o after certifying the corresponding book
; using GCL, because the form (MAYBE-INTRODUCE-EMPTY-PKG-1 "U") near the top of
; the file was insufficient to allow reading a symbol in the "U" package
; occurring later in the corresponding source file.

; On the other hand, the CL HyperSpec does not pin down the effect of
; defpackage when a package already exists.  Indeed, the defpackage approach
; that we use for GCL does not work for LispWorks 6.0.

; So, we have quite different definitions of this macro for GCL and LispWorks.
; All other Lisps we have encountered seem happy with the approach we have
; adopted for Lispworks, so we adopt that approach for them, too.

  #-gcl
  `(eval-when
    #+cltl2 (:load-toplevel :execute :compile-toplevel)
    #-cltl2 (load eval compile) ; though probably #-gcl implies #+cltl2
    (progn
      (maybe-make-package ,name)
      (maybe-make-package ,(concatenate 'string
                                        acl2::*global-package-prefix*
                                        name))
      (maybe-make-package ,(concatenate 'string
                                        acl2::*1*-package-prefix*
                                        name))))
  #+gcl
  (let ((defp #+cltl2 'defpackage #-cltl2 'user::defpackage))
    `(progn
       (,defp ,name
         (:use))
       (,defp ,(concatenate 'string
                            acl2::*global-package-prefix*
                            name)
         (:use))
       (,defp ,(concatenate 'string
                            acl2::*1*-package-prefix*
                            name)
         (:use)))))

(defmacro maybe-introduce-empty-pkg-2 (name)
  `(when (and (not (member ,name *defpkg-virgins*
                           :test 'equal))
              (not (assoc ,name *ever-known-package-alist*
                          :test 'equal))
              (package-has-no-imports ,name))
     (push ,name *defpkg-virgins*)))

(defmacro defpkg-raw (name imports book-path event-form)

; Defpkg checks that name is a string.  Event-form is a cons.  So we don't need
; to worry about capture below.

  `(let ((package-entry (find-package-entry ,name *ever-known-package-alist*))
         (*safe-mode-verified-p* t))
     (cond
      ((and package-entry
            (let ((old-event-form
                   (package-entry-defpkg-event-form package-entry)))
              (and (equal (cadr old-event-form) (cadr ,event-form))
                   (equal (caddr old-event-form) (caddr ,event-form)))))

; This shorcut is potentially a big concern!  We are checking that the name and
; term of the defpkg form agrees with an old defpkg form.  But these two forms
; may have been evaluated in different worlds!  Nevertheless, for now we trust
; that they really are equivalent, for efficiency's sake.  Defpkg-fn will call
; chk-acceptable-defpkg, which will call
; chk-package-reincarnation-import-restrictions, and if there is a discrepancy
; between the current and old package, we'll find out then.

       ,name)
      (t
       (maybe-introduce-empty-pkg-1 ,name)
       (maybe-introduce-empty-pkg-2 ,name)
       (defpkg-raw1 ,name ,imports ,book-path ,event-form)))))
)

#-acl2-loop-only
(defun-one-output slow-array-warning (fn nm)
  (let ((action (f-get-global 'slow-array-action *the-live-state*)))
    (when action
      (format
       *error-output*
       "~%~%**********************************************************~%~
          Slow Array Access!  A call of ~a on an array named~%~
          ~a is being executed slowly.  See :DOC slow-array-warning.~%~
          **********************************************************~%~%"
       fn nm)
      (when (not (eq action :warning))
        (format
         *error-output*
         "To avoid the following break and get only the above warning:~%~s~%"
         '(assign slow-array-action :warning))
        (break$)))))

(deflabel arrays
  :doc
  ":Doc-Section ACL2::Programming

  an introduction to ACL2 arrays~/

  Below we begin a detailed presentation of ACL2 arrays.  ACL2's single-threaded
  objects (~pl[stobj]) provide a similar functionality that is generally more
  efficient when there are updates (writes), but is also more restrictive.

  ~/

  ~l[arrays-example] for a brief introduction illustrating the use
  of ACL2 arrays.

  ACL2 provides relatively efficient 1- and 2-dimensional arrays.
  Arrays are awkward to provide efficiently in an applicative language
  because the programmer rightly expects to be able to ``modify'' an
  array object with the effect of changing the behavior of the element
  accessing function on that object.  This, of course, does not make
  any sense in an applicative setting.  The element accessing function
  is, after all, a function, and its behavior on a given object is
  immutable.  To ``modify'' an array object in an applicative setting
  we must actually produce a new array object.  Arranging for this to
  be done efficiently is a challenge to the implementors of the
  language.  In addition, the programmer accustomed to the von Neumann
  view of arrays must learn how to use immutable applicative arrays
  efficiently.

  In this note we explain 1-dimensional arrays.  In particular, we
  explain briefly how to create, access, and ``modify'' them, how they
  are implemented, and how to program with them.  2-dimensional arrays
  are dealt with by analogy.

  ~em[The Logical Description of ACL2 Arrays]

  An ACL2 1-dimensional array is an object that associates arbitrary
  objects with certain integers, called ``indices.'' Every array has a
  dimension, ~c[dim], which is a positive integer.  The indices of an
  array are the consecutive integers from ~c[0] through ~c[dim-1].  To obtain
  the object associated with the index ~c[i] in an array ~c[a], one uses
  ~c[(aref1 name a i)].  ~c[Name] is a symbol that is irrelevant to the
  semantics of ~ilc[aref1] but affects the speed with which it computes.  We
  will talk more about array ``names'' later.  To produce a new array
  object that is like ~c[a] but which associates ~c[val] with index ~c[i], one
  uses ~c[(aset1 name a i val)].

  An ACL2 1-dimensional array is actually an alist.  There is no
  special ACL2 function for creating arrays; they are generally built
  with the standard list processing functions ~ilc[list] and ~ilc[cons].  However,
  there is a special ACL2 function, called ~ilc[compress1], for speeding up
  access to the elements of such an alist.  We discuss ~ilc[compress1]
  later.

  One element of the alist must be the ``header'' of the array.  The
  ~il[header] of a 1-dimensional array with dimension ~c[dim] is of the form:
  ~bv[]
  (:HEADER :DIMENSIONS (dim)
           :MAXIMUM-LENGTH max
           :DEFAULT obj ; optional
           :NAME name   ; optional
           :ORDER order ; optional values are < (the default), >, or :none/nil
           ).
  ~ev[]
  ~c[Obj] may be any object and is called the ``default value'' of the array.
  ~ilc[Max] must be an integer greater than ~c[dim].  ~c[Name] must be a
  symbol.  The ~c[:]~ilc[default] and ~c[:name] entries are optional; if
  ~c[:]~ilc[default] is omitted, the default value is ~c[nil].  The function
  ~ilc[header], when given a name and a 1- or 2-dimensional array, returns the
  ~il[header] of the array.  The functions ~ilc[dimensions],
  ~ilc[maximum-length], and ~ilc[default] are similar and return the
  corresponding fields of the ~il[header] of the array.  The role of the
  ~c[:]~ilc[dimensions] field is obvious: it specifies the legal indices into
  the array.  The roles played by the ~c[:]~ilc[maximum-length] and
  ~c[:]~ilc[default] fields are described below.

  Aside from the ~il[header], the other elements of the alist must each be
  of the form ~c[(i . val)], where ~c[i] is an integer and ~c[0 <= i < dim], and
  ~c[val] is an arbitrary object.

  The ~c[:order] field of the header is ignored for 2-dimensional arrays.  For
  1-dimensional arrays, it specifies the order of keys (~c[i], above) when the
  array is compressed as with ~ilc[compress1], as described below.  An
  ~c[:order] of ~c[:none] or ~c[nil] specifies no reordering of the alist by
  ~ilc[compress1], and an order of ~c[>] specifies reordering by
  ~ilc[compress1] so that keys are in descending order.  Otherwise, the alist
  is reordered by ~ilc[compress1] so that keys are in ascending order.

  ~c[(Aref1 name a i)] is ~il[guard]ed so that ~c[name] must be a symbol, ~c[a] must be
  an array and ~c[i] must be an index into ~c[a].  The value of
  ~c[(aref1 name a i)] is either ~c[(cdr (assoc i a))] or else is the
  default value of ~c[a], depending on whether there is a pair in ~c[a]
  whose ~ilc[car] is ~c[i].  Note that ~c[name] is irrelevant to the value of
  an ~ilc[aref1] expression.  You might ~c[:pe aref1] to see how simple
  the definition is.

  ~c[(Aset1 name a i val)] is ~il[guard]ed analogously to the ~ilc[aref1] expression.
  The value of the ~ilc[aset1] expression is essentially
  ~c[(cons (cons i val) a)].  Again, ~c[name] is irrelevant.  Note
  ~c[(aset1 name a i val)] is an array, ~c[a'], with the property that
  ~c[(aref1 name a' i)] is ~c[val] and, except for index ~c[i], all other
  indices into ~c[a'] produce the same value as in ~c[a].  Note also
  that if ~c[a] is viewed as an alist (which it is) the pair
  ``binding'' ~c[i] to its old value is in ~c[a'] but ``covered up'' by
  the new pair.  Thus, the length of an array grows by one when
  ~ilc[aset1] is done.

  Because ~ilc[aset1] covers old values with new ones, an array produced by
  a sequence of ~ilc[aset1] calls may have many irrelevant pairs in it.  The
  function ~ilc[compress1] can remove these irrelevant pairs.  Thus,
  ~c[(compress1 name a)] returns an array that is equivalent
  (vis-a-vis ~ilc[aref1]) to ~c[a] but which may be shorter.  For technical
  reasons, the alist returned by ~ilc[compress1] may also list the pairs
  in a different order than listed in ~c[a].

  To prevent arrays from growing excessively long due to repeated ~ilc[aset1]
  operations, ~ilc[aset1] actually calls ~ilc[compress1] on the new alist
  whenever the length of the new alist exceeds the ~c[:]~ilc[maximum-length]
  entry, ~ilc[max], in the ~il[header] of the array.  See the definition of
  ~ilc[aset1] (for example by using ~c[:]~ilc[pe]).  This is primarily just a
  mechanism for freeing up ~ilc[cons] space consumed while doing ~ilc[aset1]
  operations.  Note however that this ~ilc[compress1] call is replaced by a
  hard error if the header specifies an ~c[:order] of ~c[:none] or ~c[nil].

  This completes the logical description of 1-dimensional arrays.
  2-dimensional arrays are analogous.  The ~c[:]~ilc[dimensions] entry of the
  ~il[header] of a 2-dimensional array should be ~c[(dim1 dim2)].  A pair of
  indices, ~c[i] and ~c[j], is legal iff ~c[0 <= i < dim1] and ~c[0 <= j < dim2].
  The ~c[:]~ilc[maximum-length] must be greater than ~c[dim1*dim2].  ~ilc[Aref2], ~ilc[aset2],
  and ~ilc[compress2] are like their counterparts but take an additional
  ~c[index] argument.  Finally, the pairs in a 2-dimensional array are of
  the form ~c[((i . j) . val)].

  ~em[The Implementation of ACL2 Arrays]

  Very informally speaking, the function ~ilc[compress1] ``creates'' an
  ACL2 array that provides fast access, while the function ~ilc[aref1]
  ``maintains'' fast access.  We now describe this informal idea more
  carefully.

  ~ilc[Aref1] is essentially ~ilc[assoc].  If ~ilc[aref1] were implemented naively the
  time taken to access an array element would be linear in the
  dimension of the array and the number of ``assignments'' to it (the
  number of ~ilc[aset1] calls done to create the array from the initial
  alist).  This is intolerable; arrays are ``supposed'' to provide
  constant-time access and change.

  The apparently irrelevant names associated with ACL2 arrays allow us
  to provide constant-time access and change when arrays are used in
  ``conventional'' ways.  The implementation of arrays makes it clear
  what we mean by ``conventional.''

  Recall that array names are symbols.  Behind the scenes, ACL2
  associates two objects with each ACL2 array name.  The first object
  is called the ``semantic value'' of the name and is an alist.  The
  second object is called the ``raw lisp array'' and is a Common Lisp
  array.

  When ~c[(compress1 name alist)] builds a new alist, ~c[a'], it sets the
  semantic value of ~c[name] to that new alist.  Furthermore, it creates a
  Common Lisp array and writes into it all of the index/value pairs of
  ~c[a'], initializing unassigned indices with the default value.  This
  array becomes the raw lisp array of ~c[name].  ~ilc[Compress1] then returns
  ~c[a'], the semantic value, as its result, as required by the definition
  of ~ilc[compress1].

  When ~c[(aref1 name a i)] is invoked, ~ilc[aref1] first determines whether the
  semantic value of ~c[name] is ~c[a] (i.e., is ~ilc[eq] to the alist ~c[a]).  If so,
  ~ilc[aref1] can determine the ~c[i]th element of ~c[a] by invoking Common Lisp's
  ~c[aref] function on the raw lisp array associated with name.  Note that
  no linear search of the alist ~c[a] is required; the operation is done
  in constant time and involves retrieval of two global variables, an
  ~ilc[eq] test and ~c[jump], and a raw lisp array access.  In fact, an ACL2
  array access of this sort is about 5 times slower than a C array
  access.  On the other hand, if ~c[name] has no semantic value or if it
  is different from ~c[a], then ~ilc[aref1] determines the answer by linear
  search of ~c[a] as suggested by the ~c[assoc-like] definition of ~ilc[aref1].
  Thus, ~ilc[aref1] always returns the axiomatically specified result.  It
  returns in constant time if the array being accessed is the current
  semantic value of the name used.  The ramifications of this are
  discussed after we deal with ~ilc[aset1].

  When ~c[(aset1 name a i val)] is invoked, ~ilc[aset1] does two ~ilc[cons]es to
  create the new array.  Call that array ~c[a'].  It will be returned as
  the answer.  (In this discussion we ignore the case in which ~ilc[aset1]
  does a ~ilc[compress1].)  However, before returning, ~ilc[aset1] determines if
  ~c[name]'s semantic value is ~c[a].  If so, it makes the new semantic value
  of ~c[name] be ~c[a'] and it smashes the raw lisp array of ~c[name] with ~c[val] at
  index ~c[i], before returning ~c[a'] as the result.  Thus, after doing an
  ~ilc[aset1] and obtaining a new semantic value ~c[a'], all ~ilc[aref1]s on that new
  array will be fast.  Any ~ilc[aref1]s on the old semantic value, ~c[a], will
  be slow.

  To understand the performance implications of this design, consider
  the chronological sequence in which ACL2 (Common Lisp) evaluates
  expressions:  basically inner-most first, left-to-right,
  call-by-value.  An array use, such as ~c[(aref1 name a i)], is ``fast''
  (constant-time) if the alist supplied, ~c[a], is the value returned by
  the most recently executed ~ilc[compress1] or ~ilc[aset1] on the name supplied.
  In the functional expression of ``conventional'' array processing,
  all uses of an array are fast.

  The ~c[:name] field of the ~il[header] of an array is completely irrelevant.
  Our convention is to store in that field the symbol we mean to use
  as the name of the raw lisp array.  But no ACL2 function inspects
  ~c[:name] and its primary value is that it allows the user, by
  inspecting the semantic value of the array ~-[] the alist ~-[] to recall
  the name of the raw array that probably holds that value.  We say
  ``probably'' since there is no enforcement that the alist was
  compressed under the name in the ~il[header] or that all ~c[aset]s used that
  name.  Such enforcement would be inefficient.

  ~em[Some Programming Examples]

  In the following examples we will use ACL2 ``global variables'' to
  hold several arrays.  ~l[@], and ~pl[assign].

  Let the ~ilc[state] global variable ~c[a] be the 1-dimensional compressed
  array of dimension ~c[5] constructed below.
  ~bv[]
  ACL2 !>(assign a (compress1 'demo
                              '((:header :dimensions (5)
                                         :maximum-length 15
                                         :default uninitialized
                                         :name demo)
                                (0 . zero))))
  ~ev[]
  Then ~c[(aref1 'demo (@ a) 0)] is ~c[zero] and ~c[(aref1 'demo (@ a) 1)] is
  ~c[uninitialized].

  Now execute
  ~bv[]
  ACL2 !>(assign b (aset1 'demo (@ a) 1 'one))
  ~ev[]
  Then ~c[(aref1 'demo (@ b) 0)] is ~c[zero] and ~c[(aref1 'demo (@ b) 1)] is
  ~c[one].

  All of the ~ilc[aref1]s done so far have been ``fast.''

  Note that we now have two array objects, one in the global variable
  ~c[a] and one in the global variable ~c[b].  ~c[B] was obtained by assigning to
  ~c[a].  That assignment does not affect the alist ~c[a] because this is an
  applicative language.  Thus, ~c[(aref1 'demo (@ a) 1)] must ~st[still] be
  ~c[uninitialized].  And if you execute that expression in ACL2 you will
  see that indeed it is.  However, a rather ugly comment is printed,
  namely that this array access is ``slow.''  The reason it is slow is
  that the raw lisp array associated with the name ~c[demo] is the array
  we are calling ~c[b].  To access the elements of ~c[a], ~ilc[aref1] must now do a
  linear search.  Any reference to ~c[a] as an array is now
  ``unconventional;'' in a conventional language like Ada or Common
  Lisp it would simply be impossible to refer to the value of the
  array before the assignment that produced our ~c[b].

  Now let us define a function that counts how many times a given
  object, ~c[x], occurs in an array.  For simplicity, we will pass in the
  name and highest index of the array:
  ~bv[]
  ACL2 !>(defun cnt (name a i x)
           (declare (xargs :guard
                           (and (array1p name a)
                                (integerp i)
                                (>= i -1)
                                (< i (car (dimensions name a))))
                           :mode :logic
                           :measure (nfix (+ 1 i))))
           (cond ((zp (1+ i)) 0) ; return 0 if i is at most -1
                 ((equal x (aref1 name a i))
                  (1+ (cnt name a (1- i) x)))
                 (t (cnt name a (1- i) x))))
  ~ev[]
  To determine how many times ~c[zero] appears in ~c[(@ b)] we can execute:
  ~bv[]
  ACL2 !>(cnt 'demo (@ b) 4 'zero)
  ~ev[]
  The answer is ~c[1].  How many times does ~c[uninitialized] appear in
  ~c[(@ b)]?
  ~bv[]
  ACL2 !>(cnt 'demo (@ b) 4 'uninitialized)
  ~ev[]
  The answer is ~c[3], because positions ~c[2], ~c[3] and ~c[4] of the array contain
  that default value.

  Now imagine that we want to assign ~c['two] to index ~c[2] and then count
  how many times the 2nd element of the array occurs in the array.
  This specification is actually ambiguous.  In assigning to ~c[b] we
  produce a new array, which we might call ~c[c].  Do we mean to count the
  occurrences in ~c[c] of the 2nd element of ~c[b] or the 2nd element of ~c[c]?
  That is, do we count the occurrences of ~c[uninitialized] or the
  occurrences of ~c[two]?  If we mean the former the correct answer is ~c[2]
  (positions ~c[3] and ~c[4] are ~c[uninitialized] in ~c[c]); if we mean the latter,
  the correct answer is ~c[1] (there is only one occurrence of ~c[two] in ~c[c]).

  Below are ACL2 renderings of the two meanings, which we call
  ~c[[former~]] and ~c[[latter~]].  (Warning:  Our description of these
  examples, and of an example ~c[[fast former~]] that follows, assumes
  that only one of these three examples is actually executed; for
  example, they are not executed in sequence.  See ``A Word of
  Warning'' below for more about this issue.)
  ~bv[]
  (cnt 'demo (aset1 'demo (@ b) 2 'two) 4 (aref1 'demo (@ b) 2))  ; [former]

  (let ((c (aset1 'demo (@ b) 2 'two)))                           ; [latter]
    (cnt 'demo c 4 (aref1 'demo c 2)))
  ~ev[]
  Note that in ~c[[former~]] we create ~c[c] in the second argument of the
  call to ~c[cnt] (although we do not give it a name) and then refer to ~c[b]
  in the fourth argument.  This is unconventional because the second
  reference to ~c[b] in ~c[[former~]] is no longer the semantic value of ~c[demo].
  While ACL2 computes the correct answer, namely ~c[2], the execution of
  the ~ilc[aref1] expression in ~c[[former~]] is done slowly.

  A conventional rendering with the same meaning is
  ~bv[]
  (let ((x (aref1 'demo (@ b) 2)))                           ; [fast former]
    (cnt 'demo (aset1 'demo (@ b) 2 'two) 4 x))
  ~ev[]
  which fetches the 2nd element of ~c[b] before creating ~c[c] by
  assignment.  It is important to understand that ~c[[former~]] and
  ~c[[fast former~]] mean exactly the same thing: both count the number
  of occurrences of ~c[uninitialized] in ~c[c].  Both are legal ACL2 and
  both compute the same answer, ~c[2].  Indeed, we can symbolically
  transform ~c[[fast former~]] into ~c[[former~]] merely by substituting
  the binding of ~c[x] for ~c[x] in the body of the ~ilc[let].  But ~c[[fast former~]]
  can be evaluated faster than ~c[[former~]] because all of the
  references to ~c[demo] use the then-current semantic value of
  ~c[demo], which is ~c[b] in the first line and ~c[c] throughout the
  execution of the ~c[cnt] in the second line.  ~c[[Fast former~]] is
  the preferred form, both because of its execution speed and its
  clarity.  If you were writing in a conventional language you would
  have to write something like ~c[[fast former~]] because there is no
  way to refer to the 2nd element of the old value of ~c[b] after
  smashing ~c[b] unless it had been saved first.

  We turn now to ~c[[latter~]].  It is both clear and efficient.  It
  creates ~c[c] by assignment to ~c[b] and then it fetches the 2nd element of
  ~c[c], ~c[two], and proceeds to count the number of occurrences in ~c[c].  The
  answer is ~c[1].  ~c[[Latter~]] is a good example of typical ACL2 array
  manipulation: after the assignment to ~c[b] that creates ~c[c], ~c[c] is used
  throughout.

  It takes a while to get used to this because most of us have grown
  accustomed to the peculiar semantics of arrays in conventional
  languages.  For example, in raw lisp we might have written something
  like the following, treating ~c[b] as a ``global variable'':
  ~bv[]
  (cnt 'demo (aset 'demo b 2 'two) 4 (aref 'demo b 2))
  ~ev[]
  which sort of resembles ~c[[former~]] but actually has the semantics of
  ~c[[latter~]] because the ~c[b] from which ~c[aref] fetches the 2nd element is
  not the same ~c[b] used in the ~c[aset]!  The array ~c[b] is destroyed by the
  ~c[aset] and ~c[b] henceforth refers to the array produced by the ~c[aset], as
  written more clearly in ~c[[latter~]].

  A Word of Warning:  Users must exercise care when experimenting with
  ~c[[former~]], ~c[[latter~]] and ~c[[fast former~]].  Suppose you have
  just created ~c[b] with the assignment shown above,
  ~bv[]
  ACL2 !>(assign b (aset1 'demo (@ a) 1 'one))
  ~ev[]
  If you then evaluate ~c[[former~]] in ACL2 it will complain that the
  ~ilc[aref1] is slow and compute the answer, as discussed.  Then suppose
  you evaluate ~c[[latter~]] in ACL2.  From our discussion you might expect
  it to execute fast ~-[] i.e., issue no complaint.  But in fact you
  will find that it complains repeatedly.  The problem is that the
  evaluation of ~c[[former~]] changed the semantic value of ~c[demo] so that it
  is no longer ~c[b].  To try the experiment correctly you must make ~c[b] be
  the semantic value of ~c[demo] again before the next example is
  evaluated.  One way to do that is to execute
  ~bv[]
  ACL2 !>(assign b (compress1 'demo (@ b)))
  ~ev[]
  before each expression.  Because of issues like this it is often
  hard to experiment with ACL2 arrays at the top-level.  We find it
  easier to write functions that use arrays correctly and efficiently
  than to so use them interactively.

  This last assignment also illustrates a very common use of
  ~ilc[compress1].  While it was introduced as a means of removing
  irrelevant pairs from an array built up by repeated assignments, it
  is actually most useful as a way of insuring fast access to the
  elements of an array.

  Many array processing tasks can be divided into two parts.  During
  the first part the array is built.  During the second part the array
  is used extensively but not modified.  If your ~il[programming] task can
  be so divided, it might be appropriate to construct the array
  entirely with list processing, thereby saving the cost of
  maintaining the semantic value of the name while few references are
  being made.  Once the alist has stabilized, it might be worthwhile
  to treat it as an array by calling ~ilc[compress1], thereby gaining
  constant time access to it.

  ACL2's theorem prover uses this technique in connection with its
  implementation of the notion of whether a ~il[rune] is ~il[disable]d or not.
  Associated with every ~il[rune] is a unique integer ~c[index], called its
  ``nume.''  When each rule is stored, the corresponding nume is
  stored as a component of the rule.  ~il[Theories] are lists of ~il[rune]s and
  membership in the ``current theory'' indicates that the
  corresponding rule is ~il[enable]d.  But these lists are very long and
  membership is a linear-time operation.  So just before a proof
  begins we map the list of ~il[rune]s in the current theory into an alist
  that pairs the corresponding numes with ~c[t].  Then we compress this
  alist into an array.  Thus, given a rule we can obtain its nume
  (because it is a component) and then determine in constant time
  whether it is ~il[enable]d.  The array is never modified during the
  proof, i.e., ~ilc[aset1] is never used in this example.  From the logical
  perspective this code looks quite odd:  we have replaced a
  linear-time membership test with an apparently linear-time ~ilc[assoc]
  after going to the trouble of mapping from a list of ~il[rune]s to an
  alist of numes.  But because the alist of numes is an array, the
  ``apparently linear-time ~ilc[assoc]'' is more apparent than real; the
  operation is constant-time.~/

  :cited-by Programming")

(deflabel arrays-example
  :doc

; The transcript below was generated essentially after executing the following
; two forms:
; (set-fmt-soft-right-margin 55 state)
; (set-fmt-hard-right-margin 68 state)

  ":Doc-Section Arrays

  an example illustrating ACL2 arrays~/

  The example below illustrates the use of ACL2 arrays.  It is not, of
  course, a substitute for the detailed explanations provided
  elsewhere (~pl[arrays], including subtopics).~/

  ~bv[]
  ACL2 !>(defun defarray (name size initial-element)
           (compress1 name
                      (cons (list :HEADER
                                  :DIMENSIONS (list size)
                                  :MAXIMUM-LENGTH (1+ size)
                                  :DEFAULT initial-element
                                  :NAME name)
                            nil)))

  Since DEFARRAY is non-recursive, its admission is trivial.  We observe
  that the type of DEFARRAY is described by the theorem
  (AND (CONSP (DEFARRAY NAME SIZE INITIAL-ELEMENT))
       (TRUE-LISTP (DEFARRAY NAME SIZE INITIAL-ELEMENT))).
  We used the :type-prescription rule COMPRESS1.

  Summary
  Form:  ( DEFUN DEFARRAY ...)
  Rules: ((:TYPE-PRESCRIPTION COMPRESS1))
  Warnings:  None
  Time:  0.02 seconds (prove: 0.00, print: 0.02, other: 0.00)
   DEFARRAY
  ACL2 !>(assign my-ar (defarray 'a1 5 17))
   ((:HEADER :DIMENSIONS (5)
             :MAXIMUM-LENGTH 6 :DEFAULT 17 :NAME A1))
  ACL2 !>(aref1 'a1 (@ my-ar) 3)
  17
  ACL2 !>(aref1 'a1 (@ my-ar) 8)


  ACL2 Error in TOP-LEVEL:  The guard for the function symbol AREF1,
  which is
  (AND (ARRAY1P NAME L) (INTEGERP N) (>= N 0) (< N (CAR (DIMENSIONS NAME L)))),
  is violated by the arguments in the call (AREF1 'A1 '(#) 8).

  ACL2 !>(assign my-ar (aset1 'a1 (@ my-ar) 3 'xxx))
   ((3 . XXX)
    (:HEADER :DIMENSIONS (5)
             :MAXIMUM-LENGTH 6 :DEFAULT 17 :NAME A1))
  ACL2 !>(aref1 'a1 (@ my-ar) 3)
  XXX
  ACL2 !>(aset1 'a1 (@ my-ar) 3 'yyy) ; BAD: (@ my-ar) now points to
                                      ;      an old copy of the array!
  ((3 . YYY)
   (3 . XXX)
   (:HEADER :DIMENSIONS (5)
            :MAXIMUM-LENGTH 6 :DEFAULT 17 :NAME A1))
  ACL2 !>(aref1 'a1 (@ my-ar) 3) ; Because of \"BAD\" above, the array
                                 ; access is done using assoc rather
                                 ; than Lisp aref, hence is slower;
                                 ; but the answer is still correct,
                                 ; reflecting the value in (@ my-ar),
                                 ; which was not changed above.


  **********************************************************
  Slow Array Access!  A call of AREF1 on an array named
  A1 is being executed slowly.  See :DOC slow-array-warning
  **********************************************************

  XXX
  ACL2 !>
  ~ev[]")

(deflabel slow-array-warning
  :doc
  ":Doc-Section Arrays

  a warning or error issued when ~il[arrays] are used inefficiently~/

  If you use ACL2 ~il[arrays] you may sometimes see a ~st[slow array] warning.
  We explain below what that warning means and some likely ``mistakes''
  it may signify.

  First, we note that you can control whether or not you get a warning and, if
  so, whether or not a break (error from which you can continue; ~pl[break$])
  ensues:
  ~bv[]
  (assign slow-array-action :warning) ; warn on slow array access (default)
  (assign slow-array-action :break)   ; warn as above, and then call break$
  (assign slow-array-action nil) ; do not warn or break on slow array access
  ~ev[]
  If you are using ACL2 arrays, then you probably care about performance, in
  which case it is probably best to avoid the ~c[nil] setting.  Below we assume
  the default behavior: a warning, but no break.~/

  The discussion in the documentation for ~il[arrays] defines what we
  mean by the semantic value of a name.  As noted there, behind the
  scenes ACL2 maintains the invariant that with some names there is
  associated a pair consisting of an ACL2 array ~c[alist], called the
  semantic value of the name, and an equivalent raw lisp array.
  Access to ACL2 array elements, as in ~c[(aref1 name alist i)], is
  executed in constant time when the array alist is the semantic value
  of the name, because we can just use the corresponding raw lisp
  array to obtain the answer.  ~ilc[Aset1] and ~ilc[compress1] modify the raw lisp
  array appropriately to maintain the invariant.

  If ~ilc[aref1] is called on a name and alist, and the alist is not the
  then-current semantic value of the name, the correct result is
  computed but it requires linear time because the alist must be
  searched.  When this happens, ~ilc[aref1] prints a ~st[slow array] warning
  message to the comment window.  ~ilc[Aset1] behaves similarly because the
  array it returns will cause the ~st[slow array] warning every time it is
  used.

  From the purely logical perspective there is nothing ``wrong'' about
  such use of ~il[arrays] and it may be spurious to print a warning
  message.  But because ~il[arrays] are generally used to achieve
  efficiency, the ~st[slow array] warning often means the user's
  intentions are not being realized.  Sometimes merely performance
  expectations are not met; but the message may mean that the
  functional behavior of the program is different than intended.

  Here are some ``mistakes'' that might cause this behavior.  In the
  following we suppose the message was printed by ~ilc[aset1] about an array
  named ~c[name].  Suppose the alist supplied ~ilc[aset1] is ~c[alist].

  (1) ~ilc[Compress1] was never called on ~c[name] and ~c[alist].  That is, perhaps
  you created an alist that is an ~ilc[array1p] and then proceeded to access
  it with ~ilc[aref1] but never gave ACL2 the chance to create a raw lisp
  array for it.  After creating an alist that is intended for use as
  an array, you must do ~c[(compress1 name alist)] and pass the resulting
  ~c[alist'] as the array.

  (2) ~c[Name] is misspelled.  Perhaps the array was compressed under the
  name ~c['delta-1] but accessed under ~c['delta1]?

  (3) An ~ilc[aset1] was done to modify ~c[alist], producing a new array,
  ~c[alist'], but you subsequently used ~c[alist] as an array.  Inspect all
  ~c[(aset1 name ...)] occurrences and make sure that the alist modified
  is never used subsequently (either in that function or any other).
  It is good practice to adopt the following syntactic style.  Suppose
  the alist you are manipulating is the value of the local variable
  ~c[alist].  Suppose at some point in a function definition you wish to
  modify ~c[alist] with ~ilc[aset1].  Then write
  ~bv[]
  (let ((alist (aset1 name alist i val))) ...)
  ~ev[]
  and make sure that the subsequent function body is entirely within
  the scope of the ~ilc[let].  Any uses of ~c[alist] subsequently will refer
  to the new alist and it is impossible to refer to the old alist.
  Note that if you write
  ~bv[]
   (foo (let ((alist (aset1 name alist i val))) ...)  ; arg 1
        (bar alist))                                  ; arg 2
  ~ev[]
  you have broken the rules, because in ~c[arg 1] you have modified
  ~c[alist] but in ~c[arg 2] you refer to the old value.  An appropriate
  rewriting is to lift the ~ilc[let] out:
  ~bv[]
   (let ((alist (aset1 name alist alist i val)))
     (foo ...                                         ; arg 1
          (bar alist)))                               ; arg 2
  ~ev[]
  Of course, this may not mean the same thing.

  (4) A function which takes ~c[alist] as an argument and modifies it with
  ~ilc[aset1] fails to return the modified version.  This is really the same
  as (3) above, but focuses on function interfaces.  If a function
  takes an array ~c[alist] as an argument and the function uses ~ilc[aset1] (or
  a subfunction uses ~ilc[aset1], etc.), then the function probably
  ``ought'' to return the result produced by ~ilc[aset1].  The reasoning
  is as follows.  If the array is passed into the function, then the
  caller is holding the array.  After the function modifies it, the
  caller's version of the array is obsolete.  If the caller is going
  to make further use of the array, it must obtain the latest version,
  i.e., that produced by the function.")

(defun array1p (name l)

  ":Doc-Section Arrays

  recognize a 1-dimensional array~/
  ~bv[]
  Example Form:
  (array1p 'delta1 a)~/

  General Form:
  (array1p name alist)
  ~ev[]
  where ~c[name] and ~c[alist] are arbitrary objects.  This function
  returns ~c[t] if ~c[alist] is a 1-dimensional ACL2 array.  Otherwise it
  returns ~c[nil].  The function operates in constant time if ~c[alist] is the
  semantic value of ~c[name].  ~l[arrays]."

  (declare (xargs :guard t))
  #-acl2-loop-only
  (cond ((symbolp name)
         (let ((prop (get-acl2-array-property name)))
           (cond ((and prop (eq l (car prop)))
                  (return-from array1p (= 1 (array-rank (cadr prop)))))))))

; Note: This function does not use the header, dimensions, and maximum-length
; functions, but obtains their results through duplication of code.  The reason
; is that we want those functions to have array1p or array2p as guards, so they
; can't be introduced before array1p.  The reason we want this function in
; their guards, even though it is overly strong, is as follows.  Users who use
; aref1 guard their functions with arrayp1 and then start proving theorems.
; The theorems talk about dimensions, etc.  If dimensions, etc., are guarded
; with weaker things (like keyword-value-listp) then you find yourself either
; having to open up array1p or forward chain from it.  But array1p is fairly
; hideous.  So we intend to keep it disabled and regard it as the atomic test
; that it is ok to use array processing functions.

  (and (symbolp name)
       (alistp l)
       (let ((header-keyword-list (cdr (assoc-eq :header l))))
         (and (keyword-value-listp header-keyword-list)
              (let ((dimensions (cadr (assoc-keyword :dimensions header-keyword-list)))
                    (maximum-length (cadr (assoc-keyword :maximum-length header-keyword-list))))
                (and (true-listp dimensions)
                     (equal (length dimensions) 1)
                     (integerp (car dimensions))
                     (integerp maximum-length)
                     (< 0 (car dimensions))
                     (< (car dimensions) maximum-length)
                     (<= maximum-length *maximum-positive-32-bit-integer*)
                     (bounded-integer-alistp l (car dimensions))))))))

(defthm array1p-forward
  (implies (array1p name l)
           (and (symbolp name)
                (alistp l)
                (keyword-value-listp (cdr (assoc-eq :header l)))
                (true-listp (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l)))))
                (equal (length (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l)))))
                       1)
                (integerp (car (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l))))))
                (integerp (cadr (assoc-keyword :maximum-length (cdr (assoc-eq :header l)))))
                (< 0 (car (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l))))))
                (< (car (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l)))))
                   (cadr (assoc-keyword :maximum-length (cdr (assoc-eq :header l)))))
                (<= (cadr (assoc-keyword :maximum-length (cdr (assoc-eq :header l))))
                    *maximum-positive-32-bit-integer*)
                (bounded-integer-alistp
                 l
                 (car (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l))))))))
  :rule-classes :forward-chaining)

(defthm array1p-linear
  (implies (array1p name l)
           (and (< 0 (car (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l))))))
                (< (car (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l)))))
                   (cadr (assoc-keyword :maximum-length (cdr (assoc-eq :header l)))))
                (<= (cadr (assoc-keyword :maximum-length (cdr (assoc-eq :header l))))
                    *maximum-positive-32-bit-integer*)))
  :rule-classes ((:linear :match-free :all)))

(defun bounded-integer-alistp2 (l i j)
  (declare (xargs :guard t))
  (cond ((atom l) (null l))
        (t (and (consp (car l))
                (let ((key (caar l)))
                  (and (or (eq key :header)
                           (and (consp key)
                                (let ((i1 (car key))
                                      (j1 (cdr key)))
                                  (and (integerp i1)
                                       (integerp j1)
                                       (integerp i)
                                       (integerp j)
                                       (>= i1 0)
                                       (< i1 i)
                                       (>= j1 0)
                                       (< j1 j)))))))
                (bounded-integer-alistp2 (cdr l) i j)))))

(defun assoc2 (i j l)
  (declare (xargs :guard (and (integerp i)
                              (integerp j))))
  (if (atom l)
      nil
    (if (and (consp (car l))
             (consp (caar l))
             (eql i (caaar l))
             (eql j (cdaar l)))
        (car l)
      (assoc2 i j (cdr l)))))

(defun array2p (name l)

  ":Doc-Section Arrays

  recognize a 2-dimensional array~/
  ~bv[]
  Example Form:
  (array2p 'delta1 a)~/

  General Form:
  (array2p name alist)
  ~ev[]
  where ~c[name] and ~c[alist] are arbitrary objects.  This function returns ~c[t] if
  ~c[alist] is a 2-dimensional ACL2 array.  Otherwise it returns ~c[nil].  The function
  operates in constant time if ~c[alist] is the semantic value of ~c[name].  ~l[arrays]."

  (declare (xargs :guard t))
  #-acl2-loop-only
  (cond ((symbolp name)
         (let ((prop (get-acl2-array-property name)))
           (cond ((and prop (eq l (car prop))
                       (return-from array2p
                                    (= 2 (array-rank (cadr prop))))))))))
  (and (symbolp name)
       (alistp l)
       (let ((header-keyword-list (cdr (assoc-eq :header l))))
         (and (keyword-value-listp header-keyword-list)
              (let ((dimensions (cadr (assoc-keyword :dimensions header-keyword-list)))
                    (maximum-length (cadr (assoc-keyword :maximum-length header-keyword-list))))
                (and (true-listp dimensions)
                     (equal (length dimensions) 2)
                     (let ((d1 (car dimensions))
                           (d2 (cadr dimensions)))
                       (and (integerp d1)
                            (integerp d2)
                            (integerp maximum-length)
                            (< 0 d1)
                            (< 0 d2)
                            (< (* d1 d2) maximum-length)
                            (<= maximum-length
                                *maximum-positive-32-bit-integer*)
                            (bounded-integer-alistp2 l d1 d2)))))))))

(defthm array2p-forward
  (implies (array2p name l)
           (and (symbolp name)
                (alistp l)
                (keyword-value-listp (cdr (assoc-eq :header l)))
                (true-listp (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l)))))
                (equal (length (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l))))) 2)
                (integerp (car (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l))))))
                (integerp (cadr (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l))))))
                (integerp (cadr (assoc-keyword :maximum-length (cdr (assoc-eq :header l)))))
                (< 0 (car (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l))))))
                (< 0 (cadr (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l))))))
                (< (* (car (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l)))))
                      (cadr (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l))))))
                   (cadr (assoc-keyword :maximum-length (cdr (assoc-eq :header l)))))
                (<= (cadr (assoc-keyword :maximum-length (cdr (assoc-eq :header l))))
                    *maximum-positive-32-bit-integer*)
                (bounded-integer-alistp2
                 l
                 (car (cadr (assoc-keyword
                             :dimensions
                             (cdr (assoc-eq :header l)))))
                 (cadr (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l))))))))
  :rule-classes :forward-chaining)

(defthm array2p-linear
  (implies (array2p name l)
           (and (< 0 (car (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l))))))
                (< 0 (cadr (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l))))))
                (< (* (car (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l)))))
                      (cadr (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l))))))
                   (cadr (assoc-keyword :maximum-length (cdr (assoc-eq :header l)))))
                (<= (cadr (assoc-keyword :maximum-length (cdr (assoc-eq :header l))))
                    *maximum-positive-32-bit-integer*)))
  :rule-classes ((:linear :match-free :all)))

; (in-theory (disable array1p array2p))

(defun header (name l)
  (declare (xargs :guard (or (array1p name l) (array2p name l))))

  ":Doc-Section Arrays

  return the header of a 1- or 2-dimensional array~/
  ~bv[]
  Example Form:
  (header 'delta1 a)~/

  General Form:
  (header name alist)
  ~ev[]
  where ~c[name] is arbitrary and ~c[alist] is a 1- or 2-dimensional array.
  This function returns the header of the array ~c[alist].  The function
  operates in virtually constant time if ~c[alist] is the semantic value
  of ~c[name].  ~l[arrays]."

  #+acl2-loop-only
  (prog2$ name ;to avoid warning in *1* function definition
          (assoc-eq :header l))

; In the usual case, this function will take constant time regardless
; of where the header is in the alist.  This makes the related
; functions for getting the fields of the header fast, too.

  #-acl2-loop-only
  (let ((prop (get-acl2-array-property name)))
    (cond ((and prop (eq l (car prop)))
           (cadddr prop))
          (t (assoc-eq :header l)))))

(defun dimensions (name l)

  ":Doc-Section Arrays

  return the ~c[:dimensions] from the ~il[header] of a 1- or 2-dimensional array~/
  ~bv[]
  Example Form:
  (dimensions 'delta1 a)~/

  General Form:
  (dimensions name alist)
  ~ev[]
  where ~c[name] is arbitrary and ~c[alist] is a 1- or 2-dimensional array.
  This function returns the dimensions list of the array ~c[alist].  That
  list will either be of the form ~c[(dim1)] or ~c[(dim1 dim2)], depending on
  whether ~c[alist] is a 1- or 2-dimensional array.  ~c[Dim1] and ~c[dim2] will be
  integers and each exceed by 1 the maximum legal corresponding index.
  Thus, if ~c[dimensions] returns, say, ~c['(100)] for an array ~c[a]
  named ~c['delta1], then ~c[(aref1 'delta1 a 99)] is legal but
  ~c[(aref1 'delta1 a 100)] violates the ~il[guard]s on ~ilc[aref1].
  ~c[Dimensions] operates in virtually constant time if ~c[alist] is the
  semantic value of ~c[name].  ~l[arrays]."

  (declare (xargs :guard (or (array1p name l) (array2p name l))))
  (cadr (assoc-keyword :dimensions
                       (cdr (header name l)))))

(defun maximum-length (name l)

  ":Doc-Section Arrays

  return the ~c[:maximum-length] from the ~il[header] of an array~/
  ~bv[]
  Example Form:
  (maximum-length 'delta1 a)~/

  General Form:
  (maximum-length name alist)
  ~ev[]
  where ~c[name] is an arbitrary object and ~c[alist] is a 1- or
  2-dimensional array.  This function returns the contents of the
  ~c[:maximum-length] field of the ~il[header] of ~c[alist].  Whenever an ~ilc[aset1] or
  ~ilc[aset2] would cause the length of the alist to exceed its maximum
  length, a ~ilc[compress1] or ~ilc[compress2] is done automatically to remove
  irrelevant pairs from the array.  ~c[Maximum-length] operates in
  virtually constant time if ~c[alist] is the semantic value of ~c[name].
  ~l[arrays]."

  (declare (xargs :guard (or (array1p name l) (array2p name l))))
  (cadr (assoc-keyword :maximum-length (cdr (header name l)))))

(defun default (name l)

  ":Doc-Section Arrays

  return the ~c[:default] from the ~il[header] of a 1- or 2-dimensional array~/
  ~bv[]
  Example Form:
  (default 'delta1 a)~/

  General Form:
  (default name alist)
  ~ev[]
  where ~c[name] is an arbitrary object and ~c[alist] is a 1- or
  2-dimensional array.  This function returns the contents of the
  ~c[:default] field of the ~il[header] of ~c[alist].  When ~ilc[aref1] or ~ilc[aref2] is used
  to obtain a value for an index (or index pair) not bound in ~c[alist],
  the default value is returned instead.  Thus, the array ~c[alist] may be
  thought of as having been initialized with the default value.
  ~c[default] operates in virtually constant time if ~c[alist] is the semantic
  value of ~c[name].  ~l[arrays]."

  (declare (xargs :guard (or (array1p name l) (array2p name l))))
  (cadr (assoc-keyword :default
                       (cdr (header name l)))))

; Parallelism wart: once upon a time we locked all array operations.  Since
; then, two improvements have been made to ACL2: (1) the
; enabled-array-structure now uses unique names based on the current subgoal
; and (2) the array implementation itself was improved to be "more" thread-safe
; (you can compare the implementation of aset1 and other related functions in
; ACL2 3.6.1 and ACL2 4.0 to see the change).  However, we suspect that
; that arrays are not thread-safe, as we have acknowledged in :DOC
; unsupported-waterfall-parallelism-features.
;
; Rager thinks that we stopped locking the array operations because the prover
; incurred significant overhead (if he can recall correctly, it was about a 40%
; increase in time required to certify a semi-expensive book) with locking
; enabled.  He thinks that the change to enabled arrays, named (1) above, could
; have eliminated most of this overhead.  However, further investigation is
; called for.

; For now, we do not lock any array operations, but we leave the dead code as
; hints to ourselves that we may need to do so.  When this wart is addressed,
; this dead code (which can be found by searching for *acl2-par-arrays-lock*)
; should either be uncommented and modified, or it should be removed.
;   #+(and acl2-par (not acl2-loop-only))
;   (deflock *acl2-par-arrays-lock*)

(defun aref1 (name l n)

  ":Doc-Section Arrays

  access the elements of a 1-dimensional array~/
  ~bv[]
  Example Form:
  (aref1 'delta1 a (+ i k))~/

  General Form:
  (aref1 name alist index)
  ~ev[]
  where ~c[name] is a symbol, ~c[alist] is a 1-dimensional array and ~c[index]
  is a legal index into ~c[alist].  This function returns the value
  associated with ~c[index] in ~c[alist], or else the default value of the
  array.  ~l[arrays] for details.

  This function executes in virtually constant time if ~c[alist] is in
  fact the ``semantic value'' associated with ~c[name] (~pl[arrays]).
  When it is not, ~c[aref1] must do a linear search through ~c[alist].  In
  that case the correct answer is returned but a ~st[slow array] comment is
  printed to the comment window.  ~l[slow-array-warning]."

  #+acl2-loop-only
  (declare (xargs :guard (and (array1p name l)
                              (integerp n)
                              (>= n 0)
                              (< n (car (dimensions name l))))))
  #+acl2-loop-only
  (let ((x (and (not (eq n :header)) (assoc n l))))
    (cond ((null x) (default name l))
          (t (cdr x))))

; We are entitled to make the following declaration because of the
; guard.

  #-acl2-loop-only
  (declare (type (unsigned-byte 31) n))
  #-acl2-loop-only
; See comment above (for #+acl2-par) about *acl2-par-arrays-lock*:
; (with-lock
;  *acl2-par-arrays-lock*
  (let ((prop (get-acl2-array-property name)))
    (cond ((eq l (car prop))
           (svref (the simple-vector (car (cdr prop)))
                  n))
          (t (slow-array-warning 'aref1 name)
             (let ((x (assoc n l))) ; n is a number, hence not :header
               (cond ((null x) (default name l))
                     (t (cdr x))))))))

(defun compress11 (name l i n default)
  (declare (xargs :guard (and (array1p name l)
                              (integerp i)
                              (integerp n)
                              (<= i n))
                  :measure (nfix (- n i))))
  (cond ((zp (- n i)) nil)
        (t (let ((pair (assoc i l)))
             (cond ((or (null pair)
                        (equal (cdr pair) default))
                    (compress11 name l (+ i 1) n default))
                   (t (cons pair
                            (compress11 name l (+ i 1) n default))))))))

#-acl2-loop-only
(defconstant *invisible-array-mark* 'acl2_invisible::|An Invisible Array Mark|)

(defun array-order (header)
  (declare (xargs :guard (and (consp header)
                              (keyword-value-listp (cdr header)))))
  (let ((orderp (assoc-keyword :order (cdr header))))
    (cond
     ((and orderp (or (eq (cadr orderp) nil)
                      (eq (cadr orderp) :none)))
      nil)
     ((and orderp (eq (cadr orderp) '>))
      '>)
     (t ; default
      '<))))

(defun compress1 (name l)

  ":Doc-Section Arrays

  remove irrelevant pairs from a 1-dimensional array~/
  ~bv[]
  Example Form:
  (compress1 'delta1 a)~/

  General Form:
  (compress1 name alist)
  ~ev[]
  where ~c[name] is a symbol and ~c[alist] is a 1-dimensional array, generally
  named ~c[name].  ~l[arrays] for details.  Logically speaking, this function
  removes irrelevant pairs from ~c[alist], possibly shortening it.  The
  function returns a new array, ~c[alist'], with the same ~ilc[header]
  (including name and dimension) as ~c[alist], that, under ~ilc[aref1], is
  everywhere equal to ~c[alist].  That is, ~c[(aref1 name alist' i)] is
  ~c[(aref1 name alist i)], for all legal indices ~c[i].  ~c[Alist'] may be
  shorter than ~c[alist] and the non-irrelevant pairs may occur in a different
  order than in ~c[alist].

  Practically speaking, this function plays an important role in the efficient
  implementation of ~ilc[aref1].  In addition to creating the new array,
  ~c[alist'], ~c[compress1] makes that array the ``semantic value'' of ~c[name]
  and allocates a raw lisp array to ~c[name].  For each legal index, ~c[i],
  that raw lisp array contains ~c[(aref1 name alist' i)] in slot ~c[i].  Thus,
  subsequent ~ilc[aref1] operations can be executed in virtually constant time
  provided they are given ~c[name] and the ~c[alist'] returned by the most
  recently executed ~c[compress1] or ~ilc[aset1] on ~c[name].  ~l[arrays].

  In general, ~c[compress1] returns an alist whose ~ilc[cdr] is an association
  list whose keys are nonnegative integers in ascending order.  However, if the
  ~ilc[header] specifies an ~c[:order] of ~c[>] then the keys will occur in
  descending order, and if the ~c[:order] is ~c[:none] or ~c[nil] then the keys
  will not be sorted, i.e., ~c[compress1] is logically the identity function
  (though it still attaches an array under the hood).  Note however that a
  ~ilc[compress1] call is replaced by a hard error if the header specifies an
  ~c[:order] of ~c[:none] or ~c[nil] and the array's length exceeds the
  ~ilc[maximum-length] field of its ~ilc[header]."

; The uses of (the (unsigned-byte 31) ...) below rely on the array1p guard,
; which for example guarantees that the dimension is bounded by
; *maximum-positive-32-bit-integer* and that each array index (i.e., each car)
; is less than the dimension.  These declarations probably only assist
; efficiency in GCL, but that may be the Lisp that benefits most from such
; fixnum declarations, anyhow.

  #+acl2-loop-only
  (declare (xargs :guard (array1p name l)))
  #+acl2-loop-only
  (case (array-order (header name l))
    (< (cons (header name l)
             (compress11
              name l 0
              (car (dimensions name l))
              (default name l))))
    (> (cons (header name l)
             (reverse (compress11
                       name l 0
                       (car (dimensions name l))
                       (default name l)))))
    (t
     (prog2$
      (and (> (length l)
              (maximum-length name l))
           (hard-error 'compress1
                       "Attempted to compress a one-dimensional array named ~
                        ~x0 whose header specifies :ORDER ~x1 and whose ~
                        length, ~x2, exceeds its maximum-length, ~x3."
                       (list (cons #\0 name)
                             (cons #\1 nil)
                             (cons #\2 (length l))
                             (cons #\3 (maximum-length name l)))))
      l)))
  #-acl2-loop-only
; See comment above (for #+acl2-par) about *acl2-par-arrays-lock*:
; (with-lock
;  *acl2-par-arrays-lock*
  (let* ((old (get-acl2-array-property name))
         (header (header name l))
         (length (car (cadr (assoc-keyword :dimensions (cdr header)))))
         (maximum-length (cadr (assoc-keyword :maximum-length (cdr header))))
         (default (cadr (assoc-keyword :default (cdr header))))
         (order (array-order header))
         old-car
         ar
         in-order)

    (when (and (null order)
               (> (length l) maximum-length))
      (hard-error 'compress1
                  "Attempted to compress a one-dimensional array named ~x0 ~
                   whose header specifies :ORDER ~x1 and whose length, ~x2, ~
                   exceeds its maximum-length, ~x3."
                  (list (cons #\0 name)
                        (cons #\1 nil)
                        (cons #\2 (length l))
                        (cons #\3 (maximum-length name l)))))

; Get an array that is all filled with the special mark *invisible-array-mark*.

    (cond ((and old
                (= 1 (array-rank (cadr old)))
                (= (length (cadr old)) length))
           (setq old-car (car old))
           (setf (car old) *invisible-array-mark*)
           (setq ar (cadr old))
           (do ((i (1- length) (1- i))) ((< i 0))
               (declare (type (signed-byte 32) i))
               (setf (svref ar i) *invisible-array-mark*)))
          (t (setq ar (make-array$ length :initial-element
                                   *invisible-array-mark*))))

; Store the value of each pair under its key (unless it is covered by
; an earlier pair with the same key).

    (do ((tl l (cdr tl)))
        ((null tl))
        (let ((index (caar tl)))
          (cond ((eq index :header) nil)
                ((eq *invisible-array-mark* (svref ar index))
                 (setf (svref ar index)
                       (cdar tl))))))

; Determine whether l is already is in normal form (header first,
; strictly ascending keys, no default values, no extra header.)

    (setq in-order t)
    (when order
      (cond ((eq (caar l) :header)
             (do ((tl (cdr l) (cdr tl)))
                 (nil)
                 (cond ((or (eq (caar tl) :header)
                            (eq (car (cadr tl)) :header))
                        (setq in-order nil)
                        (return nil))
                       ((equal (cdr (car tl)) default)
                        (setq in-order nil)
                        (return nil))
                       ((null (cdr tl)) (return nil))
                       ((if (eq order '>)
                            (<= (the (unsigned-byte 31) (caar tl))
                                (the (unsigned-byte 31) (car (cadr tl))))
                          (>= (the (unsigned-byte 31) (caar tl))
                              (the (unsigned-byte 31) (car (cadr tl)))))
                        (setq in-order nil)
                        (return nil)))))
            (t (setq in-order nil))))
    (let ((num 1) x max-ar)
      (declare (type (unsigned-byte 31) num))

;  In one pass, set x to the value to be returned, put defaults into the array
;  where the invisible mark still sits, and calculate the length of x.

      (cond (in-order
             (do ((i (1- length) (1- i))) ((< i 0))
                 (declare (type (signed-byte 32) i))
                 (let ((val (svref ar i)))
                   (cond ((eq *invisible-array-mark* val)
                          (setf (svref ar i) default))
                         (t (setq num (the (unsigned-byte 31) (1+ num)))))))
             (setq x l))
            ((eq order '>)
             (do ((i 0 (1+ i))) ((int= i length))
                 (declare (type (unsigned-byte 31) i))
                 (let ((val (svref ar i)))
                   (cond ((eq *invisible-array-mark* val)
                          (setf (svref ar i) default))
                         ((equal val default) nil)
                         (t (push (cons i val) x)
                            (setq num (the (unsigned-byte 31) (1+ num)))))))
             (setq x (cons header x)))
            (t (do ((i (1- length) (1- i))) ((< i 0))
                   (declare (type (signed-byte 32) i))
                   (let ((val (svref ar i)))
                     (cond ((eq *invisible-array-mark* val)
                            (setf (svref ar i) default))
                           ((equal val default) nil)
                           (t (push (cons i val) x)
                              (setq num (the (unsigned-byte 31) (1+ num)))))))
               (setq x (cons header x))))
      (cond (old (setq max-ar (caddr old))
                 (setf (aref (the (array (unsigned-byte 31) (*)) max-ar)
                             0)
                       (the (unsigned-byte 31)
                            (- maximum-length num))))
            (t (setq max-ar
                     (make-array$ 1
                                  :initial-contents
                                  (list (- maximum-length num))
                                  :element-type
                                  '(unsigned-byte 31)))))
      (cond (old
             (setf (cadr old) ar)
             (setf (cadddr old) header)

; We re-use the old value if it is equal to the new value.  The example
; regarding compress1 in :doc note-2-7-other shows why we need to do this.  In
; case that is not enough of a reason, here is a comment from Version_2.6 code,
; which is once again the code in Version_2.8.  (Version_2.7 had a bug from an
; ill-advised attempt to deal with a problem with slow array warnings reported
; in :doc note-2-7-bug-fixes.)

; If the old car is equal to x, then we put the old pointer back into the
; car of the 'acl2-array property rather than the new pointer.
; This has the good effect of preserving the validity of any old
; copies of the array.  It is clear the code below is correct, since
; we are putting down an equal structure in place of a newly consed up
; one.  But why go out of our way?  Why not just (setf (car old) x)?
; In fact, once upon a time, that is what we did.  But it bit us when
; we tried to prove theorems in a post-:init world.

; When ACL2 is loaded the Common Lisp global constant
; *type-set-binary-+-table* is defined by (defconst & (compress2 ...)).
; It is set to some list, here called ptr1, built by compress2 (which
; contains code analogous to that we are documenting here in
; compress1).  When ptr1 is built it is stored as the car of the
; 'acl2-array property of the array name 'type-set-binary-+-table, because at
; the time ACL2 is loaded, there is no old 'acl2-array property on
; that name.  Suppose we then :init, loading the ACL2 source code into
; the current ACL2 world.  That will execute the same defconst, in
; the acl2-loop-only setting.  Compress2 is called and will build a
; new structure, ptr2 (called x in this code).  Upon finishing, it
; will (according to the code here) find that ptr2 is equal to ptr1
; and will put ptr1 into the car of the 'acl2-array property of
; 'type-set-binary-+-table.  It will return ptr1.  That will become the value
; of the 'const getprop of '*type-set-binary-+-table* in the
; current-acl2-world.  When that world is installed, we will note that
; a non-virgin name, *type-set-binary-+-table*, is being defconst'd and so
; we will DO NOTHING, leaving ptr1 as the value of the Common Lisp
; global contant *type-set-binary-+-table*.  So, because of the code below,
; all logical copies of this array are represented by ptr1.

; In the old days, compress2 put ptr2 into the car of the 'acl2-array
; property of 'type-set-binary-+-table.  It returned ptr2, which thus became
; the value of the 'const getprop of '*type-set-binary-+-table*.  When
; that world was installed, we noted that a non-virgin name was being
; defconst'd and we DID NOTHING, leaving ptr1 as the value of the
; global constant *type-set-binary-+-table*.  Subsequent references to
; *type-set-binary-+-table* in our type-set code, e.g., as occurred when one
; tried to prove theorems about + after an :init, provoked the
; slow-array-warning.

; The following historical comment no longer applies to
; 'global-enabled-stucture, but it is still relevant to
; 'global-arithmetic-enabled-structure.

; This preservation (eq) of the old array is also crucial to the way
; recompress-global-enabled-structure works.  That function extracts
; the :theory-array from the current global-enabled-structure -- said
; theory-array having been produced by a past call of compress1 and
; hence guaranteed to be sorted etc.  It calls compress1 on it, which
; side-effects the underlying von Neumann array but returns the very
; same (eq) structure.  We then discard that structure, having only
; wanted the side effect!  Before we exploited this, we had to cons up
; a new global-enabled-structure and rebind 'global-enabled-stucture
; in the world.  This had the bad effect of sometimes putting more
; than one binding of that variable.

             (setf (car old)
                   (cond ((equal old-car x) old-car)
                         (t x)))
             (car old))
            (t (set-acl2-array-property name (list x ar max-ar header))
               x)))))

(defthm array1p-cons
  (implies (and (< n
                   (caadr (assoc-keyword :dimensions
                                         (cdr (assoc-eq :header l)))))
                (not (< n 0))
                (integerp n)
                (array1p name l))
           (array1p name (cons (cons n val) l)))
  :hints (("Goal" :in-theory (enable array1p))))

(defun aset1 (name l n val)

  ":Doc-Section Arrays

  set the elements of a 1-dimensional array~/
  ~bv[]
  Example Form:
  (aset1 'delta1 a (+ i k) 27)~/

  General Form:
  (aset1 name alist index val)
  ~ev[]
  where ~c[name] is a symbol, ~c[alist] is a 1-dimensional array named ~c[name],
  ~c[index] is a legal index into ~c[alist], and ~c[val] is an arbitrary object.
  ~l[arrays] for details.  Roughly speaking this function
  ``modifies'' ~c[alist] so that the value associated with ~c[index] is ~c[val].
  More precisely, it returns a new array, ~c[alist'], of the same name and
  dimension as ~c[alist] that, under ~ilc[aref1], is everywhere equal to ~c[alist]
  except at ~c[index] where the result is ~c[val].  That is,
  ~c[(aref1 name alist' i)] is ~c[(aref1 name alist i)] for all legal
  indices ~c[i] except ~c[index], where ~c[(aref1 name alist' i)] is ~c[val].

  In order to ``modify'' ~c[alist], ~c[aset1] ~ilc[cons]es a new pair onto the
  front.  If the length of the resulting alist exceeds the
  ~c[:]~ilc[maximum-length] entry in the array ~il[header], ~c[aset1] compresses the
  array as with ~ilc[compress1].

  It is generally expected that the ``semantic value'' of ~c[name] will be
  ~c[alist] (~pl[arrays]).  This function operates in virtually
  constant time whether this condition is true or not (unless the
  ~ilc[compress1] operation is required).  But the value returned by this
  function cannot be used efficiently by subsequent ~c[aset1] operations
  unless ~c[alist] is the semantic value of ~c[name] when ~c[aset1] is executed.
  Thus, if the condition is not true, ~c[aset1] prints a ~st[slow array]
  warning to the comment window.  ~l[slow-array-warning]."

  #+acl2-loop-only
  (declare (xargs :guard (and (array1p name l)
                              (integerp n)
                              (>= n 0)
                              (< n (car (dimensions name l))))))
  #+acl2-loop-only
  (let ((l (cons (cons n val) l)))
    (cond ((> (length l)
              (maximum-length name l))
           (compress1 name l))
          (t l)))
  #-acl2-loop-only
  (declare (type (unsigned-byte 31) n))
  #-acl2-loop-only
; See comment above (for #+acl2-par) about *acl2-par-arrays-lock*:
; (with-lock
;  *acl2-par-arrays-lock*
  (let ((prop (get-acl2-array-property name)))
    (cond ((eq l (car prop))
           (let* ((ar (cadr prop))
                  (to-go (aref (the (array (unsigned-byte 31) (*))
                                    (caddr prop))
                               0)))
             (declare (type (unsigned-byte 31) to-go)
                      (simple-vector ar))
             (cond ((eql (the (unsigned-byte 31) to-go) 0)
                    (setf (car prop) *invisible-array-mark*)
                    (setf (aref ar n) val)
                    (let* ((header (cadddr prop))
                           (order (array-order header))
                           (length (car (cadr (assoc-keyword
                                               :dimensions
                                               (cdr header)))))
                           (maximum-length
                            (cadr (assoc-keyword
                                   :maximum-length (cdr header))))
                           (default
                             (cadr (assoc-keyword
                                    :default (cdr header))))
                           (x nil)
                           (num 1))
                      (declare (type (unsigned-byte 31) num length))
                      (declare (type (unsigned-byte 31) maximum-length))
                      (cond ((null order)
; Cause same error as in the logic.
                             (return-from aset1
                                          (compress1 name (cons (cons n val)
                                                                l))))
                            ((eq order '>)
                             (do ((i 0 (1+ i)))
                                 ((int= i length))
                                 (declare (type (unsigned-byte 31) i))
                                 (let ((val (svref ar (the (unsigned-byte 31) i))))
                                   (cond ((equal val default) nil)
                                         (t (push (cons i val) x)
                                            (setq num (the (unsigned-byte 31)
                                                           (1+ num))))))))
                            (t
                             (do ((i (1- length) (1- i)))
                                 ((< i 0))
                                 (declare (type (signed-byte 32) i))
                                 (let ((val (svref ar (the (signed-byte 32) i))))
                                   (cond ((equal val default) nil)
                                         (t (push (cons i val) x)
                                            (setq num (the (unsigned-byte 31)
                                                           (1+ num)))))))))
                      (setq x (cons header x))
                      (setf (aref (the (array (unsigned-byte 31) (*))
                                       (caddr prop)) 0)
                            (the (unsigned-byte 31) (- maximum-length num)))
                      (setf (car prop) x)
                      x))
                   (t (let ((x (cons (cons n val) l)))
                        (setf (car prop) *invisible-array-mark*)
                        (setf (svref (the simple-vector ar) n) val)
                        (setf (aref (the (array (unsigned-byte 31) (*))
                                         (caddr prop))
                                    0)
                              (the (unsigned-byte 31) (1- to-go)))
                        (setf (car prop) x)
                        x)))))
          (t (let ((l (cons (cons n val) l)))
               (slow-array-warning 'aset1 name)
               (cond ((> (length l)
                         (maximum-length name l))
                      (compress1 name l))
                     (t l)))))))

(defun aref2 (name l i j)

  ":Doc-Section Arrays

  access the elements of a 2-dimensional array~/
  ~bv[]
  Example Form:
  (aref2 'delta1 a i j)~/

  General Form:
  (aref2 name alist i j)
  ~ev[]
  where ~c[name] is a symbol, ~c[alist] is a 2-dimensional array and ~c[i] and ~c[j]
  are legal indices into ~c[alist].  This function returns the value
  associated with ~c[(i . j)] in ~c[alist], or else the default value of the
  array.  ~l[arrays] for details.

  This function executes in virtually constant time if ~c[alist] is in
  fact the ``semantic value'' associated with ~c[name] (~pl[arrays]).
  When it is not, ~c[aref2] must do a linear search through ~c[alist].  In
  that case the correct answer is returned but a ~st[slow array] comment is
  printed to the comment window.  ~l[slow-array-warning]."

  #+acl2-loop-only
  (declare (xargs :guard (and (array2p name l)
                              (integerp i)
                              (>= i 0)
                              (< i (car (dimensions name l)))
                              (integerp j)
                              (>= j 0)
                              (< j (cadr (dimensions name l))))))
  #+acl2-loop-only
  (let ((x (assoc2 i j l)))
    (cond ((null x) (default name l))
          (t (cdr x))))
  #-acl2-loop-only
  (declare (type (unsigned-byte 31) i j))
  #-acl2-loop-only
  (let ((prop (get-acl2-array-property name)))
    (cond ((eq l (car prop))
           (aref (the (array * (* *)) (car (cdr prop)))
                 i j))
          (t (slow-array-warning 'aref2 name)
             (let ((x (assoc2 i j l)))
               (cond ((null x) (default name l))
                     (t (cdr x))))))))

(defun compress211 (name l i x j default)
  (declare (xargs :guard (and (array2p name l)
                              (integerp x)
                              (integerp i)
                              (integerp j)
                              (<= x j))
                  :measure (nfix (- j x))))
  (cond ((zp (- j x))
         nil)
        (t (let ((pair (assoc2 i x l)))
             (cond ((or (null pair)
                        (equal (cdr pair) default))
                    (compress211 name l i (+ 1 x) j default))
                   (t (cons pair
                            (compress211 name l i (+ 1 x) j default))))))))

(defun compress21 (name l n i j default)
  (declare (xargs :guard (and (array2p name l)
                              (integerp n)
                              (integerp i)
                              (integerp j)
                              (<= n i)
                              (<= 0 j))
                  :measure (nfix (- i n))))

  (cond ((zp (- i n)) nil)
        (t (append (compress211 name l n 0 j default)
                   (compress21 name l (+ n 1) i j default)))))

(defun compress2 (name l)

  ":Doc-Section Arrays

  remove irrelevant pairs from a 2-dimensional array~/
  ~bv[]
  Example Form:
  (compress2 'delta1 a)~/

  General Form:
  (compress2 name alist)
  ~ev[]
  where ~c[name] is a symbol and ~c[alist] is a 2-dimensional array, generally
  named ~c[name].  ~l[arrays] for details.  Logically speaking, this function
  removes irrelevant pairs from ~c[alist], possibly shortening it.  The
  function returns a new array, ~c[alist'], with the same ~ilc[header]
  (including name and dimension) as ~c[alist], that, under ~ilc[aref2], is
  everywhere equal to ~c[alist].  That is, ~c[(aref2 name alist' i j)] is
  ~c[(aref2 name alist i j)], for all legal indices ~c[i] and ~c[j].
  ~c[Alist'] may be shorter than ~c[alist] and the non-irrelevant pairs may
  occur in a different order in ~c[alist'] than in ~c[alist].

  Practically speaking, this function plays an important role in the
  efficient implementation of ~ilc[aref2].  In addition to creating the new
  array, ~c[alist'], ~c[compress2] makes that array the ``semantic value'' of
  ~c[name] and allocates a raw lisp array to ~c[name].  For all legal indices,
  ~c[i] and ~c[j], that raw lisp array contains ~c[(aref2 name alist' i j)] in
  slot ~c[i],~c[j].  Thus, subsequent ~ilc[aref2] operations can be executed in
  virtually constant time provided they are given ~c[name] and the ~c[alist']
  returned by the most recently executed ~c[compress2] or ~ilc[aset2] on ~c[name].
  ~l[arrays]."

  #+acl2-loop-only

; The uses of (the (unsigned-byte 31) ...) below rely on the array2p
; guard, which for example guarantees that each dimension is bounded
; by *maximum-positive-32-bit-integer* and that array indices are
; therefore less than *maximum-positive-32-bit-integer*.  These
; declarations probably only assist efficiency in GCL, but that may be
; the Lisp that benefits most from such fixnum declarations, anyhow.

  (declare (xargs :guard (array2p name l)))
  #+acl2-loop-only
  (cons (header name l)
        (compress21 name l 0
                    (car (dimensions name l))
                    (cadr (dimensions name l))
                    (default name l)))
  #-acl2-loop-only
  (let* ((old (get-acl2-array-property name))
         (header (header name l))
         (dimension1 (car (cadr (assoc-keyword :dimensions (cdr header)))))
         (dimension2 (cadr (cadr (assoc-keyword :dimensions (cdr header)))))
         (maximum-length (cadr (assoc-keyword :maximum-length (cdr header))))
         (default (cadr (assoc-keyword :default (cdr header))))
         old-car
         ar
         in-order)

;  Get an array that is filled with the special mark *invisible-array-mark*.

    (cond ((and old
                (= 2 (array-rank (cadr old)))
                (and (= dimension1 (array-dimension (cadr old) 0))
                     (= dimension2 (array-dimension (cadr old) 1))))
           (setq old-car (car old))
           (setf (car old) *invisible-array-mark*)
           (setq ar (cadr old))
           (let ((ar ar))
             (declare (type (array * (* *)) ar))
             (do ((i (1- dimension1) (1- i))) ((< i 0))
                 (declare (type fixnum i))
                 (do ((j (1- dimension2) (1- j))) ((< j 0))
                     (declare (type fixnum j))
                     (setf (aref ar i j) *invisible-array-mark*)))))
          (t (setq ar
                   (make-array$ (list dimension1 dimension2)
                                :initial-element
                                *invisible-array-mark*))))
    (let ((ar ar))
      (declare (type (array * (* *)) ar))

; Store the value of each pair under its key (unless it is covered by
; an earlier pair with the same key).

      (do ((tl l (cdr tl)))
          ((null tl))
          (let ((index (caar tl)))
            (cond ((eq index :header) nil)
                  ((eq *invisible-array-mark*
                       (aref ar
                             (the fixnum (car index))
                             (the fixnum (cdr index))))
                   (setf (aref ar
                               (the fixnum (car index))
                               (the fixnum (cdr index)))
                         (cdar tl))))))

; Determine whether l is already in normal form (header first,
; strictly ascending keys, no default values, n extra header.)

      (setq in-order t)
      (cond ((eq (caar l) :header)
             (do ((tl (cdr l) (cdr tl)))
                 (nil)
                 (cond ((or (eq (caar tl) :header)
                            (eq (car (cadr tl)) :header))
                        (setq in-order nil)
                        (return nil))
                       ((equal (cdr (car tl)) default)
                        (setq in-order nil)
                        (return nil))
                       ((null (cdr tl)) (return nil))
                       ((or (> (the (unsigned-byte 31) (caaar tl))
                               (the (unsigned-byte 31) (caaadr tl)))
                            (and (= (the (unsigned-byte 31) (caaar tl))
                                    (the (unsigned-byte 31) (caaadr tl)))
                                 (> (the (unsigned-byte 31) (cdaar tl))
                                    (the (unsigned-byte 31) (cdaadr tl)))))
                        (setq in-order nil)
                        (return nil)))))
            (t (setq in-order nil)))
      (let ((x nil) (num 1) max-ar)
        (declare (type (unsigned-byte 31) num))

;  In one pass, set x to the value to be returned, put defaults into the array
;  where the invisible mark still sits, and calculate the length of x.

        (cond (in-order
               (do ((i (1- dimension1) (1- i)))
                   ((< i 0))
                   (declare (type fixnum i))
                   (do ((j (1- dimension2) (1- j)))
                       ((< j 0))
                       (declare (type fixnum j))
                       (let ((val (aref ar i j)))
                         (cond ((eq *invisible-array-mark* val)
                                (setf (aref ar i j) default))
                               (t
                                (setq num (the (unsigned-byte 31)
                                           (1+ num))))))))
               (setq x l))
              (t (do ((i (1- dimension1) (1- i)))
                     ((< i 0))
                     (declare (type fixnum i))
                     (do ((j (1- dimension2) (1- j)))
                         ((< j 0))
                         (declare (type fixnum j))
                         (let ((val (aref ar i j)))
                           (cond ((eq *invisible-array-mark* val)
                                  (setf (aref ar i j) default))
                                 ((equal val default) nil)
                                 (t (push (cons (cons i j) val) x)
                                    (setq num (the (unsigned-byte 31)
                                               (1+ num))))))))
                 (setq x (cons header x))))
        (cond (old (setq max-ar (caddr old))
                   (setf (aref (the (array (unsigned-byte 31) (*)) max-ar)
                               0)
                         (the (unsigned-byte 31)
                          (- maximum-length num))))
              (t (setq max-ar
                       (make-array$ 1
                                    :initial-contents
                                    (list (- maximum-length num))
                                    :element-type
                                    '(unsigned-byte 31)))))
        (cond (old
               (setf (cadr old) ar)
               (setf (cadddr old) header)
               (setf (car old)
                     (cond ((equal old-car x) old-car)
                           (t x)))
               (car old))
              (t
               (set-acl2-array-property name (list x ar max-ar header))
               x))))))

(defthm array2p-cons
  (implies (and (< j (cadr (dimensions name l)))
                (not (< j 0))
                (integerp j)
                (< i (car (dimensions name l)))
                (not (< i 0))
                (integerp i)
                (array2p name l))
           (array2p name (cons (cons (cons i j) val) l)))
  :hints (("Goal" :in-theory (enable array2p))))

(defun aset2 (name l i j val)

  ":Doc-Section Arrays

  set the elements of a 2-dimensional array~/
  ~bv[]
  Example Form:
  (aset2 'delta1 a i j 27)~/

  General Form:
  (aset2 name alist i j val)
  ~ev[]
  where ~c[name] is a symbol, ~c[alist] is a 2-dimensional array named ~c[name],
  ~c[i] and ~c[j] are legal indices into ~c[alist], and ~c[val] is an arbitrary
  object.  ~l[arrays] for details.  Roughly speaking this
  function ``modifies'' ~c[alist] so that the value associated with
  ~c[(i . j)] is ~c[val].  More precisely, it returns a new array,
  ~c[alist'], of the same name and dimension as ~c[alist] that, under
  ~ilc[aref2], is everywhere equal to ~c[alist] except at ~c[(i . j)] where
  the result is ~c[val].  That is, ~c[(aref2 name alist' x y)] is
  ~c[(aref2 name alist x y)] for all legal indices ~c[x] ~c[y] except
  ~c[i] and ~c[j] where ~c[(aref2 name alist' i j)] is ~c[val].

  In order to ``modify'' ~c[alist], ~c[aset2] ~ilc[cons]es a new pair onto the
  front.  If the length of the resulting ~c[alist] exceeds the
  ~c[:]~ilc[maximum-length] entry in the array ~il[header], ~c[aset2] compresses the
  array as with ~ilc[compress2].

  It is generally expected that the ``semantic value'' of ~c[name] will be
  ~c[alist] (~pl[arrays]).  This function operates in virtually
  constant time whether this condition is true or not (unless the
  ~ilc[compress2] operation is required).  But the value returned by this
  function cannot be used efficiently by subsequent ~c[aset2] operations
  unless ~c[alist] is the semantic value of ~c[name] when ~c[aset2] is executed.
  Thus, if the condition is not true, ~c[aset2] prints a ~st[slow array]
  warning to the comment window.  ~l[slow-array-warning]."

  #+acl2-loop-only
  (declare (xargs :guard (and (array2p name l)
                              (integerp i)
                              (>= i 0)
                              (< i (car (dimensions name l)))
                              (integerp j)
                              (>= j 0)
                              (< j (cadr (dimensions name l))))))
  #+acl2-loop-only
  (let ((l (cons (cons (cons i j) val) l)))
    (cond ((> (length l)
              (maximum-length name l))
           (compress2 name l))
          (t l)))
  #-acl2-loop-only
  (declare (type (unsigned-byte 31) i j))
  #-acl2-loop-only
  (let ((prop (get-acl2-array-property name)))
    (cond
     ((eq l (car prop))
      (let* ((ar (car (cdr prop)))
             (to-go (aref (the (array (unsigned-byte 31) (*))
                           (caddr prop))
                          0)))
        (declare (type (unsigned-byte 31) to-go))
        (declare (type (array * (* *)) ar))
        (cond
         ((eql (the (unsigned-byte 31) to-go) 0)
          (setf (car prop) *invisible-array-mark*)
          (setf (aref ar i j) val)
          (let* ((header (cadddr prop))
                 (d1 (car (cadr (assoc-keyword :dimensions (cdr header)))))
                 (d2 (cadr (cadr (assoc-keyword :dimensions (cdr header)))))
                 (maximum-length
                  (cadr (assoc-keyword
                         :maximum-length (cdr header))))
                 (default (cadr (assoc-keyword :default (cdr header))))
                 (x nil)
                 (num 1))
            (declare (type (unsigned-byte 31) num d1 d2 maximum-length))
            (do ((i (1- d1) (1- i)))
                ((< i 0))
                (declare (type fixnum i))
                (do ((j (1- d2) (1- j)))
                    ((< j 0))
                    (declare (type fixnum j))
                    (let ((val (aref ar
                                     (the fixnum i)
                                     (the fixnum j))))
                      (cond ((equal val default) nil)
                            (t (push (cons (cons i j) val) x)
                               (setq num (the (unsigned-byte 31)
                                          (1+ num))))))))
            (setq x (cons header x))
            (setf (aref (the (array (unsigned-byte 31) (*))
                         (caddr prop))
                        0)
                  (the (unsigned-byte 31) (- maximum-length num)))
            (setf (car prop) x)
            x))
         (t (let ((x (cons (cons (cons i j) val) l)))
              (setf (car prop) *invisible-array-mark*)
              (setf (aref ar i j) val)
              (setf (aref (the (array (unsigned-byte 31) (*))
                           (caddr prop))
                          0)
                    (the (unsigned-byte 31) (1- to-go)))
              (setf (car prop) x)
              x)))))
     (t (let ((l (cons (cons (cons i j) val) l)))
          (slow-array-warning 'aset2 name)
          (cond ((> (length l)
                    (maximum-length name l))
                 (compress2 name l))
                (t l)))))))

(defun flush-compress (name)

  ":Doc-Section Arrays

  flush the under-the-hood array for the given name~/
  ~bv[]
  Example Form:
  (flush-compress 'my-array)~/

  General Form:
  (flush-compress name)
  ~ev[]
  where ~c[name] is a symbol.

  Recall that ~c[(compress1 nm alist)] associates an under-the-hood raw Lisp
  one-dimensional array of name ~c[nm] with the given association list,
  ~c[alist], while ~c[(compress2 nm alist)] is the analogous function for
  two-dimensional arrays; ~pl[compress1] and ~pl[compress2].  The only purpose
  of ~c[flush-compress], which always returns ~c[nil], is to remove the
  association of any under-the-hood array with the given name, thus eliminating
  slow array accesses (~pl[slow-array-warning]).  It is not necessary if the
  return values of ~ilc[compress1] and ~ilc[compress2] are always used as the
  ``current'' copy of the named array, and thus ~c[flush-compress] should
  rarely, if ever, be needed in user applications.

  Nevertheless, we provide the following contrived example to show how
  ~c[flush-compress] can be used to good effect.  Comments have been added to
  this log to provide explanation.
  ~bv[]
  ACL2 !>(assign a (compress1 'demo
                              '((:header :dimensions (5)
                                         :maximum-length 15
                                         :default uninitialized
                                         :name demo)
                                (0 . zero)
                                (1 . one))))
   ((:HEADER :DIMENSIONS (5)
             :MAXIMUM-LENGTH
             15 :DEFAULT UNINITIALIZED :NAME DEMO)
    (0 . ZERO)
    (1 . ONE))
  ACL2 !>(aref1 'demo (@ a) 0)
  ZERO
  ; As expected, the above evaluation did not cause a slow array warning.  Now
  ; we associate a different under-the-hood array with the name 'demo.
  ACL2 !>(compress1 'demo
                    '((:header :dimensions (5)
                               :maximum-length 15
                               :default uninitialized
                               :name demo)
                      (0 . zero)))
  ((:HEADER :DIMENSIONS (5)
            :MAXIMUM-LENGTH
            15 :DEFAULT UNINITIALIZED :NAME DEMO)
   (0 . ZERO))
  ; The following array access produces a slow array warning because (@ a) is
  ; no longer associated under-the-hood with the array name 'demo.
  ACL2 !>(aref1 'demo (@ a) 0)


  **********************************************************
  Slow Array Access!  A call of AREF1 on an array named
  DEMO is being executed slowly.  See :DOC slow-array-warning
  **********************************************************

  ZERO
  ; Now we associate under-the-hood, with array name 'demo, an alist equal to
  ; (@ a).
  ACL2 !>(compress1 'demo
                    '((:header :dimensions (5)
                               :maximum-length 15
                               :default uninitialized
                               :name demo)
                      (0 . zero)
                      (1 . one)))
  ((:HEADER :DIMENSIONS (5)
            :MAXIMUM-LENGTH
            15 :DEFAULT UNINITIALIZED :NAME DEMO)
   (0 . ZERO)
   (1 . ONE))
  ; The following array access is still slow, because the under-the-hood array
  ; is merely associated with a copy of (@ a), not with the actual object
  ; (@ a).
  ACL2 !>(aref1 'demo (@ a) 0)


  **********************************************************
  Slow Array Access!  A call of AREF1 on an array named
  DEMO is being executed slowly.  See :DOC slow-array-warning
  **********************************************************

  ZERO
  ; So we might try to fix the problem by recompressing. But this doesn't
  ; work.  It would work, by the way, if we re-assign a:
  ; (assign a (compress1 'demo (@ a))).  That is why we usually will not need
  ; flush-compress.
  ACL2 !>(compress1 'demo (@ a))
  ((:HEADER :DIMENSIONS (5)
            :MAXIMUM-LENGTH
            15 :DEFAULT UNINITIALIZED :NAME DEMO)
   (0 . ZERO)
   (1 . ONE))
  ACL2 !>(aref1 'demo (@ a) 0)


  **********************************************************
  Slow Array Access!  A call of AREF1 on an array named
  DEMO is being executed slowly.  See :DOC slow-array-warning
  **********************************************************

  ZERO
  ; Finally, we eliminate the warning by calling flush-compress before we call
  ; compress1.  The call of flush-compress removes any under-the-hood
  ; association of an array with the name 'demo.  Then the subsequent call of
  ; compress1 associates the object (@ a) with that name.  (Technical point:
  ; compress1 always associates the indicated name with the value that it
  ; returns.  in this case, what compress1 returns is (@ a), because (@ a) is
  ; already, logically speaking, a compressed array1p (starts with a :header
  ; and the natural number keys are ordered).
  ACL2 !>(flush-compress 'demo)
  NIL
  ACL2 !>(compress1 'demo (@ a))
  ((:HEADER :DIMENSIONS (5)
            :MAXIMUM-LENGTH
            15 :DEFAULT UNINITIALIZED :NAME DEMO)
   (0 . ZERO)
   (1 . ONE))
  ACL2 !>(aref1 'demo (@ a) 0)
  ZERO
  ACL2 !>
  ~ev[]"

  (declare (xargs :guard t))
  #+acl2-loop-only
  (declare (ignore name))
  #+acl2-loop-only
  nil
  #-acl2-loop-only
  (set-acl2-array-property name nil))

; MULTIPLE VALUE returns, done our way, not Common Lisp's way.

; We implement an efficient mechanism for returning a multiple value,
; with an applicative semantics.  Formally, the macro mv is just the
; same as ``list''; one can use it to return a list of arbitrary
; objects.  However, the translator for ACL2 checks that mv is in fact
; only used to return values to mv-let, a special form of let which
; picks out the members of a list but does not hold on to the cdrs of
; the list.  Because mv-let does not hold on to cdrs, we are able to
; implement mv so that the list is never actually consed up.  Instead,
; the elements of the list are passed to mv-let in global locations.

; *number-of-return-values* may be increased (but not reduced) to be
; as high as required to increase the allowed number of ACL2 return
; values.  However, if it is increased, the entire ACL2 system must be
; recompiled.  Currently, the first 10 locations are handled specially
; in releases of AKCL past 206.

#-(or acl2-loop-only acl2-mv-as-values)
(progn

(defparameter *return-values*
  (let (ans)
    (do ((i *number-of-return-values* (1- i))) ((= i 0))
        (push (intern (format nil "*return-value-~a*" i))
              ans))
    ans))

(defmacro declare-return-values ()
  (cons 'progn (declare-return-values1)))

(defun declare-return-values1 ()
  (mapcar #'(lambda (v) `(defvar ,v))
          *return-values*))

(eval-when
 #-cltl2
 (load eval compile)
 #+cltl2
 (:load-toplevel :execute :compile-toplevel)
 (declare-return-values))

(defun in-akcl-with-mv-set-and-ref ()
  (member :akcl-set-mv *features*))

(defconstant *akcl-mv-ref-and-set-inclusive-upper-bound* 9)

(defmacro special-location (i)
  (cond ((or (not (integerp i))
             (< i 1))
         (acl2::interface-er
          "Macro calls of special-location must have an explicit ~
           positive integer argument, which is not the case with ~x0." i))
        ((> i *number-of-return-values*)
         (acl2::interface-er "Not enough built-in return values."))
        (t (nth (1- i) *return-values*))))

(defmacro set-mv (i v)
  (cond ((or (not (integerp i))
             (< i 1))
         (interface-er
          "The first argument to a macro call of set-mv must be ~
           an explicit positive integer, but that is not the case ~
           with ~A." i))
        #+akcl
        ((and (in-akcl-with-mv-set-and-ref)
              (<= i *akcl-mv-ref-and-set-inclusive-upper-bound*))
         `(system::set-mv ,i ,v))
        (t `(setf (special-location ,i) ,v))))

(defmacro mv-ref (i)
  (cond ((or (not (integerp i))
             (< i 1))
         (interface-er
          "The argument to macro calls of mv-ref must be an ~
           explicit positive integer, but that is not the case with ~x0." i))
        #+akcl
        ((and (in-akcl-with-mv-set-and-ref)
              (<= i *akcl-mv-ref-and-set-inclusive-upper-bound*))
         `(system::mv-ref ,i))
        (t `(special-location ,i))))

(defun mv-refs-fn (i)
  (let (ans)
    (do ((k i (1- k)))
        ((= k 0))
        (push `(mv-ref ,k)
              ans))
    ans))

(defmacro mv-refs (i)
  (cond
   ((and (natp i) (< i *number-of-return-values*)) ; optimization
    (cons 'list (mv-refs-fn i)))
   (t
    `(case ,i
       ,@(let (ans)
           (do ((j *number-of-return-values* (1- j)))
               ((= j 0))
               (push
                `(,j (list ,@(mv-refs-fn j)))
                ans))
           ans)
       (otherwise (interface-er "Not enough return values."))))))

)

(defun cdrn (x i)
  (declare (xargs :guard (and (integerp i)
                              (<= 0 i))))
  (cond ((zp i) x)
        (t (cdrn (list 'cdr x) (- i 1)))))

(defun mv-nth (n l)

  ":Doc-Section ACL2::ACL2-built-ins

  the mv-nth element (zero-based) of a list~/

  ~c[(Mv-nth n l)] is the ~c[n]th element of ~c[l], zero-based.  If ~c[n] is
  greater than or equal to the length of ~c[l], then ~c[mv-nth] returns
  ~c[nil].~/

  ~c[(Mv-nth n l)] has a ~il[guard] that ~c[n] is a non-negative integer.

  ~c[Mv-nth] is equivalent to the Common Lisp function ~ilc[nth] (although
  without the guard condition that the list is a ~ilc[true-listp]), but is used
  by ACL2 to access the nth value returned by a multiply valued expression.
  For example, the following are logically equivalent:
  ~bv[]
  (mv-let (erp val state)
          (read-object ch state)
          (value (list erp val)))
  ~ev[]
  and
  ~bv[]
  (let ((erp (mv-nth 0 (read-object ch state)))
        (val (mv-nth 1 (read-object ch state)))
        (state (mv-nth 2 (read-object ch state))))
    (value (list erp val)))
  ~ev[]

  To see the ACL2 definition of ~c[mv-nth], ~pl[pf].

  If ~c[EXPR] is an expression that is multiply valued, then the form
  ~c[(mv-nth n EXPR)] is illegal both in definitions and in forms submitted
  directly to the ACL2 loop.  Indeed, ~c[EXPR] cannot be passed as an argument
  to any function (~c[mv-nth] or otherwise) in such an evaluation context.  The
  reason is that ACL2 code compiled for execution does not actually create a
  list for multiple value return; for example, the ~c[read-object] call above
  logically returns a list of length 3, but when evaluated, it instead stores
  its three returned values without constructing a list.  In such cases you can
  use ~c[mv-nth] to access the corresponding list by using ~c[mv-list], writing
  ~c[(mv-nth n (mv-list k EXPR))] for suitable ~c[k], where ~c[mv-list]
  converts a multiple value result into the corresponding list;
  ~pl[mv-list].~/"

  (declare (xargs :guard (and (integerp n)
                              (>= n 0))))
  (if (atom l)
      nil
    (if (zp n)
        (car l)
      (mv-nth (- n 1) (cdr l)))))

(defun make-mv-nths (args call i)
  (declare (xargs :guard (and (true-listp args)
                              (integerp i))))
  (cond ((endp args) nil)
        (t (cons (list (car args) (list 'mv-nth i call))
                 (make-mv-nths (cdr args) call (+ i 1))))))

#-(or acl2-loop-only acl2-mv-as-values)
(defun mv-bindings (lst)

; Gensym a var for every element of lst except the last and pair
; that var with its element in a doublet.  Return the list of doublets.

  (cond ((null (cdr lst)) nil)
        (t (cons (list (gensym) (car lst))
                 (mv-bindings (cdr lst))))))

#-(or acl2-loop-only acl2-mv-as-values)
(defun mv-set-mvs (bindings i)
  (cond ((null bindings) nil)
        (t (cons `(set-mv ,i ,(caar bindings))
                 (mv-set-mvs (cdr bindings) (1+ i))))))

(defmacro mv (&rest l)

  ":Doc-Section ACL2::ACL2-built-ins

  returning a multiple value~/

  ~c[Mv] is the mechanism provided by ACL2 for returning two or more values.
  Logically, ~c[(mv x1 x2 ... xn)] is the same as ~c[(list x1 x2 ... xn)], a
  list of the indicated values.  However, ACL2 avoids the cost of building this
  list structure, with the cost that ~c[mv] may only be used in a certain style
  in definitions: if a function ever returns using ~c[mv] (either directly, or
  by calling another function that returns a multiple value), then this
  function must always return the same number of values.

  For more explanation of the multiple value mechanism,
  ~pl[mv-let].  Also ~pl[mv-list] for a way to convert a multiple value into an
  ordinary list.~/

  ACL2 does not support the Common Lisp construct ~c[values], whose logical
  meaning seems difficult to characterize.  ~c[Mv] is the ACL2 analogue of that
  construct.~/"

  (declare (xargs :guard (>= (length l) 2)))

  #+acl2-loop-only
  (cons 'list l)
  #+(and (not acl2-loop-only) acl2-mv-as-values)
  (return-from mv (cons 'values l))
  #+(and (not acl2-loop-only) (not acl2-mv-as-values))

; In an earlier version of the mv macro, we had a terrible bug.
; (mv a b ... z) expanded to

; (LET ((#:G1 a))
;   (SET-MV 1 b)
;   ...
;   (SET-MV k z)
;   (SETQ *MOST-RECENT-MULTIPLICITY* 3)
;   #:G1)

; Note that if the evaluation of z uses a multiple value then it overwrites the
; earlier SET-MV.  Now this expansion is safe if there are only two values
; because the only SET-MV is done after the second value is computed.  If there
; are three or more value forms, then this expansion is also safe if all but
; the first two are atomic.  For example, (mv & & (killer)) is unsafe because
; (killer) may overwrite the SET-MV, but (mv & & STATE) is safe because the
; evaluation of an atomic form is guaranteed not to overwrite SET-MV settings.
; In general, all forms after the second must be atomic for the above expansion
; to be used.

; Suppose we are using GCL.  In some cases we can avoid boxing fixnums that are
; the first value returned, by making the following two optimizations.  First,
; we insert a declaration when we see (mv (the type expr) ...) where type is
; contained in the set of fixnums.  Our second optimization is for the case
; of (mv v ...) where v is an atom, when we avoid let-binding v.  To see why
; this second optimization is helpful, consider the following definition.

; (defun foo (x y)
;   (declare (type (signed-byte 30) x))
;   (the-mv 2
;           (signed-byte 30)
;           (mv x (cons y y))))

; If we submit this definition to ACL2, the proclaim-form mechanism arranges
; for the following declaim form to be evaluated.

; (DECLAIM (FTYPE (FUNCTION ((SIGNED-BYTE 30) T)
;                           (VALUES (SIGNED-BYTE 30)))
;                 FOO))

; Now let us exit the ACL2 loop and then, in raw Lisp, call disassemble on the
; above defun.  Without our second optimization there is boxing: a call of
; CMPmake_fixnum in the output of disassemble.  That happens because (mv x
; (cons y y)) macroexpands to something like this:

; (LET ((#:G5579 X)) (SET-MV 1 (CONS Y Y)) #:G5579)

; With the second optimization, however, we get this macroexpansion instead:

; (LET () (SET-MV 1 (CONS Y Y)) X)

; GCL can see that the fixnum declaration for x applies at the occurrence
; above, but fails (as of this writing, using GCL 2.6.8) to recognize that the
; above gensym is a fixnum.

  (cond ((atom-listp (cddr l))

; We use the old expansion because it is safe and more efficient.

         (let* ((v (if (atom (car l))
                       (car l)
                     (gensym)))
                (bindings (if (atom (car l))
                              nil
                            `((,v ,(car l))))))
           `(let ,bindings

; See comment above regarding boxing fixnums.

              ,@(and (consp (car l))
                     (let ((output (macroexpand-till (car l) 'the)))
                       (cond ((and (consp output)
                                   (eq 'the (car output)))
                              `((declare (type ,(cadr output) ,v))))
                             (t nil))))
              ,@(let (ans)
                  (do ((tl (cdr l) (cdr tl))
                       (i 1 (1+ i)))
                      ((null tl))
                      (push `(set-mv ,i ,(car tl))
                            ans))
                  (nreverse ans))
              ,v)))
        (t

; We expand (mv a b ... y z) to
; (LET ((#:G1 a)
;       (#:G2 b)
;       ...
;       (#:Gk y))
;  (SET-MV k z)
;  (SET-MV 1 #:G2)
;  ...
;  (SET-MV k-1 #:Gk)
;  #:G1)

         (let* ((cdr-bindings (mv-bindings (cdr l)))
                (v (if (atom (car l))
                       (car l)
                     (gensym)))
                (bindings (if (atom (car l))
                              cdr-bindings
                            (cons (list v (car l))
                                  cdr-bindings))))
           `(let ,bindings

; See comment above regarding boxing fixnums.

              ,@(and (consp (car l))
                     (let ((output (macroexpand-till (car l) 'the)))
                       (cond ((and (consp output)
                                   (eq 'the (car output)))
                              `((declare (type ,(cadr output) ,v))))
                             (t nil))))
              (set-mv ,(1- (length l)) ,(car (last l)))
              ,@(mv-set-mvs cdr-bindings 1)
              ,v)))))

(defmacro mv? (&rest l)

; Why not simply extend mv and mv-let to handle single values?  The reason is
; that there seem to be problems with defining (mv x) to be (list x) and other
; problems with defining (mv x) to be x.

; To see potential problems with defining (mv x) = (list x), consider this
; form:

; (mv-let (x)
;         (f y)
;         (g x y))

; We presumably want it to expand as follows.

; (let ((x (f y)))
;   (g x y))

; But suppose (f y) is defined to be (mv (h y)).  Then the above mv-let would
; instead have to expand to something like this:

; (let ((x (mv-nth 0 (f y)))) ; or, car instead of (mv-nth 0 ...)
;   (g x y))

; So in order to extend mv and mv-let to handle single values, we'd need to
; look carefully at the rather subtle mv and mv-nth code.  It seems quite
; possible that some show-stopping reason would emerge why this approach can't
; work out, or if it does then it might be easy to make mistakes in the
; implementation.  Note that we'd need to consider both the cases of
; #+acl2-mv-as-values and #acl2-mv-as-values.

; In a way it seems more natural anyhow that (mv x) is just x, since we don't
; wrap single-valued returns into a list.  But that would ruin our simple story
; that mv is logically just list, instead giving us:

; (mv x) = x
; (mv x1 x2 ...) = (list x1 x2 ...)

; Thus it seems safest, and potentially less confusing to users, to introduce
; mv? and mv?-let to be used in cases that single-valued returns are to be
; allowed (presumably in generated code).

  ":Doc-Section ACL2::ACL2-built-ins

  return one or more values~/

  ~c[Mv?] is designed to work with ~c[mv?-let], generalizing how ~ilc[mv] works
  with ~ilc[mv-let] by allowing the binding of a single variable.  For example,
  the following form is legal.
  ~bv[]
  (mv?-let (y)
           (mv? (f x))
           (declare (type integer y))
           (g x y z))
  ~ev[]
  The expression above is equivalent to the following expression, because
  ~c[(mv? form)] expands to ~c[form] for any expression, ~c[form].
  ~bv[]
  (let ((y (f x)))
    (declare (type integer y))
    (g x y z))
  ~ev[]

  Logically, ~c[(mv? x)] is the same as ~c[x], while ~c[(mv? v1 v2 ...)] is the
  same as ~c[(list v1 v2 ...)].  Also ~pl[mv] and ~pl[mv?-let].~/~/"

  (declare (xargs :guard l))
  (cond ((null (cdr l))
         (car l))
        (t `(mv ,@l))))

(defmacro mv-let (&rest rst)

; Warning: If the final logical form of a translated mv-let is
; changed, be sure to reconsider translated-acl2-unwind-protectp.

  ":Doc-Section ACL2::ACL2-built-ins

  calling multi-valued ACL2 functions~/
  ~bv[]
  Example Form:
  (mv-let (x y z)              ; local variables
          (mv 1 2 3)           ; multi-valued expression
          (declare (ignore y)) ; optional declarations
          (cons x z))          ; body
  ~ev[]
  The form above binds the three ``local variables,'' ~c[x], ~c[y], and ~c[z],
  to the three results returned by the multi-valued expression and
  then evaluates the body.  The result is ~c['(1 . 3)].  The second local,
  ~c[y], is ~il[declare]d ~c[ignore]d.  The multi-valued expression can be any ACL2
  expression that returns ~c[k] results, where ~c[k] is the number of local
  variables listed.  Often however it is simply the application of a
  ~c[k]-valued function.  ~c[Mv-let] is the standard way to invoke a
  multi-valued function when the caller must manipulate the vector of
  results returned.~/
  ~bv[]
  General Form:
  (mv-let (var1 ... vark)
          term
          body)
  or
  (mv-let (var1 ... vark)
          term
          (declare ...) ... (declare ...)
          body)
  ~ev[]
  where the ~c[vari] are distinct variables, ~c[term] is a term that returns
  ~c[k] results and mentions only variables bound in the environment containing
  the ~c[mv-let] expression, and ~c[body] is a term mentioning only the
  ~c[vari] and variables bound in the environment containing the ~c[mv-let].
  Each ~c[vari] must occur in ~c[body] unless it is ~il[declare]d ~c[ignore]d
  or ~c[ignorable] in one of the optional ~ilc[declare] forms, unless this
  requirement is turned off; ~pl[set-ignore-ok].  The value of the ~c[mv-let]
  term is the result of evaluating ~c[body] in an environment in which the
  ~c[vari] are bound, in order, to the ~c[k] results obtained by evaluating
  ~c[term] in the environment containing the ~c[mv-let].

  Here is an extended example that illustrates both the definition of
  a multi-valued function and the use of ~c[mv-let] to call it.  Consider
  a simple binary tree whose interior nodes are ~ilc[cons]es and whose
  leaves are non-~ilc[cons]es.  Suppose we often need to know the number, ~c[n],
  of interior nodes of such a tree; the list, ~c[syms], of symbols that
  occur as leaves; and the list, ~c[ints], of integers that occur as
  leaves.  (Observe that there may be leaves that are neither symbols
  nor integers.)  Using a multi-valued function we can collect all
  three results in one pass.

  Here is the first of two definitions of the desired function.  This
  definition is ``primitive recursive'' in that it has only one
  argument and that argument is reduced in size on every recursion.
  ~bv[]
  (defun count-and-collect (x)

  ; We return three results, (mv n syms ints) as described above.

    (cond ((atom x)

  ; X is a leaf.  Thus, there are 0 interior nodes, and depending on
  ; whether x is a symbol, an integer, or something else, we return
  ; the list containing x in as the appropriate result.

           (cond ((symbolp x) (mv 0 (list x) nil))
                 ((integerp x)(mv 0 nil      (list x)))
                 (t           (mv 0 nil      nil))))
          (t

  ; X is an interior node.  First we process the car, binding n1, syms1, and
  ; ints1 to the answers.

             (mv-let (n1 syms1 ints1)
                     (count-and-collect (car x))

  ; Next we process the cdr, binding n2, syms2, and ints2.

                     (mv-let (n2 syms2 ints2)
                             (count-and-collect (car x))

  ; Finally, we compute the answer for x from those obtained for its car
  ; and cdr, remembering to increment the node count by one for x itself.

                             (mv (1+ (+ n1 n2))
                                 (append syms1 syms2)
                                 (append ints1 ints2)))))))
  ~ev[]
  This use of a multiple value to ``do several things at once'' is
  very common in ACL2.  However, the function above is inefficient
  because it ~il[append]s ~c[syms1] to ~c[syms2] and ~c[ints1] to ~c[ints2], copying the
  list structures of ~c[syms1] and ~c[ints1] in the process.  By adding
  ``accumulators'' to the function, we can make the code more
  efficient.
  ~bv[]
  (defun count-and-collect1 (x n syms ints)
    (cond ((atom x)
           (cond ((symbolp x) (mv n (cons x syms) ints))
                 ((integerp x) (mv n syms (cons x ints)))
                 (t (mv n syms ints))))
          (t (mv-let (n2 syms2 ints2)
                     (count-and-collect1 (cdr x) (1+ n) syms ints)
                     (count-and-collect1 (car x) n2 syms2 ints2)))))
  ~ev[]
  We claim that ~c[(count-and-collect x)] returns the same triple of
  results as ~c[(count-and-collect1 x 0 nil nil)].  The reader is urged to
  study this claim until convinced that it is true and that the latter
  method of computing the results is more efficient.  One might try
  proving the theorem
  ~bv[]
  (defthm count-and-collect-theorem
    (equal (count-and-collect1 x 0 nil nil) (count-and-collect x))).
  ~ev[]
  Hint:  the inductive proof requires attacking a more general
  theorem.

  ACL2 does not support the Common Lisp construct
  ~c[multiple-value-bind], whose logical meaning seems difficult to
  characterize.  ~c[Mv-let] is the ACL2 analogue of that construct.
  Also ~pl[mv] and ~pl[mv-list].~/"

  (declare (xargs :guard (and (>= (length rst) 3)
                              (true-listp (car rst))
                              (>= (length (car rst)) 2))))
  #+acl2-loop-only
  (list* 'let
         (make-mv-nths (car rst)
                       (list 'mv-list (length (car rst)) (cadr rst))
                       0)
         (cddr rst))
  #+(and (not acl2-loop-only) acl2-mv-as-values)
  (return-from mv-let (cons 'multiple-value-bind rst))
  #+(and (not acl2-loop-only) (not acl2-mv-as-values))
  (cond ((> (length (car rst)) (+ 1 *number-of-return-values*))
         (interface-er
          "Need more *return-values*.  Increase ~
           *number-of-return-values* and recompile ACL2."))
        (t
         `(let ((,(car (car rst)) ,(cadr rst))
                (,(cadr (car rst)) (mv-ref 1))
                ,@(let (ans)
                    (do ((tl (cddr (car rst)) (cdr tl))
                         (i 2 (1+ i)))
                        ((null tl))
                        (push (list (car tl) `(mv-ref ,i))
                              ans))
                    (nreverse ans)))
            ,@ (cddr rst)))))

(defmacro mv?-let (vars form &rest rst)

; See the comment in mv? for reasons why we do not simply extend mv-let to
; handle single values.

  ":Doc-Section ACL2::ACL2-built-ins

  calling possibly multi-valued ACL2 functions~/

  ~c[Mv?-let] is a macro that extends the macro ~ilc[mv-let] by allowing a
  single variable to be bound.  Thus, the syntax is the same as that of
  ~ilc[mv-let] except that ~c[mv?-let] is permitted to bind a single variable
  to a form that produces a single value.  The macros ~c[mv?-let] and ~ilc[mv?]
  are provided to facilitate the writing of macros that traffic in expressions
  that could return one or more (multiple) values.

  For example, the form
  ~bv[]
  (mv?-let (y)
           (f x)
           (declare (type integer y))
           (g x y z))
  ~ev[]
  is equivalent to the following form.
  ~bv[]
  (let ((y (f x)))
    (declare (type integer y))
    (g x y z))
  ~ev[]~/

  Calls of ~c[mv?-let] and of ~ilc[mv-let] are equivalent when the first
  argument contains at least two variables; ~pl[mv-let] for documentation.  In
  the case of binding a single variable, the general form is
  ~bv[]
  (mv?-let (var)
           term
           (declare ...) ... (declare ...)
           body)
  ~ev[]
  and this is equivalent to the following form (~pl[let]).
  ~bv[]
  (let ((var term))
    (declare ...) ... (declare ...)
    body)
  ~ev[]

  Also ~pl[mv?].~/"

  (declare (xargs :guard (and (true-listp vars)
                              vars)))
  (cond ((null (cdr vars))
         `(let ((,(car vars) ,form))
            ,@rst))
        (t `(mv-let ,vars ,form ,@rst))))

#+acl2-loop-only
(defun mv-list (input-arity x)

  ":Doc-Section ACL2::ACL2-built-ins

  converting multiple-valued result to a single-valued list~/
  ~bv[]
  Example Forms:
  ; Returns the list (3 4):
  (mv-list 2 (mv 3 4))

  ; Returns a list containing the three values returned by var-fn-count:
  (mv-list 3 (var-fn-count '(cons (binary-+ x y) z) nil))~/

  General form:
  (mv-list n term)
  ~ev[]

  Logically, ~c[(mv-list n term)] is just ~c[term]; that is, in the logic
  ~c[mv-list] simply returns its second argument.  However, the evaluation of a
  call of ~c[mv-list] on explicit values always results in a single value,
  which is a (null-terminated) list.  For evaluation, the term ~c[n] above (the
  first argument to an ~c[mv-list] call) must ``essentially'' (see below) be an
  integer not less than 2, where that integer is the number of values returned
  by the evaluation of ~c[term] (the second argument to that ~c[mv-list] call).

  We say ``essentially'' above because it suffices that the translation of
  ~c[n] to a term (~pl[trans]) be of the form ~c[(quote k)], where ~c[k] is an
  integer greater than 1.  So for example, if ~c[term] above returns three
  values, then ~c[n] can be the expression ~c[3], or ~c[(quote 3)], or even
  ~c[(mac 3)] if ~c[mac] is a macro defined by ~c[(defmacro mac (x) x)].  But
  ~c[n] cannot be ~c[(+ 1 2)], because even though that expression evaluates to
  ~c[3], nevertheless it translates to ~c[(binary-+ '1 '2)], not to
  ~c[(quote 3)].

  ~c[Mv-list] is the ACL2 analogue of the Common Lisp construct
  ~c[multiple-value-list].

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard t
                  :mode :logic)
           (ignore input-arity))
  x)

#+(and (not acl2-loop-only) acl2-mv-as-values)
(defmacro mv-list (input-arity x)
  (declare (ignore input-arity))
  `(multiple-value-list ,x))

#+(and (not acl2-loop-only) (not acl2-mv-as-values))
(defmacro mv-list (input-arity x)
  `(cons ,x (mv-refs (1- ,input-arity))))

(deflabel state
  :doc
  ":Doc-Section ACL2::Programming

  the von Neumannesque ACL2 state object~/

  Note: If you are interested in programming with state,
  ~pl[programming-with-state] after reading the information below.~/

  The ACL2 state object is used extensively in programming the ACL2
  system, and has been used in other ACL2 programs as well.  However,
  most users, especially those interested in specification and
  verification (as opposed to programming ~i[per se]), need not be
  aware of the role of the state object in ACL2, and will not write
  functions that use it explicitly.  We say more about this point at
  the end of this documentation topic.

  The ACL2 state object is an example of a single-threaded object or
  ~il[stobj].  ACL2 allows the user to define new single-threaded objects.
  Generally, ACL2 may need to access the ACL2 state but should not
  (cannot) change it except via a certain set of approved functions
  such as ~ilc[defun] and ~ilc[defthm].  If you need a state-like object
  to which you have complete rights, you may want a ~il[stobj].

  Key to the idea of our ~c[state] is the notion of single-threadedness.
  For an explanation, ~pl[stobj].  The upshot of it is that ~c[state]
  is a variable symbol with severe restrictions on its use, so that it
  can be passed into only certain functions in certain slots, and must be
  returned by those functions that ``modify'' it.  Henceforth, we do not
  discuss single-threaded objects in general (which the user can introduce
  with ~ilc[defstobj] and ~ilc[defabsstobj]) but one in particular, namely
  ACL2's ~c[state] object.

  The ~i[global table] is perhaps the most visible portion of the state
  object.  Using the interface functions ~c[@] and ~c[assign], a user
  may bind global variables to the results of function evaluations
  (much as an Nqthm user exploits the Nqthm utility ~c[r-loop]).
  ~l[@], and ~pl[assign].

  ACL2 supports several facilities of a truly von Neumannesque state
  machine character, including file ~il[io] and global variables.
  Logically speaking, the state is a true list of the 14 components
  described below.  There is a ``current'' state object at the
  top-level of the ACL2 ~il[command] loop.  This object is understood to be
  the value of what would otherwise be the free variable ~c[state]
  appearing in top-level input.  When any ~il[command] returns a state
  object as one of its values, that object becomes the new current
  state.  But ACL2 provides von Neumann style speed for state
  operations by maintaining only one physical (as opposed to logical)
  state object.  Operations on the state are in fact destructive.
  This implementation does not violate the applicative semantics
  because we enforce certain draconian syntactic rules regarding the
  use of state objects.  For example, one cannot ``hold on'' to an old
  state, access the components of a state arbitrarily, or ``modify'' a
  state object without passing it on to subsequent state-sensitive
  functions.

  Every routine that uses the state facilities (e.g. does ~il[io], or calls
  a routine that does ~il[io]), must be passed a ``state object.'' And a
  routine must return a state object if the routine modifies the state
  in any way.  Rigid syntactic rules governing the use of state
  objects are enforced by the function ~c[translate], through which all
  ACL2 user input first passes.  State objects can only be ``held'' in
  the formal parameter ~c[state], never in any other formal parameter and
  never in any structure (excepting a multiple-value return list
  field which is always a state object).  State objects can only be
  accessed with the primitives we specifically permit.  Thus, for
  example, one cannot ask, in code to be executed, for the length of
  ~c[state] or the ~ilc[car] of ~c[state].  In the statement and proof of theorems,
  there are no syntactic rules prohibiting arbitrary treatment of
  state objects.

  Logically speaking, a state object is a true list whose members
  are as follows:~bq[]

  ~c[Open-input-channels], an alist with keys that are symbols in
  package ~c[\"ACL2-INPUT-CHANNEL\"].  The value (~ilc[cdr]) of each pair has
  the form ~c[((:header type file-name open-time) . elements)], where
  ~c[type] is one of ~c[:character], ~c[:byte], or ~c[:object] and ~c[elements] is a
  list of things of the corresponding ~c[type], i.e. characters,
  integers of type ~c[(mod 255)], or lisp objects in our theory.
  ~c[File-name] is a string.  ~c[Open-time] is an integer.  ~l[io].

  ~c[Open-output-channels], an alist with keys that are symbols in
  package ~c[\"ACL2-OUTPUT-CHANNEL\"].  The value of a pair has the form
  ~c[((:header type file-name open-time) .  current-contents)].
  ~l[io].

  ~c[Global-table], an alist associating symbols (to be used as ``global
  variables'') with values.  ~l[@], and ~pl[assign].

  ~c[T-stack], a list of arbitrary objects accessed and changed by the
  functions ~c[aref-t-stack] and ~c[aset-t-stack].

  ~c[32-bit-integer-stack], a list of arbitrary 32-bit-integers accessed
  and changed by the functions ~c[aref-32-bit-integer-stack] and
  ~c[aset-32-bit-integer-stack].

  ~c[Big-clock-entry], an integer, that is used logically to bound the
  amount of effort spent to evaluate a quoted form.

  ~c[Idates], a list of dates and times, used to implement the function
  ~c[print-current-idate], which prints the date and time.

  ~c[Acl2-oracle], a list of objects, used for example to implement the
  functions that let ACL2 report how much time was used, but inaccessible to
  the user.  Also ~pl[with-prover-time-limit].

  ~c[File-clock], an integer that is increased on every file opening and
  closing, and on each call of ~ilc[sys-call], and is used to maintain the
  consistency of the ~ilc[io] primitives.

  ~c[Readable-files], an alist whose keys have the form
  ~c[(string type time)], where ~ilc[string] is a file name and ~c[time] is
  an integer.  The value associated with such a key is a list of
  characters, bytes, or objects, according to ~c[type].  The ~c[time] field
  is used in the following way:  when it comes time to open a file for
  input, we will only look for a file of the specified name and ~c[type]
  whose time field is that of ~c[file-clock].  This permits us to have
  a ``probe-file'' aspect to ~c[open-file]: one can ask for a file,
  find it does not exist, but come back later and find that it does
  now exist.

  ~c[Written-files], an alist whose keys have the form
  ~c[(string type time1 time2)], where ~ilc[string] is a file name,
  ~c[type] is one of ~c[:character], ~c[:byte] or ~c[:object], and
  ~c[time1] and ~c[time2] are integers.  ~c[Time1] and ~c[time2]
  correspond to the ~c[file-clock] time at which the channel for the
  file was opened and closed.  This field is write-only; the only
  operation that affects this field is ~c[close-output-channel], which
  ~ilc[cons]es a new entry on the front.

  ~c[Read-files], a list of the form ~c[(string type time1 time2)], where
  ~ilc[string] is a file name and ~c[time1] and ~c[time2] were the times at which
  the file was opened for reading and closed.  This field is write
  only.

  ~c[Writeable-files], an alist whose keys have the form
  ~c[(string type time)].  To open a file for output, we require that
  the name, type, and time be on this list.

  ~c[List-all-package-names-lst], a list of ~c[true-listps].  Roughly
  speaking, the ~ilc[car] of this list is the list of all package names
  known to this Common Lisp right now and the ~ilc[cdr] of this list is
  the value of this ~c[state] variable after you look at its ~ilc[car].
  The function, ~c[list-all-package-names], which takes the state as an
  argument, returns the ~ilc[car] and ~ilc[cdr]s the list (returning a new state
  too).  This essentially gives ACL2 access to what is provided by
  CLTL's ~c[list-all-packages].  ~ilc[Defpkg] uses this feature to ensure that
  the about-to-be-created package is new in this lisp.  Thus, for
  example, in ~c[akcl] it is impossible to create the package
  ~c[\"COMPILER\"] with ~ilc[defpkg] because it is on the list, while in Lucid
  that package name is not initially on the list.

  ~c[User-stobj-alist], an alist which associates user-defined single-threaded
  objects (~pl[stobj]) with their values.
  ~eq[]

  We recommend avoiding the use of the state object when writing ACL2
  code intended to be used as a formal model of some system, for
  several reasons.  First, the state object is complicated and
  contains many components that are oriented toward implementation and
  are likely to be irrelevant to the model in question.  Second, there
  is currently not much support for reasoning about ACL2 functions
  that manipulate the state object, beyond their logical definitions.
  Third, the documentation about state is not as complete as one might wish.

  User-defined single-threaded objects offer the speed of ~c[state] while
  giving the user complete access to all the fields.  ~l[stobj].

  Again, if you are interested in programming with state
  ~pl[programming-with-state].~/

  :cited-by Other")

(defdoc programming-with-state
  ":Doc-Section state

  programming using the von Neumannesque ACL2 ~il[state] object~/

  This ~il[documentation] section introduces some common techniques for
  programming using the ACL2 state object.  A prerequisite is thus a basic
  understanding of that object; ~pl[state].  We hope this section is useful,
  and we invite suggestions for improvements and additions.

  A supplement to this section is the ACL2 source code, which uses most (and
  probably all) of the techniques discussed here.  That code is thus a source
  of many examples, which can serve as ``templates'' to guide one's own
  programming with state.

  Recall that ``ACL2'' stands for ``A Computational Logic for Applicative
  Common Lisp''.  In particular, the language is applicative: there are no
  global variables or side effects.  For many purposes this does not feel
  restrictive; for example, an ACL2 user who is programming in raw Lisp may
  well be more comfortable coding a factorial function applicatively, using
  recursion, rather than using iteration with repeated assignment to the same
  variable.

  However, there are situations that call for reading or modifying the system
  state, such as performing input and output, signalling errors, saving
  information from one computation for use in a later one, or reading and
  updating system-level or environmental data.  This section provides an
  introductory guide for writing functions that traffic in state.  We emphasize
  that this guide is intended as an introduction; more complete documentation
  may often be found by following links to documentation of individual
  utilities, and again, more examples may be found by searching the ACL2 source
  code for uses of the functions and macros mentioned below.  The rest of this
  section is organized as follows.
  ~bf[]
  ~sc[Enabling programming with state]
  ~sc[State globals and the ACL2 logical world]
  ~sc[A remark on guards]
  ~sc[Errors and error triples]
  ~sc[Sequential programming]
  ~sc[Binding variables using error triples]
  ~sc[Binding state global variables]
  ~sc[Input and output]
  ~sc[Timings]
  ~sc[Environment and system]
  ~sc[Remarks on events and LD]
  ~sc[Advanced topics]
  ~ef[]~/

  ~sc[Enabling programming with state]

  In order to submit a definition that takes ~ilc[state] as a formal parameter,
  you must either declare ~c[state] as a ~c[:]~ilc[stobj] (~pl[xargs]) or first
  evaluate the following form at the top level: ~c[(set-state-ok t)].

  Consider for example the following trivial definition.
  ~bv[]
  (defun foo (state)
    (mv 3 state))
  ~ev[]
  If you submit the above definition in a fresh ACL2 session, you will get this
  error message.
  ~bv[]
    ACL2 Error in ( DEFUN FOO ...):  The variable symbol STATE should not
    be used as a formal parameter of a defined function unless you are
    aware of its unusual status and the restrictions enforced on its use.
    See :DOC set-state-ok.
  ~ev[]
  If first you evaluate ~c[(set-state-ok t)], you can admit the above
  definition.  Alternatively, you can declare ~c[state] as a ~c[:]~ilc[stobj],
  as follows.
  ~bv[]
  (defun foo (state)
    (declare (xargs :stobjs state))
    (mv 3 state))
  ~ev[]
  A difference in the two approaches is that for the latter, a ~il[guard] proof
  obligation is generated by default.  See the section below entitled ``A
  remark on guards''.

  ~sc[State globals and the ACL2 logical world]

  Recall (~pl[state]) that one of the fields of the ACL2 state object is the
  global-table, which logically is an alist associating symbols, known as
  ``state globals'' or ``state global variables'', with values.  But no such
  alist actually exists in the implementation.  Instead, ACL2 provides
  utilities for reading state globals ~-[] ~pl[@] and ~pl[f-get-global] ~-[]
  and utilities for writing them ~-[] ~pl[assign] and ~pl[f-put-global].  The
  following log shows how they work; further explanation follows below.
  ~bv[]
  ACL2 !>(assign my-var (+ 3 4))
   7
  ACL2 !>(@ my-var)
  7
  ACL2 !>(f-put-global 'my-var (+ 1 5) state)
  <state>
  ACL2 !>(f-get-global 'my-var state)
  6
  ACL2 !>
  ~ev[]
  Note that the first result is indented by one space.  This is ACL2's way to
  indicate that the ~ilc[assign] expression returned an ``error triple'' and
  that no error was signalled.  We discuss error triples in more detail below;
  also ~pl[error-triples].

  As illustrated above, the output signatures of the utilities for assigning to
  state globals differ from each other as follows: ~ilc[f-put-global] returns
  ~c[state], but ~ilc[assign] returns an error triple ~c[(mv nil val state)]
  where ~c[val] is the value assigned to the state global.  The output
  signatures of the utilities for reading, ~c[@] and ~c[f-get-global], are
  identical.  In fact, the form ~c[(f-get-global 'my-var state)] is the
  single-step macroexpansion of the form ~c[(@ my-var)], as can be confirmed
  using ~ilc[trans1].
  ~bv[]
  ACL2 !>:trans1 (@ my-var)
   (F-GET-GLOBAL 'MY-VAR STATE)
  ACL2 !>
  ~ev[]

  State globals are useful for conveying persistent state information.
  Consider for example the utility ~ilc[set-inhibit-output-lst].  The form
  ~c[(set-inhibit-output-lst '(prove proof-tree))] is approximately equivalent
  to (assign inhibit-output-lst '(prove proof-tree)).  We say ``approximately''
  because ~c[set-inhibit-output-lst] additionally does some error checking to
  insure that all the tokens in the new list are legal.  When deciding whether
  to print output, the ACL2 system reads the value of state global variable
  ~c[inhibit-output-lst].

  A particularly useful state global is ~c[current-acl2-world], whose value is
  the ACL2 logical ~il[world].  Because the ACL2 world is commonly accessed in
  applications that use the ACL2 state, ACL2 provides a function that returns
  the world: ~c[(w state) = (f-get-global 'current-acl2-world state)].  While
  it is common to read the world, only functions ~c[set-w] and ~c[set-w!] are
  available to write the world, but these are untouchable and these should
  generally be avoided except by system implementors (pl[remove-untouchable]).

  ~sc[A remark on guards]

  For a function definition (~pl[defun]), if ~c[state] is specified as a
  ~il[stobj] as with the form ~c[(declare (xargs :stobjs state))], then the
  ~il[guard] for that function is considered to include the condition
  ~c[(state-p state)].  By default, ~il[guard] verification will then be
  performed.

  We can illustrate this point by modifying the example above as follows, to
  read the value of state global ~c[gag-mode].
  ~bv[]
  (defun foo (state)
    (declare (xargs :stobjs state))
    (f-get-global 'gag-mode state))
  ~ev[]
  If you try this in a fresh ACL2 session, the proof will fail with the
  following key checkpoint, which says that the state global ~c[gag-mode] is
  bound in the global-table of the state.
  ~bv[]
    (IMPLIES (STATE-P1 STATE)
             (ASSOC-EQUAL 'GAG-MODE (NTH 2 STATE)))
  ~ev[]

  How can we deal with this proof failure?   One way is simply to ignore the
  issue by defining the function in ~c[:]~ilc[program] mode, as follows.
  ~bv[]
  (defun foo (state)
    (declare (xargs :stobjs state
                    :mode :program))
    (f-get-global 'gag-mode state))
  ~ev[]
  Perhaps a better way is to strengthen the guard to assert that the indicated
  state global is bound, as follows.
  ~bv[]
  (defun foo (state)
    (declare (xargs :guard (boundp-global 'gag-mode state)
                    :stobjs state))
    (f-get-global 'gag-mode state))
  ~ev[]
  Also ~pl[guard-miscellany] for a discussion of how guards are generated from
  ~ilc[xargs] fields of ~il[declare] forms, specifically, for keywords
  ~c[:guard] and ~c[:stobjs].

  ~sc[Errors and error triples]

  When evaluation returns three values, where the first two are ordinary
  objects and the third is the ACL2 state, the result may be called an ``error
  triple''.  (Whether it is treated as an error triple depends on the
  programmer.)  Error triples are often denoted ~c[(mv erp val state)], and
  common ACL2 programming idioms treat ~c[erp] as a flag indicating whether an
  error is being signalled and ~c[val] as the ``value'' computed.  Also
  ~pl[error-triples].

  Even ACL2 users who are not programmers encounter error triples, because
  these are the values returned by evaluation of ACL2 ~il[events].  Consider
  the following log, where the only user input is the ~c[defun] form
  following the ~il[prompt].
  ~bv[]
  ACL2 !>(defun foo (x) x)

  Since FOO is non-recursive, its admission is trivial.  We observe that
  the type of FOO is described by the theorem (EQUAL (FOO X) X).

  Summary
  Form:  ( DEFUN FOO ...)
  Rules: NIL
  Time:  0.00 seconds (prove: 0.00, print: 0.00, other: 0.00)
   FOO
  ACL2 !>
  ~ev[]
  All output above results from explicit calls of output functions, except for
  the next-to-last line, which contains ~c[FOO].  Notice the single-space
  indentation preceding ~c[FOO].  That space indicates that in fact, the value
  returned by evaluation of the ~c[defun] form is the error triple whose error
  flag is ~c[nil] and whose computed value is ~c[FOO].  By default, ACL2 prints
  any error triple ~c[(mv nil val state)] by inserting a space before printing
  ~c[val].  You can change the default by setting state global
  ~ilc[ld-post-eval-print] to ~c[t]; notice how the same result is printed
  below.
  ~bv[]
  ACL2 !>:u
            0:x(EXIT-BOOT-STRAP-MODE)
  ACL2 !>(set-ld-post-eval-print t state)
  (NIL T <state>)
  ACL2 !>(defun foo (x) x)

  Since FOO is non-recursive, its admission is trivial.  We observe that
  the type of FOO is described by the theorem (EQUAL (FOO X) X).

  Summary
  Form:  ( DEFUN FOO ...)
  Rules: NIL
  Time:  0.00 seconds (prove: 0.00, print: 0.00, other: 0.00)
  (NIL FOO <state>)
  ACL2 !>
  ~ev[]

  The way error triples are printed by ~c[ld] is controlled not only by state
  global ~c[ld-post-eval-print], but also by state global ~c[ld-error-triples].
  These are examples of ``ld specials''; ~pl[ld], ~pl[ld-post-eval-print], and
  ~pl[ld-error-triples].

  It is so common to produce an error triple whose first (error flag) component
  is ~c[nil] that ACL2 provides a handy macro, ~c[value], for this purpose.
  Thus, ~c[(value <expression>)] is equivalent to
  ~c[(mv nil <expression> state)].  Also ~pl[value-triple] for a similar
  construct that is a legal event form.

  We turn now to the topic of errors.  The macro ~ilc[ER] ``causes'' an error,
  but there are really two quite different kinds of errors: ``soft'' and
  ``hard'' errors.  We use the term ``soft error'' to refer to a form that
  returns an error triple ~c[(mv erp val state)] for which ~c[erp] is
  non-~c[nil].  Soft errors do not interrupt the normal flow of evaluation: the
  error triple is returned to the caller which interprets the ~c[erp] flag and
  ~c[val] as directed by the programmer.  Macros discussed below make it
  convenient to think about soft errors as short-circuiting the computation.
  Hard errors, on the other hand, do actually rip control away from the current
  evaluation and return it to the top-level loop.  Logically speaking,
  expressions that cause hard errors return ~c[nil] in the error case, but the
  ~c[nil] is never seen in actual evaluation because control does not return to
  the caller.

  Note that the function ~ilc[abort!], which you can invoke by typing
  ~c[:]~ilc[a!], always returns to the top level.  Note that ACL2 can
  prove that ~c[(abort!)] returns ~c[nil] but that this cannot be confirmed
  by computation.
  ~bv[]
  ACL2 !>(thm (equal (abort!) nil))

  Q.E.D.

  Summary
  Form:  ( THM ...)
  Rules: ((:FAKE-RUNE-FOR-TYPE-SET NIL)
          (:TYPE-PRESCRIPTION ABORT!))
  Time:  0.00 seconds (prove: 0.00, print: 0.00, other: 0.00)

  Proof succeeded.
  ACL2 !>(equal (abort!) nil)
  Abort to ACL2 top-level
  ...
  ACL2 !>
  ~ev[]

  (What actually happens with a hard error, including non-default cases, is a
  bit subtle; most readers will probably want to skip this paragraph.  The
  read-eval-print loop implemented by ~ilc[ld] is implemented by a call of the
  ACL2 evaluator function, ~c[trans-eval], on each input form.  If a hard
  error occurs during evaluation of an input form, its ~c[trans-eval] call will
  return with a soft error.  ~ilc[Ld], in turn handles that soft error
  appropriately; ~pl[ld-error-action].)

  The most common way to signal errors is the macro ~ilc[er], which prints a
  formatted error message and returns a soft or hard error as specified by the
  call.  Note however that soft errors are signalled using ~c[:]~ilc[program]
  mode functions.

  Since the output signatures of soft and hard errors are different ~-[] hard
  errors ``return'' a single value while soft errors return a triple ~-[]
  mixing them in an expression requires embedding the hard error form in (an
  irrelevant) triple, as illustrated below.  All branches of the expression
  must produce an error triple if any branch does.
  ~bv[]
  ACL2 !>(defun chk-find-or-abort (e x state)
           (declare (xargs :mode :program))
           (if (endp x)
               (value                          ; Note use of VALUE!
                 (er hard 'chk-find-or-abort
                     \"Did not find ~~x0!\"
                      e))
               (if (not (integerp (car x)))
                   (er soft 'chk-find-or-abort
                       \"Non-integer, ~~x0, in list!\"
                       (car x))
                   (if (eql (car x) e)
                       (value x)
                       (chk-find-or-abort e (cdr x) state)))))

  Summary
  Form:  ( DEFUN CHK-FIND-OR-ABORT ...)
  Rules: NIL
  Time:  0.00 seconds (prove: 0.00, print: 0.00, other: 0.00)
   CHK-FIND-OR-ABORT
  ACL2 !>(chk-find-or-abort 3 '(1 2 3 4 5) state)
   (3 4 5)
  ACL2 !>(chk-find-or-abort 3 '(1 A 3 4 5) state)


  ACL2 Error in CHK-FIND-OR-ABORT:  Non-integer, A, in list!

  ACL2 !>(chk-find-or-abort 3 '(1 2 4 5) state)

  HARD ACL2 ERROR in CHK-FIND-OR-ABORT:  Did not find 3!
  ...
  ACL2 !>
  ~ev[]

  ~l[er] for further discussion of errors.  For some other individual topics
  related to errors ~pl[assert$], ~pl[break-on-error], ~pl[error1],
  ~pl[hard-error], ~pl[illegal], and ~pl[ld-error-triples].

  In the next section we discuss soft errors further, in the context of
  programming.

  ~sc[Sequential programming]

  This section describes handy ways to modify state in steps, using macros that
  implement a sequence of ~ilc[let] or ~ilc[mv-let] bindings.  For example,
  suppose you want to assign the values 1 and 2 to two state globals
  ~c[one-var] and ~c[two-var], respectively.  Because of ACL2's syntactic
  restrictions on ~ilc[state], it is not legal simply to write
  ~c[(f-put-global 'two-var 2 (f-put-global 'one-var 1 state))].  However,
  ~ilc[let] comes to the rescue as follows.
  ~bv[]
  (let ((state (f-put-global 'one-var 1 state)))
    (let ((state (f-put-global 'two-var 2 state)))
      state))
  ~ev[]
  It is so common to bind state successively in such a manner that ACL2
  provides a macro, ~ilc[pprogn], for this purpose.  Thus, an equivalent
  solution to the problem above is
  ~bv[]
  (pprogn (f-put-global 'one-var 1 state)
          (f-put-global 'two-var 2 state)
          state)
  ~ev[]
  or, more simply, as follows.
  ~bv[]
  (pprogn (f-put-global 'one-var 1 state)
          (f-put-global 'two-var 2 state))
  ~ev[]
  ~l[pprogn].  Note that the last form is allowed to return multiple values;
  the only requirement on the last form is that its value include ~c[state].

  It is also common to update the state using a sequence of forms such that
  each returns an error triple, where the intention is for evaluation to
  short-circuit immediately if a soft error is encountered.  Suppose
  ~c[<expr1>] and ~c[<expr2>] are expressions that return error triples, where
  the ~c[state] components of the error triples might be updated, and one
  wishes to evaluate ~c[<expr1>] and then ~c[<expr2>], returning the (multiple)
  values returned by ~c[<expr2>] unless the error triple returned by
  ~c[<expr1>] is a soft error, in which case that error triple is returned.
  One can of course do so as follows.
  ~bv[]
  (mv-let (erp val state)
          <expr1>
          (cond (erp (mv erp val state))
                (t <expr2>)))
  ~ev[]
  But ACL2 provides a handy macro, ~ilc[er-progn], for this purpose.  The
  following code is equivalent to the code just above.
  ~bv[]
  (er-progn <expr1> <expr2>)
  ~ev[]
  ~l[er-progn] for more details.  Note that unlike ~ilc[pprogn], the return
  ~il[signature] for the last expression must be the same as that of the
  others: an error triple.

  Let's consider how to use ~c[pprogn] and ~c[er-progn] together.  In the
  following example ~c[f1] and ~c[f2] both return ~c[state], while each of
  ~c[g1] and ~c[g2] returns an error triple.  The following code modifies state
  by executing these in the order ~c[f1], ~c[g1], ~c[f2], and finally ~c[g2],
  returning ~c[(mv nil val state)] where ~c[val] is the value component of the
  error triple returned by ~c[g2] ~-[] except we return a soft error if ~c[g1]
  or ~c[g2] returns a soft error.
  ~bv[]
  (pprogn (f1 x state)
          (er-progn (g1 x state)
                    (pprogn (f2 x state)
                            (g2 x state))))
  ~ev[]

  Finally, consider the ~il[events] ~ilc[progn] and ~ilc[progn!].  These have
  similar behavior to that of ~ilc[er-progn].  However, ~ilc[progn] and
  ~ilc[progn!] may only be used in event contexts, for example at the top level
  or immediately underneath a call of ~ilc[encapsulate] or ~ilc[progn], while
  ~ilc[er-progn] has no such restriction.  So when writing code, use
  ~c[er-progn] rather than ~ilc[progn] or ~ilc[progn!].  In particular, the
  body of a ~ilc[defun] must not have any calls of ~c[progn] (or of ~c[progn!]
  either), and the same restriction holds for any code to be executed, such as
  the body of a ~ilc[make-event] form.

  ~sc[Binding variables using error triples]

  In this section we discuss the macro ~c[er-let*], which is a variant of the
  special form, ~ilc[let*], that is useful when programming with state.

  The macro ~c[er-let*] is useful when binding variables to the value
  components of error triples.  It is actually quite similar to ~c[er-progn],
  described above, except that ~c[er-let*] binds variables.  First consider the
  following example.
  ~bv[]
  (er-let* ((x1 (f1 state))
            (x2 (f2 x1 state)))
    (value (cons x1 x2)))
  ~ev[]
  The code just above is essentially equivalent to writing the following.
  ~bv[]
  (mv-let (erp x1 state)
          (f1 state)
          (cond (erp (mv erp x1 state))
                (t (mv-let (erp x2 state)
                           (f2 x1 state)
                           (cond (erp (mv erp x2 state))
                                 (t (value (cons x1 x2))))))))
  ~ev[]

  As suggested by the example above, ~c[er-let*] has the same syntax as
  ~c[let*], except that declarations are not supported.  (But note that
  ~c[ignore] declarations are not needed; all variables that are bound are also
  used, at least in the error case.  Consider replacing ~c[(cons x1 x2)] by
  ~c[nil] in the example displayed immediately above, and note that ~c[x1] and
  ~c[x2] are still used.)  However, unlike ~c[let*], ~c[er-let*] requires that
  for each binding ~c[(var expr)], the expression ~c[expr] must evaluate to an
  error triple and, moreover, it requires that the second argument (the
  ``body'') of ~c[er-let*] must evaluate to an error triple.  If one of the
  variable expressions (e.g., the ~c[f1] and ~c[f2] calls above) signals an
  error, its error triple is returned as the value of the ~c[er-let*].

  Of course, soft errors can be ``caught'' by using ~ilc[mv-let] instead of
  ~c[er-let*] and simply ignoring the error flag or, more generally, by
  returning a non-erroneous error triple even if the error flag was on.

  ~sc[Binding state global variables]

  In this section we introduce a utility, ~ilc[state-global-let*], that is an
  analogue of ~c[let*] for state global variables.  Consider the following
  example.
  ~bv[]
  (state-global-let*
   ((inhibit-output-lst (add-to-set-eq 'summary (@ inhibit-output-lst))))
   (thm (equal x x)))
  ~ev[]
  This form binds state global variable ~c[inhibit-output-lst] to the result of
  adding the symbol, ~c[summary], to the current value of that state global.
  Thus (~pl[set-inhibit-output-lst]), the usual summary is not printed when
  evaluating this call of ~ilc[thm].

  ~l[state-global-let*] for more complete ~il[documentation].

  ~sc[Input and output]

  In ACL2, most input and output involves the ACL2 state.  ~l[io].

  ~sc[Timings]

  For how to obtain the time elapsed since the start of the ACL2 session,
  ~pl[read-run-time].

  For a utility for saving times into the ACL2 state and for printing those
  saved times, see the community book ~c[misc/save-time.lisp].

  To time an evaluation (though this really isn't about state), ~pl[time$].

  ~sc[Environment and system]

  Next, we mention briefly some ways in which ACL2 interacts with its
  environment using the ACL2 state.

  For how to read and write environment variables, ~pl[getenv$] and
  ~pl[setenv$].

  For how to run a command in the host operating system, ~pl[sys-call].

  ~sc[Remarks on events and LD]

  In general, undefined or surprising behavior may occur when using ACL2
  ~il[events] or calling ~il[ld] in your programs.  In some cases ACL2 enforces
  restrictions against these uses.  We strongly discourage using ~ilc[ld] in
  programs, as it has been designed to be called only at the top level of a
  read-eval-print loop.

  There is also a restriction on contexts in which ~ilc[make-event] may be
  called: it may only be called in a context where an event is expected, such
  as the top level, in a book, or as an argument of ~ilc[encapsulate] or
  ~ilc[progn].  The reason is that ACL2 does very subtle and careful tracking
  of ~ilc[make-event] expansions; and it is only able to do this in event
  contexts, where it is able to carry out such tracking accurately.

  ~sc[Advanced topics]

  ACL2 provides the function ~c[trans-eval] to evaluate an arbitrary form
  (after translating it to a ~il[term], i.e., into internal form).  For more
  information, we refer to reader to comments in the definition of
  ~c[trans-eval] in the ACL2 source code.  There are also many examples of its
  use in the ACL2 sources.

  For a function that provides the true absolute filename, with soft links
  resolved, ~pl[canonical-pathname].

  For a function that returns a check-sum on the characters in a channel,
  ~pl[check-sum].

  To obtain a random number, ~pl[random$].

  If you are programming in raw-mode (~pl[set-raw-mode]) or in raw Lisp, use
  the variable ~c[*the-live-state*] in place of the variable ~c[state].

  We invite suggestions for additional advanced topics.~/")

(defdoc error-triples
  ":Doc-Section state

  a common ACL2 programming idiom~/

  When evaluation returns three values, where the first two are ordinary
  (non-~il[stobj]) objects and the third is the ACL2 ~il[state], the result may
  be called an ``error triple''.  If an error triple is ~c[(mv erp val state)],
  we think of ~c[erp] as an error flag and ~c[val] as the returned value.
  By default, if the result of evaluating a top-level form is an error triple
  ~c[(mv erp val state)], then that result is not printed if ~c[erp] is
  non-~c[nil] or if ~c[val] is the keyword ~c[:INVISIBLE], and otherwise
  ~c[val] is printed with a preceding space.  For example:
  ~bv[]
  ACL2 !>(+ 3 4) ; ordinary value
  7
  ACL2 !>(mv nil (+ 3 4) state) ; error triple, error component of nil
   7
  ACL2 !>(mv t (+ 3 4) state) ; error triple, non-nil error component
  ACL2 !>(mv nil :invisible state) ; special case for :INVISIBLE
  ACL2 !>
  ~ev[]

  ~l[programming-with-state] for a discussion of error triples and how to
  program with them.  Also ~pl[ld-error-triples] and ~pl[ld] for a discussion
  of the value ~c[:COMMAND-CONVENTIONS] for keyword
  ~c[:LD-POST-EVAL-PRINT].~/~/")

(defun update-nth (key val l)

  ":Doc-Section ACL2::ACL2-built-ins

  modify a list by putting the given value at the given position~/

  ~c[(Update-nth key val l)] returns a list that is the same as the
  list ~c[l], except that the value at the ~c[0]-based position ~c[key]
  (a natural number) is ~c[val].~/

  If ~c[key] is an integer at least as large as the length of ~c[l], then
  ~c[l] will be padded with the appropriate number of ~c[nil] elements,
  as illustrated by the following example.
  ~bv[]
  ACL2 !>(update-nth 8 'z '(a b c d e))
  (A B C D E NIL NIL NIL Z)
  ~ev[]
  We have the following theorem.
  ~bv[]
  (implies (and (true-listp l)
                (integerp key)
                (<= 0 key))
           (equal (length (update-nth key val l))
                  (if (< key (length l))
                      (length l)
                    (+ 1 key))))
  ~ev[]

  The ~il[guard] of ~c[update-nth] requires that its first (position)
  argument is a natural number and its last (list) argument is a true
  list.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (true-listp l))
           (type (integer 0 *) key))
  (cond ((zp key)
         (cons val (cdr l)))
        (t (cons (car l)
                 (update-nth (1- key) val (cdr l))))))

; Rockwell Addition:

(defun update-nth-array (j key val l)
  (declare (xargs :guard (and (integerp j)
                              (integerp key)
                              (<= 0 j)
                              (<= 0 key)
                              (true-listp l)
                              (true-listp (nth j l)))))
  (update-nth j (update-nth key val (nth j l)) l))

; The following defmacro forms may speed up 32-bit-integerp a little.

(defmacro maximum-positive-32-bit-integer ()
  *maximum-positive-32-bit-integer*)

(defmacro maximum-positive-32-bit-integer-minus-1 ()
  (+ (- *maximum-positive-32-bit-integer*) -1))

(defun 32-bit-integerp (x)
  (declare (xargs :guard t))
  (and (integerp x)
       (<= x (maximum-positive-32-bit-integer))
       (>= x (maximum-positive-32-bit-integer-minus-1))))

(defthm 32-bit-integerp-forward-to-integerp
  (implies (32-bit-integerp x)
           (integerp x))
  :rule-classes :forward-chaining)

(defun acl2-number-listp (l)

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for a true list of numbers~/

  The predicate ~c[acl2-number-listp] tests whether its argument is a true list
  of numbers.

  To see the ACL2 definition of this function, ~pl[pf].~/~/"

  (declare (xargs :guard t))
  (cond ((atom l)
         (eq l nil))
        (t (and (acl2-numberp (car l))
                (acl2-number-listp (cdr l))))))

(defthm acl2-number-listp-forward-to-true-listp
  (implies (acl2-number-listp x)
           (true-listp x))
  :rule-classes :forward-chaining)

(defun rational-listp (l)

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for a true list of rational numbers~/

  The predicate ~c[rational-listp] tests whether its argument is a true
  list of rational numbers.

  To see the ACL2 definition of this function, ~pl[pf].~/~/"

  (declare (xargs :guard t))
  (cond ((atom l)
         (eq l nil))
        (t (and (rationalp (car l))
                (rational-listp (cdr l))))))

(defthm rational-listp-forward-to-acl2-number-listp
  (implies (rational-listp x)
           (acl2-number-listp x))
  :rule-classes :forward-chaining)

;; RAG - This function is analogous to rational-listp.

#+:non-standard-analysis
(defun real-listp (l)
  (declare (xargs :guard t))
  (cond ((atom l)
         (eq l nil))
        (t (and (realp (car l))
                (real-listp (cdr l))))))

(defdoc real-listp
  ":Doc-Section ACL2::Real

  ACL2(r) recognizer for a true list of real numbers~/

  The predicate ~c[real-listp] tests whether its argument is a true
  list of real numbers.  This predicate is only defined in ACL2(r)
  (~pl[real]).~/~/")

;; RAG - Standard forward chaining theorem about <type>-listp.

#+:non-standard-analysis
(defthm real-listp-forward-to-acl2-number-listp
  (implies (real-listp x)
           (acl2-number-listp x))
  :rule-classes :forward-chaining)

(defun integer-listp (l)

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for a true list of integers~/

  The predicate ~c[integer-listp] tests whether its argument is a true
  list of integers.

  To see the ACL2 definition of this function, ~pl[pf].~/~/"

  (declare (xargs :guard t))
  (cond ((atom l)
         (eq l nil))
        (t (and (integerp (car l))
                (integer-listp (cdr l))))))

(defthm integer-listp-forward-to-rational-listp
  (implies (integer-listp x)
           (rational-listp x))
  :rule-classes :forward-chaining)

(defun nat-listp (l)

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for a true list of natural  numbers~/

  The predicate ~c[nat-listp] tests whether its argument is a true
  list of natural numbers.

  To see the ACL2 definition of this function, ~pl[pf].~/~/"

  (declare (xargs :guard t))
  (cond ((atom l)
         (eq l nil))
        (t (and (natp (car l))
                (nat-listp (cdr l))))))

(defthm nat-listp-forward-to-integer-listp
  (implies (nat-listp x)
           (integer-listp x))
  :rule-classes :forward-chaining)

;; RAG - Analogous to the forward rule from integers to rationals.

#+:non-standard-analysis
(defthm rational-listp-forward-to-real-listp
  (implies (rational-listp x)
           (real-listp x))
  :rule-classes :forward-chaining)

(defun 32-bit-integer-listp (l)
  (declare (xargs :guard t))
  (cond ((atom l) (equal l nil))
        (t (and (32-bit-integerp (car l))
                (32-bit-integer-listp (cdr l))))))

(defthm 32-bit-integer-listp-forward-to-integer-listp
  (implies (32-bit-integer-listp x)
           (integer-listp x))
  :rule-classes :forward-chaining)

; Observe that even though we are defining the primitive accessors and
; updaters for states, we do not use the formal parameter STATE as an
; argument.  This is discussed in STATE-STATE below.

(defun open-input-channels (st)
  (declare (xargs :guard (true-listp st)))
  (nth 0 st))

(defun update-open-input-channels (x st)
  (declare (xargs :guard (true-listp st)))
  (update-nth 0 x st))

(defun open-output-channels (st)
  (declare (xargs :guard (true-listp st)))
  (nth 1 st))

(defun update-open-output-channels (x st)
  (declare (xargs :guard (true-listp st)))
  (update-nth 1 x st))

(defun global-table (st)
  (declare (xargs :guard (true-listp st)))
  (nth 2 st))

(defun update-global-table (x st)
  (declare (xargs :guard (true-listp st)))
  (update-nth 2 x st))

(defun t-stack (st)
  (declare (xargs :guard (true-listp st)))
  (nth 3 st))

(defun update-t-stack (x st)
  (declare (xargs :guard (true-listp st)))
  (update-nth 3 x st))

(defun 32-bit-integer-stack (st)
  (declare (xargs :guard (true-listp st)))
  (nth 4 st))

(defun update-32-bit-integer-stack (x st)
  (declare (xargs :guard (true-listp st)))
  (update-nth 4 x st))

(defun big-clock-entry (st)
  (declare (xargs :guard (true-listp st)))
  (nth 5 st))

(defun update-big-clock-entry (x st)
  (declare (xargs :guard (true-listp st)))
  (update-nth 5 x st))

(defun idates (st)
  (declare (xargs :guard (true-listp st)))
  (nth 6 st))

(defun update-idates (x st)
  (declare (xargs :guard (true-listp st)))
  (update-nth 6 x st))

(defun acl2-oracle (st)
  (declare (xargs :guard (true-listp st)))
  (nth 7 st))

(defun update-acl2-oracle (x st)
  (declare (xargs :guard (true-listp st)))
  (update-nth 7 x st))

(defun file-clock (st)
  (declare (xargs :guard (true-listp st)))
  (nth 8 st))

(defun update-file-clock (x st)
  (declare (xargs :guard (true-listp st)))
  (update-nth 8 x st))

(defun readable-files (st)
  (declare (xargs :guard (true-listp st)))
  (nth 9 st))

(defun written-files (st)
  (declare (xargs :guard (true-listp st)))
  (nth 10 st))

(defun update-written-files (x st)
  (declare (xargs :guard (true-listp st)))
  (update-nth 10 x st))

(defun read-files (st)
  (declare (xargs :guard (true-listp st)))
  (nth 11 st))

(defun update-read-files (x st)
  (declare (xargs :guard (true-listp st)))
  (update-nth 11 x st))

(defun writeable-files (st)
  (declare (xargs :guard (true-listp st)))
  (nth 12 st))

(defun list-all-package-names-lst (st)
  (declare (xargs :guard (true-listp st)))
  (nth 13 st))

(defun update-list-all-package-names-lst (x st)
  (declare (xargs :guard (true-listp st)))
  (update-nth 13 x st))

; We use the name ``user-stobj-alist1'' below so that we can reserve the
; name ``user-stobj-alist'' for the same function but which is known to
; take STATE as its argument.  See the discussion of STATE-STATE.

(defun user-stobj-alist1 (st)
  (declare (xargs :guard (true-listp st)))
  (nth 14 st))

(defun update-user-stobj-alist1 (x st)
  (declare (xargs :guard (true-listp st)))
  (update-nth 14 x st))

#-acl2-mv-as-values
(defconst *initial-raw-arity-alist*

; The list below is used for printing raw mode results.  It should include any
; functions that we know have arity 1 (in the sense of mv) but are not in
; *common-lisp-symbols-from-main-lisp-package*.

; The symbol :last means that the number of values returned by the call is the
; number of values returned by the last argument.

  '((er-progn . :last)
    (eval-when . :last) ; needed?
    (let . :last)
    (let* . :last)
    (make-event . 3)
    (mv-let . :last)
    (prog2$ . :last)
    (progn . :last)
    (the . :last) ; needed?
    (time . :last)
    (trace . 1)
    (untrace . 1)
    (set-raw-mode-on . 3)
    (set-raw-mode-off . 3)
    (mv-list . 1)
    (return-last . :last)))

(defconst *initial-checkpoint-processors*

; This constant is used in the implementation of proof-trees.

; We have removed preprocess-clause and simplify-clause because they are
; clearly not checkpoint processors; settled-down-clause, because it shouldn't
; come up anyhow; and :forcing-round, which should not be included unless
; special provision is made for forcing rounds that do not start with this
; marker.  Note that :induct is not a real processor, but rather will be a
; marker pointing to the start of the inductive proof of a pushed goal (in
; particular, to the induction scheme).

  '(eliminate-destructors-clause
    fertilize-clause
    generalize-clause
    eliminate-irrelevance-clause
    push-clause
    :induct))

(defconst *primitive-program-fns-with-raw-code*

; This is the list of :program mode functions generated by
; fns-different-wrt-acl2-loop-only in acl2-check.lisp.  We have added comments
; to give a sense of why these functions have #-acl2-loop-only code.

; Functions in this list should be executed only in raw Lisp, hence perhaps not
; in safe-mode.  See the case of 'program-only-er in ev-fncall-msg.

; This list is used in defining state global 'program-fns-with-raw-code.  If
; errors are caused by attempting to call some of these functions in safe-mode,
; consider adding such functions to the list *oneify-primitives*.

  '(relieve-hyp-synp ; *deep-gstack*
    apply-abbrevs-to-lambda-stack1 ; *nth-update-tracingp*
    nth-update-rewriter ; *nth-update-tracingp*
    ev-w-lst ; *the-live-state*
    simplify-clause1 ; dmr-flush
    ev-rec-acl2-unwind-protect ; *acl2-unwind-protect-stack*
    allocate-fixnum-range ; *the-live-state*
    trace$-fn-general ; trace
    ev-fncall! ; apply
    open-trace-file-fn ; *trace-output*
    set-trace-evisc-tuple ; *trace-evisc-tuple*
    ev-fncall-w ; *the-live-state*
    ev-rec ; wormhole-eval
    setup-simplify-clause-pot-lst1 ; dmr-flush
    save-exec-fn ; save-exec-raw, etc.
    cw-gstack-fn ; *deep-gstack*
    recompress-global-enabled-structure ; get-acl2-array-property
    ev-w ; *the-live-state*
    verbose-pstack ; *verbose-pstk*
    user-stobj-alist-safe ; chk-user-stobj-alist
    comp-fn ; compile-uncompiled-defuns
    fmt-ppr ; print-infix
    get-memo ; *nu-memos*
    acl2-raw-eval ; eval
    pstack-fn ; *pstk-stack*
    dmr-start-fn ; dmr-start-fn-raw
    memo-exit ; *nu-memos*
    memo-key1 ; *nu-memos*
    ev-fncall-meta ; *metafunction-context*
    ld-loop ; *ld-level*
    print-summary ; dmr-flush
    ev ; *ev-shortcut-okp*
    ev-lst ; *ev-shortcut-okp*
    allegro-allocate-slowly-fn ; sys:gsgc-parameter
    certify-book-fn ; si::sgc-on
    translate11-flet-alist1 ; special-form-or-op-p
    include-book-fn1
    include-book-fn
    set-w ; retract-world1, extend-world1, ...
    prove-loop ; *deep-gstack*
    chk-virgin ; chk-virgin2
    w-of-any-state ; live-state-p
    lambda-abstract ; *lambda-abstractp*
    ld-fn-body ; reset-parallelism-variables, *first-entry-to-ld-fn-body-flg*
    untranslate ; *the-live-state*
    longest-common-tail-length-rec ; eq
    compile-function ; compile
    untranslate-lst ; *the-live-state*
    ev-synp ; *metafunction-context*
    add-polys ; *add-polys-counter*
    dmr-stop-fn ; dmr-stop-fn-raw
    ld-print-results ; print-infix
    apply-abbrevs-to-lambda-stack ; *nth-update-tracingp*
    flpr ; print-flat-infix
    close-trace-file-fn ; *trace-output*
    ev-fncall-rec ; raw-ev-fncall
    ev-fncall ; live-state-p
    ld-fn0 ; *acl2-unwind-protect-stack*, etc.
    ld-fn  ; unwind-protect
    write-expansion-file ; compile-uncompiled-*1*-defuns
    latch-stobjs1 ; eq
    chk-package-reincarnation-import-restrictions ; [-restrictions2 version]
    untrace$-fn1 ; eval
    bdd-top ; (GCL only) si::sgc-on
    defstobj-field-fns-raw-defs ; call to memoize-flush when #+hons
    expansion-alist-pkg-names
    times-mod-m31 ; gcl has raw code
    iprint-ar-aref1
    prove ; #+write-arithmetic-goals
    make-event-fn
    oops-warning
    checkpoint-world
    ubt-prehistory-fn
    get-declaim-list
    pathname-unix-to-os
    hcomp-build-from-portcullis
    defconst-val
    push-warning-frame
    pop-warning-frame
    push-warning
    initialize-accumulated-warnings
    ev-rec-return-last
    chk-return-last-entry
    fchecksum-atom
    step-limit-error1
    waterfall1-lst@par ; for #+acl2-par
    waterfall1-wrapper@par-before ; for #+acl2-par
    waterfall1-wrapper@par-after ; for #+acl2-par
    increment-waterfall-parallelism-counter ; for #+acl2-par
    flush-waterfall-parallelism-hashtables ; for #+acl2-par
    clear-current-waterfall-parallelism-ht ; for #+acl2-par
    setup-waterfall-parallelism-ht-for-name ; for #+acl2-par
    set-waterfall-parallelism-fn ; for #+acl2-par combined with +hons
    fix-stobj-array-type
    set-gc-threshold$-fn
    certify-book-finish-complete
    chk-absstobj-invariants
    get-stobj-creator
    ))

(defconst *primitive-logic-fns-with-raw-code*

; This is the list of :logic mode functions generated by
; fns-different-wrt-acl2-loop-only.  We have commented on those functions whose
; #-acl2-loop-only code has side effects.  (Side effects are presumably the
; only issue, since functionally the #-acl2-loop-only code had better implement
; the logic code!)  We use lower-case when we can live with the
; #+acl2-loop-only code and upper case when we can't.

  '(mod-expt ; (GCL only) si::powm
    header
    search-fn
    state-p1 ; LIVE-STATE-P
    aref2 ; aref, slow-array-warning
    aref1 ; aref, slow-array-warning
    fgetprop ; EQ, GET, ...
    getenv$ ; GETENV$-RAW
    wormhole-eval ; *WORMHOLE-STATUS-ALIST*
    wormhole1 ; *WORMHOLEP*, ...
    get-wormhole-status ; *WORMHOLE-STATUS-ALIST*
    aset2 ; [seems like we can live with logic code]
    sgetprop ; SGETPROP1
    setenv$ ; SI::SETENV ...
    getprops ; EQ, GET, ...
    compress1 ; [seems like we can live with logic code]
    time-limit5-reached-p ; THROW
    fmt-to-comment-window ; *THE-LIVE-STATE*
    len ; len1
    cpu-core-count ; CORE-COUNT-RAW
    nonnegative-integer-quotient ; floor
    check-print-base ; PRIN1-TO-STRING
    retract-world ; RETRACT-WORLD1
    aset1 ; [seems like we can live with logic code]
    array1p ; get [seems like we can live with logic code]
    boole$ ; boole
    array2p ; [seems like we can live with logic code]
    strip-cdrs ; strip-cdrs1
    compress2 ; [seems like we can live with logic code]
    strip-cars ; strip-cars1
    plist-worldp ; *the-live-state* (huge performance penalty?)
    wormhole-p ; *WORMHOLEP*
    may-need-slashes-fn ;*suspiciously-first-numeric-array* ...
    fmt-to-comment-window! ; *THE-LIVE-STATE*
    has-propsp ; EQ, GET, ...
    hard-error ; *HARD-ERROR-RETURNS-NILP*, FUNCALL, ...
    abort! p! ; THROW
    flush-compress ; SETF [may be critical for correctness]
    alphorder ; [bad atoms]
    extend-world ; EXTEND-WORLD1
    default-total-parallelism-work-limit ; for #+acl2-par (raw Lisp error)

; The following have arguments of state-state, and hence some may not be of
; concern since presumably users cannot define these redundantly anyhow.  But
; we go ahead and include them, just to be safe.

    user-stobj-alist read-acl2-oracle read-acl2-oracle@par
    update-user-stobj-alist decrement-big-clock put-global close-input-channel
    makunbound-global open-input-channel open-input-channel-p1 boundp-global1
    global-table-cars1 extend-t-stack list-all-package-names
    close-output-channel write-byte$ shrink-t-stack aset-32-bit-integer-stack
    get-global 32-bit-integer-stack-length1 extend-32-bit-integer-stack
    aset-t-stack aref-t-stack read-char$ aref-32-bit-integer-stack
    open-output-channel open-output-channel-p1 princ$ read-object
    big-clock-negative-p peek-char$ shrink-32-bit-integer-stack read-run-time
    read-byte$ read-idate t-stack-length1 print-object$-ser
    get-output-stream-string$-fn

    mv-list return-last

; The following were discovered after we included functions defined in
; #+acl2-loop-only whose definitions are missing (or defined with
; defun-one-output) in #-acl-loop-only.

    ZPF IDENTITY ENDP NTHCDR LAST REVAPPEND NULL BUTLAST STRING NOT
    MOD PLUSP ATOM LISTP ZP FLOOR CEILING TRUNCATE ROUND REM REMOVE
    REMOVE-DUPLICATES LOGBITP ASH LOGCOUNT SIGNUM INTEGER-LENGTH EXPT
    SUBSTITUTE ZEROP MINUSP ODDP EVENP = /= MAX MIN CONJUGATE
    LOGANDC1 LOGANDC2 LOGNAND LOGNOR LOGNOT LOGORC1 LOGORC2 LOGTEST
    ABS STRING-EQUAL STRING< STRING> STRING<= STRING>=
    STRING-UPCASE STRING-DOWNCASE KEYWORDP EQ EQL CHAR SUBST SUBLIS
    ACONS NTH SUBSEQ LENGTH REVERSE ZIP STANDARD-CHAR-P
    ALPHA-CHAR-P UPPER-CASE-P LOWER-CASE-P CHAR< CHAR> CHAR<= CHAR>=
    CHAR-EQUAL CHAR-UPCASE CHAR-DOWNCASE
    AND-LIST OR-LIST ; relevant for #+acl2-par

; Might as well add additional ones below:

    random$
    throw-nonexec-error
    gc$-fn
    set-compiler-enabled
    good-bye-fn ; exit-lisp
    remove-eq remove-equal
    take
    file-write-date$
    print-call-history
    set-debugger-enable-fn ; lisp::*break-enable* and *debugger-hook*
    break$ ; break
    prin1$ prin1-with-slashes
    member-equal assoc-equal subsetp-equal no-duplicatesp-equal
    rassoc-equal remove-equal position-equal
    maybe-finish-output$

; Found for hons after fixing note-fns-in-form just before release v4-2.

    FAST-ALIST-LEN HONS-COPY-PERSISTENT HONS-SUMMARY HONS-CLEAR HONS-WASH
    HONS-SHRINK-ALIST HONS-EQUAL-LITE CLEAR-HASH-TABLES NUMBER-SUBTREES
    FAST-ALIST-SUMMARY HONS-ACONS! CLEAR-MEMOIZE-TABLES HONS-COPY HONS-ACONS
    CLEAR-MEMOIZE-TABLE FAST-ALIST-FREE HONS-EQUAL HONS-RESIZE-FN HONS-GET HONS
    HONS-SHRINK-ALIST! MEMOIZE-SUMMARY CLEAR-MEMOIZE-STATISTICS
    make-fast-alist
    serialize-read-fn serialize-write-fn
    read-object-suppress
    assign-lock
    throw-or-attach-call
    oracle-apply oracle-apply-raw
    time-tracker-fn
    gc-verbose-fn
    set-absstobj-debug-fn
    sys-call-status ; *last-sys-call-status*
    sys-call ; system-call
    sys-call+ ; system-call+

    canonical-pathname ; under dependent clause-processor

; mfc functions

    mfc-ancestors ; *metafunction-context*
    mfc-clause ; *metafunction-context*
    mfc-rdepth ; *metafunction-context*
    mfc-type-alist ; *metafunction-context*
    mfc-unify-subst ; *metafunction-context*
    mfc-world ; *metafunction-context*
    mfc-ap-fn ; under dependent clause-processor
    mfc-relieve-hyp-fn ; under dependent clause-processor
    mfc-relieve-hyp-ttree ; under dependent clause-processor
    mfc-rw+-fn ; under dependent clause-processor
    mfc-rw+-ttree ; under dependent clause-processor
    mfc-rw-fn ; under dependent clause-processor
    mfc-rw-ttree ; under dependent clause-processor
    mfc-ts-fn ; under dependent clause-processor
    mfc-ts-ttree ; under dependent clause-processor
    magic-ev-fncall ; under dependent clause-processor
    never-memoize-fn

; The following are introduced into the logic by an encapsulate, but have raw
; Lisp definitions.

    big-n zp-big-n decrement-big-n

; The following are introduced into the logic with encapsulates, but have their
; raw Lisp definitions provided by defproxy.

    ancestors-check
    oncep-tp
    print-clause-id-okp
    too-many-ifs-post-rewrite
    too-many-ifs-pre-rewrite
  ))

(defconst *primitive-macros-with-raw-code*

; This list is generated by fns-different-wrt-acl2-loop-only.

  '(theory-invariant
    set-let*-abstractionp defaxiom
    set-bogus-mutual-recursion-ok
    set-ruler-extenders
    delete-include-book-dir certify-book progn!
    f-put-global push-untouchable
    set-backchain-limit set-default-hints!
    set-rw-cache-state! set-override-hints-macro
    deftheory pstk verify-guards defchoose
    set-default-backchain-limit set-state-ok
    set-ignore-ok set-non-linearp set-tau-auto-mode with-output
    set-compile-fns add-include-book-dir
    clear-pstk add-custom-keyword-hint
    initial-gstack
    acl2-unwind-protect set-well-founded-relation
    catch-time-limit5 catch-time-limit5@par
    defuns add-default-hints!
    local encapsulate remove-default-hints!
    include-book pprogn set-enforce-redundancy
    set-ignore-doc-string-error
    logic er deflabel mv-let program value-triple
    set-body comp set-bogus-defun-hints-ok
    dmr-stop defpkg set-measure-function
    set-inhibit-warnings! defthm mv
    f-big-clock-negative-p reset-prehistory
    mutual-recursion set-rewrite-stack-limit set-prover-step-limit
    add-match-free-override
    set-match-free-default
    the-mv table in-arithmetic-theory regenerate-tau-database
    set-case-split-limitations
    set-irrelevant-formals-ok remove-untouchable
    in-theory with-output-forced dmr-start
    rewrite-entry skip-proofs f-boundp-global
    make-event set-verify-guards-eagerness
    wormhole verify-termination-boot-strap start-proof-tree
    f-decrement-big-clock defabsstobj defstobj defund defttag
    defdoc push-gframe defthmd f-get-global
    set-nu-rewriter-mode

; Most of the following were discovered after we included macros defined in
; #+acl2-loop-only whose definitions are missing in #-acl-loop-only.

    CAAR CADR CDAR CDDR CAAAR CAADR CADAR CADDR CDAAR CDADR CDDAR CDDDR
    CAAAAR CAAADR CAADAR CAADDR CADAAR CADADR CADDAR CADDDR CDAAAR
    CDAADR CDADAR CDADDR CDDAAR CDDADR CDDDAR CDDDDR REST MAKE-LIST
    LIST OR AND * LOGIOR LOGXOR LOGAND SEARCH LOGEQV CONCATENATE LET*
    DEFUN THE > <= >= + - / 1+ 1- PROGN DEFMACRO COND CASE LIST*
    APPEND DEFCONST IN-PACKAGE INTERN FIRST SECOND THIRD FOURTH FIFTH
    SIXTH SEVENTH EIGHTH NINTH TENTH DIGIT-CHAR-P
    UNMEMOIZE MEMOIZE ; for #+hons
    DEFUNS-STD DEFTHM-STD DEFUN-STD ; for #+:non-standard-analysis
    POR PAND PLET PARGS ; for #+acl2-par
    SPEC-MV-LET ; for #+acl2-par

; The following were included after Version_3.4 as ACL2 continued to evolve.

    trace!
    with-live-state
    with-output-object-channel-sharing
    with-hcomp-bindings
    with-hcomp-ht-bindings
    redef+
    redef-
    bind-acl2-time-limit
    defattach defproxy
    count
    member assoc subsetp no-duplicatesp rassoc remove remove-duplicates
    position
    catch-step-limit
    step-limit-error
    waterfall-print-clause-id@par ; for #+acl2-par
    deflock ; for #+acl2-par
    f-put-global@par ; for #+acl2-par
    set-waterfall-parallelism
    with-prover-step-limit
    waterfall1-wrapper@par ; for #+acl2-par
    with-waterfall-parallelism-timings ; for #+acl2-par
    with-parallelism-hazard-warnings ; for #+acl2-par
    warn-about-parallelism-hazard ; for #+acl2-par
    with-ensured-parallelism-finishing ; for #+acl2-par
    state-global-let* ; raw Lisp version for efficiency
    with-reckless-readtable
    with-lock
    catch-throw-to-local-top-level
    with-fast-alist-raw with-stolen-alist-raw fast-alist-free-on-exit-raw
    stobj-let
    add-ld-keyword-alias! set-ld-keyword-aliases!
    ))

(defmacro with-live-state (form)

; Occasionally macros will generate uses of STATE, which is fine in the ACL2
; loop but can cause compiler warnings in raw Lisp.  For example, in v3-4 with
; CCL one found:

;     ? [RAW LISP] (trace$)
;     ;Compiler warnings :
;     ;   In an anonymous lambda form: Undeclared free variable STATE
;     NIL
;     NIL
;     ACL2_INVISIBLE::|The Live State Itself|
;     ? [RAW LISP]

; The present macro is provided in order to avoid this problem: in raw Lisp
; (with-live-state form) binds state to *the-live-state*.  This way, we avoid
; the above compiler warning.

; Unfortunately, our initial solution was unsound.  The following book
; certifies in Versions 3.5 and 4.3, and probably all versions inbetween.

;   (in-package "ACL2")
;
;   (defun foo (state)
;     (declare (xargs :stobjs state))
;     (with-live-state state))
;
;   (defthm thm1
;     (equal (caddr (foo (build-state)))
;            nil)
;     :rule-classes nil)
;
;   (defthm thm2
;     (consp (caddr (build-state)))
;     :rule-classes nil)
;
;   (defthm contradiction
;     nil
;     :hints (("Goal"
;              :use (thm1 thm2)
;              :in-theory (disable build-state (build-state))))
;     :rule-classes nil)

; The problem was that state was bound to *the-live-state* for evaluation
; during a proof, where lexically state had a different binding that should
; have ruled.  This macro's conde included the check (eq (symbol-value 'state)
; *the-live-state*), which unfortunately was no check at all: it was already
; true because symbol-value returns the global value, and is not affected by a
; superior lexical binding of state.

; Our initial solution defined this macro to be the identity within the usual
; ACL2 loop, as determined by (> *ld-level* 0).  But compile-file is called
; when certifying a book, so state remained free in that place, generating a
; compiler warning or (on occasion with CCL) an error.

; So we have decided to keep the existing implementation, in which this macro
; always binds state to *the-live-state* in raw Lisp, but to make this macro
; untouchable.  Thus, users can call it freely in raw Lisp or raw-mode, where
; they simply need to understand its spec.  But they will never be able to
; exploit it to prove nil (without a trust tag or entering raw Lisp).

; We could avoid making this macro untouchable if we had a way to query the
; lexical environment to see if state is lexically bound.  If so, the macro
; call would expand to the identity; if not, it would bind state to
; *the-live-state*.  But we found no way in Common Lisp to do that.

  ":Doc-Section ACL2::ACL2-built-ins

  allow a reference to ~c[state] in raw Lisp~/

  The macro ~c[with-live-state] is an advanced feature that very few users will
  need (basically, only system hackers).  Indeed, it is untouchable;
  ~pl[remove-untouchable] for how to enable calling ~c[with-live-state] in the
  ACL2 loop.~/

  ~bv[]
  Example Form:
  (with-live-state (assign y 3))

  General form:
  (with-live-state form)
  ~ev[]
  where form is an arbitrary form with a free reference to the variable
  ~ilc[state].

  Logically, ~c[(with-live-state FORM)] macroexpands to ~c[FORM].  However, in
  raw Lisp it expands to:
  ~bv[]
  (let ((state *the-live-state*))
    FORM)
  ~ev[]

  If a form that mentions the variable ~ilc[state] might be executed in raw
  Lisp ~-[] that is, either outside the ACL2 loop or in raw
  mode (~pl[set-raw-mode]) ~-[] then the surrounding the form with
  ~c[with-live-state] as shown above can avoid potential warnings or (much less
  likely) errors.  Note however that if ~c[state] is lexically bound to a state
  other than the usual ``live'' state, surprising behavior may occur when
  evaluating a call of ~c[with-live-state] in raw Lisp or raw mode (either
  directly by evaluation or at compile time), because ~c[with-live-state] will
  override that lexical binding of ~ilc[state] by a lexical binding of
  ~c[state] to the usual ``live'' state.~/"

  #+acl2-loop-only
  form
  #-acl2-loop-only
  `(let ((state *the-live-state*))
     ,form))

(defun init-iprint-ar (hard-bound enabledp)

; We return an iprint-ar with the given hard-bound.

; As stated in the Essay on Iprinting, we maintain the invariants that the
; dimension of state global 'iprint-ar exceeds the hard bound and that the
; maximum-length of the 'iprint-ar is always at least four times its dimension.

; Therefore, we need to avoid :order nil so that compress can shrink the
; array.

; We write the array ar as we do below so that (equal (compress1 'iprint-ar ar)
; ar) is T.  That probably is not important, but it may come in handy at some
; point to know that compress1 is the identity on this array.

; WARNING: Consider carefully comments in rollover-iprint-ar and
; disable-iprint-ar before changing :ORDER.

  (declare (xargs :guard (natp hard-bound)))
  (let* ((dim (1+ hard-bound)))
    `((:HEADER :DIMENSIONS     (,dim)
               :MAXIMUM-LENGTH ,(* 4 dim)
               :DEFAULT        nil
               :NAME           iprint-ar
               :ORDER          :none)
      (0 . ,(if enabledp 0 (list 0))))))

; The default bounds for iprinting are deliberately rather high, in order to
; minimize the chance that novice users attempt to read stale #@i# values.
; We assume that for those who use ACL2 with large objects, for whom iprinting
; causes a space problem because of these large bounds, will know to reset the
; bounds using set-iprint.
(defconst *iprint-soft-bound-default* 1000)
(defconst *iprint-hard-bound-default* 10000)

(defdoc parallelism

  ":Doc-Section Parallelism

  experimental extension for parallel execution and proofs~/

  This documentation topic relates to an experimental extension of ACL2,
  ACL2(p), created initially by David L. Rager.  ~l[compiling-acl2p] for how to
  build an executable image that supports parallel execution.  Also see
  community books directory ~c[books/parallel/] for examples.  For a completely
  different sort of parallelism, at the system level,
  ~pl[provisional-certification].~/

  IMPORTANT NOTE.  We hope and expect that every evaluation result is correctly
  computed by ACL2(p), and that every formula proved using ACL2(p) is a theorem
  of the ACL2 logic (and in fact is provable using ACL2).  However, we do not
  guarantee these properties.  Since ACL2(p) is intended to be an aid in
  efficient evaluation and proof development, we focus less on ironclad
  soundness and more on providing an efficient and working implementation.
  Nevertheless, if you encounter a case where ACL2(p) computes an incorrect
  result, or produces a proof where ACL2 fails to do so (and this failure is
  not discussed in ~il[unsupported-waterfall-parallelism-features]), please
  notify the implementors.

  The ACL2 source code provides experimental parallel execution and proof
  capabilities.  For example, one of ACL2's strengths lies in its ability to
  simulate industrial models efficiently, and it can also decrease the time
  required for proofs about such models both by making use of parallel
  evaluation and by dispatching proof subgoals in parallel.

  While we aim to support Clozure Common Lisp (CCL), Steel Bank Common
  Lisp (SBCL), and Lispworks, SBCL and Lispworks both currently sometimes
  experience problems when evaluating the ACL2 proof process (the
  ``waterfall'') in parallel.  Therefore, CCL is the recommend Lisp for anyone
  that wants to use parallelism and isn't working on fixing those
  problems.~/")

(defdoc parallel-programming

  ":Doc-Section ACL2::Parallelism

  parallel programming in ACL2(p)~/

  Here we document support for parallel programming in ACL2(p), an experimental
  extension of ACL2; also ~pl[parallelism].~/

  One of ACL2's strengths lies in its ability to execute industrial models
  efficiently.  The ACL2 source code provides an experimental parallel
  execution capability that can increase the speed of explicit evaluation,
  including simulator runs using such models, and it can also decrease the time
  required for proofs that make heavy use of the evaluation of ground terms.

  The parallelism primitives are ~ilc[plet], ~ilc[pargs], ~ilc[pand],
  ~ilc[por], and ~ilc[spec-mv-let].  ~ilc[Pand] and ~ilc[por] terminate early
  when an argument is found to evaluate to ~c[nil] or non-~c[nil],
  respectively, thus potentially improving on the efficiency of lazy
  evaluation.  ~ilc[Spec-mv-let] is a modification of ~ilc[mv-let] that
  supports speculative and parallel execution.

  Of the above five parallelism primitives, all but ~ilc[spec-mv-let] allow for
  limiting parallel execution (spawning of so-called ``threads'') depending on
  resource availability.  Specifically, the primitives allow specification of a
  size condition to control the ~il[granularity] under which threads are
  allowed to spawn.  You can use such ~il[granularity] declarations in
  recursively-defined functions to implement data-dependent parallelism in
  their execution.

  We recommend that in order to learn to use the parallelism primitives, you
  begin by reading examples: ~pl[parallelism-tutorial].  That section will
  direct you to further documentation topics.

  In addition to providing parallel programming primitives, ACL2(p) also
  provides the ability to execute the main ACL2 proof process in parallel.
  ~l[set-waterfall-parallelism] for further details.~/")

(defdoc parallel-proof

; Parallelism blemish: write a few introductory words to "advertise" parallel
; proof in ACL2(p), perhaps by way of a very simple example.

  ":Doc-Section ACL2::Parallelism

  parallel proof in ACL2(p)~/

  Here we document support for parallel proof in ACL2(p), an experimental
  extension of ACL2; also ~pl[parallelism], and for parallel programming in
  particular, ~pl[parallel-programming].~/~/")

(defun default-total-parallelism-work-limit ()

; The number of pieces of work in the system, *total-work-count* and
; *total-future-count* (depending upon whether one is using the
; plet/pargs/pand/por system or the spec-mv-let system [which is based upon
; futures]), must be less than the ACL2 global total-parallelism-work-limit in
; order to enable creation of new pieces of work or futures.  (However, if
; total-parallelism-work-limit were set to 50, we could go from 49 to 69 pieces
; of work when encountering a pand; just not from 50 to 52.)

; Why limit the amount of work in the system?  :Doc parallelism-how-to
; (subtopic "Another Granularity Issue Related to Thread Limitations") provides
; an example showing how cdr recursion can rapidly create threads.  That
; example shows that if there is no limit on the amount of work we may create,
; then eventually, many successive cdrs starting at the top will correspond to
; waiting threads.  If we do not limit the amount of work that can be created,
; this can exhaust the supply of Lisp threads available to process the elements
; of the list.

  ":Doc-Section Parallel-proof

  for ACL2(p): returns the default value for global ~c[total-parallelism-work-limit]~/

  ~l[set-total-parallelism-work-limit].~/~/"

  (declare (xargs :guard t))
  (let ((val

; Warning: It is possible, in principle to create (+ val
; *max-idle-thread-count*) threads.  You'll receive either a hard Lisp error,
; segfault, or complete machine crash if your Lisp cannot create that many
; threads.

; We picked a new value of 400 on September 2011 to support Robert Krug's proof
; that took ~9000 seconds in serial mode.  Initially, when
; default-total-parallelism-work-limit returned 50, the parallelized proof only
; saw an improvement to ~2200 seconds, but after changing the return value to
; 400, the parallelized proof now takes ~1300 seconds.

; After doing even more tests, we determined that a limit of 400 is still too
; low (another one of Robert's proofs showed us this).  So, now that we have
; the use-case for setting this to the largest number that we think the
; underlying runtime system will support, we do exactly that.  As of Jan 26,
; 2012, we think a safe enough limit is 4,000.  So, we use that number.  As
; multi-threading becomes more prevalent and the underlying runtime systems
; increase their support for massive numbers of threads, we may wish to
; continue to increase this number.  Note, however, that since we would also
; like to support older systems, perhaps increasing this number is infeasible,
; since the default should support all systems.

; On April 6, 2012, Rager reworked the way that we use spec-mv-let in the
; waterfall.  As such, the limit on the total amount of parallelism work
; allowed in the system now has a different consequence (in terms of the number
; of threads required to process futures).  As such, the limit was increased
; from 4,000 to 8,000 on April 11, 2012.

         8000))
    #+(and acl2-par (not acl2-loop-only))
    (let ((bound (* 4 *core-count*)))
      (when (< val bound)

; Since this check is cheap and not performed while we're doing proofs, we
; leave it.  That being said, we do not realistically expect to receive this
; error for a very long time, because it will be a very long time until the
; number of CPU cores is within a factor of 4 of 10,000.  David Rager actually
; found this check useful once upon a time (back when the limit was 50),
; because he was testing ACL2(p) on one of the IBM 64-core machines and forgot
; that this limit needed to be increased.

        (error "The value returned by function ~
                default-total-parallelism-work-limit needs to be at ~%least ~
                ~s, i.e., at least four times the *core-count*.  ~%Please ~
                redefine function default-total-parallelism-work-limit so ~
                that it ~%is not ~s."
               bound
               val)))
    val))

(defconst *fmt-soft-right-margin-default* 65)
(defconst *fmt-hard-right-margin-default* 77)

(defconst *initial-global-table*

; Warning: Keep this list in alphabetic order as per ordered-symbol-alistp.  It
; must satisfy the predicate ordered-symbol-alistp if build-state is to build a
; state-p.

; When you add a new state global to this table, consider whether to modify
; *protected-system-state-globals*.

; Note that check-state-globals-initialized insists that all state globals that
; are bound by the build are bound in this alist or in
; *initial-ld-special-bindings*.

  `((abbrev-evisc-tuple . :default)
    (accumulated-ttree . nil) ; just what succeeded; tracking the rest is hard
    (acl2-raw-mode-p . nil)
    (acl2-sources-dir . nil) ; set by initialize-state-globals
    (acl2-version .

; Keep this value in sync with the value assigned to
; acl2::*copy-of-acl2-version* in file acl2.lisp.

; The reason MCL needs special treatment is that (char-code #\Newline) = 13 in
; MCL, not 10.  See also :DOC version.

; ACL2 Version 6.3

; We put the version number on the line above just to remind ourselves to bump
; the value of state global 'acl2-version, which gets printed out with the
; check-sum info.

; Leave this here.  It is read when loading acl2.lisp.  This constant should be
; a string containing at least one `.'.  The function save-acl2-in-akcl in
; akcl-init.lisp suggests that the user see :doc notexxx, where xxx is the
; substring appearing after the first `.'.

; We have occasion to write fixed version numbers in this code, that is,
; version numbers that are not supposed to be touched when we do ``version
; bump.''  The problem is that version bump tends to replace the standard
; version string with an incremented one, so we need a way to make references
; to versions in some non-standard form.  In Lisp comments we tend to write
; these with an underscore instead of a space before the number.  Thus, `ACL2
; Version_2.5' is a fixed reference to that version.  In :DOC strings we tend
; to write ACL2 Version 2.5.  Note the two spaces.  This is cool because HTML
; etc removes the redundant spaces so the output of this string is perfect.
; Unfortunately, if you use the double space convention in Lisp comments the
; double space is collapsed by ctrl-meta-q when comments are formatted.  They
; are also collapsed by `fill-format-string', so one has to be careful when
; reformatting :DOC comments.

                  ,(concatenate 'string
                                "ACL2 Version 6.3"
                                #+non-standard-analysis
                                "(r)"
                                #+(and mcl (not ccl))
                                "(mcl)"))
    (acl2p-checkpoints-for-summary . nil)
    (axiomsp . nil)
    (bddnotes . nil)
    (certify-book-info .

; Certify-book-info is non-nil when certifying a book, in which case it is a
; certify-book-info record.

                       nil)
    (check-sum-weirdness . nil)
    (checkpoint-forced-goals . nil) ; default in :doc
    (checkpoint-processors . ; avoid unbound var error with collect-checkpoints
                           ,*initial-checkpoint-processors*)
    (checkpoint-summary-limit . (nil . 3))
    (compiled-file-extension . nil) ; set by initialize-state-globals
    (compiler-enabled . nil) ; Lisp-specific; set by initialize-state-globals
    (connected-book-directory . nil)  ; set-cbd couldn't have put this!
    (current-acl2-world . nil)
    (current-package . "ACL2")
    (debug-pspv .

; This variable is used with #+acl2-par for printing information when certain
; modifications are made to the pspv in the waterfall.  David Rager informs us
; in December 2011 that he hasn't used this variable in some time, but that it
; still works as far as he knows.  It should be harmless to remove it if there
; is a reason to do so, but of course there would be fallout from doing so
; (e.g., argument lists of various functions that take a debug-pspv argument
; would need to change).

                nil)
    (debugger-enable . nil) ; keep in sync with :doc set-debugger-enable
    (defaxioms-okp-cert . t) ; t when not inside certify-book
    (deferred-ttag-notes . :not-deferred)
    (deferred-ttag-notes-saved . nil)
    (dmrp . nil)
    (doc-char-subst-table . nil)
    (doc-fmt-alist . nil)
    (evisc-hitp-without-iprint . nil)
    (eviscerate-hide-terms . nil)
    (fmt-hard-right-margin . ,*fmt-hard-right-margin-default*)
    (fmt-soft-right-margin . ,*fmt-soft-right-margin-default*)
    (gag-mode . nil) ; set in lp
    (gag-mode-evisc-tuple . nil)
    (gag-state . nil)
    (gag-state-saved . nil) ; saved when gag-state is set to nil
    (get-internal-time-as-realtime . nil) ; seems harmless to change
    (global-enabled-structure . nil) ; initialized in enter-boot-strap-mode
    (gstackp . nil)
    (guard-checking-on . t)
    (host-lisp . nil)
    (illegal-to-certify-message . nil)
    (in-local-flg . nil)
    (in-prove-flg . nil)
    (in-verify-flg . nil)
    (infixp . nil)                   ; See the Essay on Infix below
    (inhibit-output-lst . (summary)) ; Without this setting, initialize-acl2
                                     ; will print a summary for each event.
                                     ; Exit-boot-strap-mode sets this list
                                     ; to nil.
    (inhibit-output-lst-stack . nil)
    (inhibited-summary-types . nil)
    (inside-skip-proofs . nil)
    (iprint-ar . ,(init-iprint-ar *iprint-hard-bound-default* nil))
    (iprint-hard-bound . ,*iprint-hard-bound-default*)
    (iprint-soft-bound . ,*iprint-soft-bound-default*)
    (keep-tmp-files . nil)
    (last-make-event-expansion . nil)
    (last-prover-steps . nil)
    (last-step-limit . -1) ; any number should be OK
    (ld-level . 0)
    (ld-okp . :default) ; see :DOC calling-ld-in-bad-contexts
    (ld-redefinition-action . nil)
    (ld-skip-proofsp . nil)
    (logic-fns-with-raw-code . ,*primitive-logic-fns-with-raw-code*)
    (macros-with-raw-code . ,*primitive-macros-with-raw-code*)
    (main-timer . 0)
    (make-event-debug . nil)
    (make-event-debug-depth . 0)
    (match-free-error . nil) ; if t, modify :doc for set-match-free-error
    (modifying-include-book-dir-alist . nil)
    (more-doc-max-lines . 45)
    (more-doc-min-lines . 35)
    (more-doc-state . nil)
    (parallel-execution-enabled . nil)
    (parallelism-hazards-action . nil) ; nil or :error, else treated as :warn
    (pc-erp . nil)
    (pc-output . nil)
    (pc-print-macroexpansion-flg . nil)
    (pc-print-prompt-and-instr-flg . t)
    (pc-prompt . "->: ")
    (pc-prompt-depth-prefix . "#")
    (pc-ss-alist . nil)
    (pc-val . nil)
    (ppr-flat-right-margin . 40)
    (print-base . 10)
    (print-case . :upcase)
    (print-circle . nil)
    (print-circle-files . t) ; set to nil for #+gcl in LP
    (print-clause-ids . nil)
    (print-doc-start-column . 15)
    (print-escape . t)
    (print-length . nil)
    (print-level . nil)
    (print-lines . nil)
    (print-pretty . nil) ; default in Common Lisp is implementation dependent
    (print-radix . nil)
    (print-readably . nil)
    (print-right-margin . nil)
    (program-fns-with-raw-code . ,*primitive-program-fns-with-raw-code*)
    (prompt-function . default-print-prompt)
    (prompt-memo . nil)
    (proof-tree . nil)
    (proof-tree-buffer-width . ,*fmt-soft-right-margin-default*)
    (proof-tree-ctx . nil)
    (proof-tree-indent . "|  ")
    (proof-tree-start-printed . nil)
    (proofs-co . acl2-output-channel::standard-character-output-0)
    (raw-arity-alist . nil)
    (raw-include-book-dir-alist . :ignore)
    (raw-proof-format . nil)
    (redo-flat-fail . nil)
    (redo-flat-succ . nil)
    (redundant-with-raw-code-okp . nil)
    (retrace-p . nil)
    (safe-mode . nil)
    (save-expansion-file . nil)
    (saved-output-p . nil)
    (saved-output-reversed . nil)
    (saved-output-token-lst . nil)
    (serialize-character . nil)
    (serialize-character-system . nil) ; set for #+hons in LP
    (show-custom-keyword-hint-expansion . nil)
    (skip-notify-on-defttag . nil)
    (skip-proofs-by-system . nil)
    (skip-proofs-okp-cert . t) ; t when not inside certify-book
    (slow-array-action . :break) ; set to :warning in exit-boot-strap-mode
    (splitter-output . t)
    (standard-co . acl2-output-channel::standard-character-output-0)
    (standard-oi . acl2-output-channel::standard-object-input-0)
    (step-limit-record . nil)
    (system-books-dir . nil) ; set in enter-boot-strap-mode and perhaps lp
    (temp-touchable-fns . nil)
    (temp-touchable-vars . nil)
    (term-evisc-tuple . :default)
    (timer-alist . nil)
    (tmp-dir . nil) ; set by lp; user-settable but not much advertised.
    (total-parallelism-work-limit ; for #+acl2-par
     . ,(default-total-parallelism-work-limit))
    (total-parallelism-work-limit-error . t) ; for #+acl2-par
    (trace-co . acl2-output-channel::standard-character-output-0)
    (trace-level . 0)
    (trace-specs . nil)
    (triple-print-prefix . " ")
    (ttags-allowed . :all)
    (undone-worlds-kill-ring . (nil nil nil))

; By making the above list of nils be of length n you can arrange for ACL2 to
; save n worlds for undoing undos.  If n is 0, no undoing of undos is possible.
; If n is 1, the last undo can be undone.

    (user-home-dir . nil) ; set first time entering lp
    (verbose-theory-warning . t)
    (walkabout-alist . nil)
    (waterfall-parallelism . nil) ; for #+acl2-par
    (waterfall-parallelism-timing-threshold
     . 10000) ; #+acl2-par -- microsec limit for resource-and-timing-based mode
    (waterfall-printing . :full) ; for #+acl2-par
    (waterfall-printing-when-finished . nil) ; for #+acl2-par
    (window-interface-postlude
     . "#>\\>#<\\<e(acl2-window-postlude ?~sw ~xt ~xp)#>\\>")
    (window-interface-prelude
     . "~%#<\\<e(acl2-window-prelude ?~sw ~xc)#>\\>#<\\<~sw")
    (window-interfacep . nil)
    (wormhole-name . nil)
    (wormhole-status . nil)
    (write-acl2x . nil)
    (write-for-read . nil)
    (writes-okp . t)))

#+acl2-loop-only ; not during compilation
(value ; avoid value-triple, as state-global-let* is not yet defined in pass 1
 (or (ordered-symbol-alistp *initial-global-table*)
     (illegal 'top-level
              "*initial-global-table* is not an ordered-symbol-alistp!"
              nil)))

; Essay on Infix

; ACL2 has a hook for providing a different syntax.  We call this different
; syntax "infix" but it could be anything.  If the state global variable
; infixp is nil, ACL2 only supports CLTL syntax.  If infixp is non-nil
; then infix syntax may be used, depending on the context and the value of
; infixp.

; First, what is the "infix" syntax supported?  The answer is "a really stupid
; one."  In the built-in infix syntax, a well-formed expression is a dollar
; sign followed by a CLTL s-expression.  E.g., if infixp is t one must
; write $ (car (cdr '(a b c))) instead of just (car (cdr '(a b c))).  If
; infixp is t, the prover prints formulas by preceding them with a dollar
; sign.  This stupid syntax allows the ACL2 developers to test the infix
; hooks without having to invent and implement an new syntax.  Such testing
; has helped us identify places where, for example, we printed or read in
; one syntax when the other was expected by the user.

; However, we anticipate that users will redefine the infix primitives so as to
; implement interesting alternative syntax.  This note explains the primitives
; which must be redefined.  But first we discuss the values of the state
; global variable infixp.

; In addition to nil, infixp can be :in, :out or t (meaning both).  As noted,
; if infixp is nil, we use Common Lisp s-expression syntax.  If infixp is
; non-nil the syntax used depends on both infixp and on the context.  On
; printing, we use infix if infixp is t or :out.  On reading from the terminal,
; we expect infix if infixp is :in or t.  When reading from files (as in
; include-book) with infixp non-nil, we peek at the file and if it begins with

; (IN-PACKAGE "...

; optionally preceded by Lisp-style comments and whitespace, we use lisp
; syntax, otherwise infix.  The check is made with the raw Lisp function
; lisp-book-syntaxp.

; By allowing the :in and :out settings we allow users to type one and see the
; other.  We think this might help some users learn the other syntax.

; The following variable and functions, mostly defined in raw Lisp should be
; redefined to implement an alternative infix syntax.
;
; (defparameter *parse* ...)
; (defun parse-infix-from-terminal (eof) ...)
; (defun print-infix (x termp width rpc col file eviscp) ...)
; (defun print-flat-infix (x termp file eviscp) ...)
; (defun flatsize-infix (x termp j max state eviscp) ...)

; We document each of these when we define them for the silly $ syntax.

(defun all-boundp (alist1 alist2)
  (declare (xargs :guard (and (eqlable-alistp alist1)
                              (eqlable-alistp alist2))))
  (cond ((endp alist1) t)
        ((assoc (caar alist1) alist2)
         (all-boundp (cdr alist1) alist2))
        (t nil)))

(defun known-package-alistp (x)

; Keep this in sync with make-package-entry.

  (declare (xargs :guard t))
  (cond ((atom x) (null x))
        (t (and (true-listp (car x)) ; "final cdr" of book-path is a true-listp
                (stringp (car (car x)))         ; name
                (symbol-listp (cadr (car x)))   ; imports
                (known-package-alistp (cdr x))))))

(defthm known-package-alistp-forward-to-true-list-listp-and-alistp
  (implies (known-package-alistp x)
           (and (true-list-listp x)
                (alistp x)))
  :rule-classes :forward-chaining)

(defun timer-alistp (x)

; A timer-alistp is an alist binding symbols to lists of rationals.

  (declare (xargs :guard t))
  (cond ((atom x) (equal x nil))
        ((and (consp (car x))
              (symbolp (caar x))
              (rational-listp (cdar x)))
         (timer-alistp (cdr x)))
        (t nil)))

(defthm timer-alistp-forward-to-true-list-listp-and-symbol-alistp
  (implies (timer-alistp x)
           (and (true-list-listp x)
                (symbol-alistp x)))
  :rule-classes :forward-chaining)

(defun typed-io-listp (l typ)
  (declare (xargs :guard t))
  (cond ((atom l) (equal l nil))
        (t (and (case typ
                      (:character (characterp (car l)))
                      (:byte (and (integerp (car l))
                                  (<= 0 (car l))
                                  (< (car l) 256)))
                      (:object t)
                      (otherwise nil))
                (typed-io-listp (cdr l) typ)))))

(defthm typed-io-listp-forward-to-true-listp
  (implies (typed-io-listp x typ)
           (true-listp x))
  :rule-classes :forward-chaining)

(defconst *file-types* '(:character :byte :object))

(defun open-channel1 (l)
  (declare (xargs :guard t))
  (and (true-listp l)
       (consp l)
       (let ((header (car l)))
         (and
          (true-listp header)
          (equal (length header) 4)
          (eq (car header) :header)
          (member-eq (cadr header) *file-types*)
          (stringp (caddr header))
          (integerp (cadddr header))
          (typed-io-listp (cdr l) (cadr header))))))

(defthm open-channel1-forward-to-true-listp-and-consp
  (implies (open-channel1 x)
           (and (true-listp x)
                (consp x)))
  :rule-classes :forward-chaining)

(defun open-channel-listp (l)

; The following guard seems reasonable (and is certainly necessary, or at least
; some guard is) since open-channels-p will tell us that we're looking at an
; ordered-symbol-alistp.

  (declare (xargs :guard (alistp l)))

  (if (endp l)
      t
    (and (open-channel1 (cdr (car l)))
         (open-channel-listp (cdr l)))))

(defun open-channels-p (x)
  (declare (xargs :guard t))
  (and (ordered-symbol-alistp x)
       (open-channel-listp x)))

(defthm open-channels-p-forward
  (implies (open-channels-p x)
           (and (ordered-symbol-alistp x)
                (true-list-listp x)))
  :rule-classes :forward-chaining)

(defun file-clock-p (x)
  (declare (xargs :guard t))
  (natp x))

(defthm file-clock-p-forward-to-integerp
  (implies (file-clock-p x)
           (natp x))
  :rule-classes :forward-chaining)

(defun readable-file (x)
  (declare (xargs :guard t))
  (and (true-listp x)
       (consp x)
       (let ((key (car x)))
         (and (true-listp key)
              (equal (length key) 3)
              (stringp (car key))
              (member (cadr key) *file-types*)
              (integerp (caddr key))
              (typed-io-listp (cdr x) (cadr key))))))

(defthm readable-file-forward-to-true-listp-and-consp
  (implies (readable-file x)
           (and (true-listp x)
                (consp x)))
  :rule-classes :forward-chaining)

(defun readable-files-listp (x)
  (declare (xargs :guard t))
  (cond ((atom x) (equal x nil))
        (t (and (readable-file (car x))
                (readable-files-listp (cdr x))))))

(defthm readable-files-listp-forward-to-true-list-listp-and-alistp
  (implies (readable-files-listp x)
           (and (true-list-listp x)
                (alistp x)))
  :rule-classes :forward-chaining)

(defun readable-files-p (x)
  (declare (xargs :guard t))
  (readable-files-listp x))

(defthm readable-files-p-forward-to-readable-files-listp
  (implies (readable-files-p x)
           (readable-files-listp x))
  :rule-classes :forward-chaining)

(defun written-file (x)
  (declare (xargs :guard t))
  (and (true-listp x)
       (consp x)
       (let ((key (car x)))
         (and (true-listp key)
              (equal (length key) 4)
              (stringp (car key))
              (integerp (caddr key))
              (integerp (cadddr key))
              (member (cadr key) *file-types*)
              (typed-io-listp (cdr x) (cadr key))))))

(defthm written-file-forward-to-true-listp-and-consp
  (implies (written-file x)
           (and (true-listp x)
                (consp x)))
  :rule-classes :forward-chaining)

(defun written-file-listp (x)
  (declare (xargs :guard t))
  (cond ((atom x) (equal x nil))
        (t (and (written-file (car x))
                (written-file-listp (cdr x))))))

(defthm written-file-listp-forward-to-true-list-listp-and-alistp
  (implies (written-file-listp x)
           (and (true-list-listp x)
                (alistp x)))
  :rule-classes :forward-chaining)

(defun written-files-p (x)
  (declare (xargs :guard t))
  (written-file-listp x))

(defthm written-files-p-forward-to-written-file-listp
  (implies (written-files-p x)
           (written-file-listp x))
  :rule-classes :forward-chaining)

(defun read-file-listp1 (x)
  (declare (xargs :guard t))
  (and (true-listp x)
       (equal (length x) 4)
       (stringp (car x))
       (member (cadr x) *file-types*)
       (integerp (caddr x))
       (integerp (cadddr x))))

(defthm read-file-listp1-forward-to-true-listp-and-consp
  (implies (read-file-listp1 x)
           (and (true-listp x)
                (consp x)))
  :rule-classes :forward-chaining)

(defun read-file-listp (x)
  (declare (xargs :guard t))
  (cond ((atom x) (equal x nil))
        (t (and (read-file-listp1 (car x))
                (read-file-listp (cdr x))))))

(defthm read-file-listp-forward-to-true-list-listp
  (implies (read-file-listp x)
           (true-list-listp x))
  :rule-classes :forward-chaining)

(defun read-files-p (x)
  (declare (xargs :guard t))
  (read-file-listp x))

(defthm read-files-p-forward-to-read-file-listp
  (implies (read-files-p x)
           (read-file-listp x))
  :rule-classes :forward-chaining)

(defun writable-file-listp1 (x)
  (declare (xargs :guard t))
  (and (true-listp x)
       (equal (length x) 3)
       (stringp (car x))
       (member (cadr x) *file-types*)
       (integerp (caddr x))))

(defthm writable-file-listp1-forward-to-true-listp-and-consp
  (implies (writable-file-listp1 x)
           (and (true-listp x)
                (consp x)))
  :rule-classes :forward-chaining)

(defun writable-file-listp (x)
  (declare (xargs :guard t))
  (cond ((atom x) (equal x nil))
        (t (and (writable-file-listp1 (car x))
                (writable-file-listp (cdr x))))))

(defthm writable-file-listp-forward-to-true-list-listp
  (implies (writable-file-listp x)
           (true-list-listp x))
  :rule-classes :forward-chaining)

(defun writeable-files-p (x)
  (declare (xargs :guard t))
  (writable-file-listp x))

(defthm writeable-files-p-forward-to-writable-file-listp
  (implies (writeable-files-p x)
           (writable-file-listp x))
  :rule-classes :forward-chaining)

(defun state-p1 (x)
  (declare (xargs :guard t))
  #-acl2-loop-only
  (cond ((live-state-p x)
         (return-from state-p1 t)))
  (and (true-listp x)
       (equal (length x) 15)
       (open-channels-p (open-input-channels x))
       (open-channels-p (open-output-channels x))
       (ordered-symbol-alistp (global-table x))
       (all-boundp *initial-global-table*
                   (global-table x))
       (plist-worldp (cdr (assoc 'current-acl2-world (global-table x))))
       (symbol-alistp
        (getprop 'acl2-defaults-table 'table-alist nil
                 'current-acl2-world
                 (cdr (assoc 'current-acl2-world (global-table x)))))
       (timer-alistp (cdr (assoc 'timer-alist (global-table x))))
       (known-package-alistp
        (getprop 'known-package-alist 'global-value nil
                 'current-acl2-world
                 (cdr (assoc 'current-acl2-world (global-table x)))))
       (true-listp (t-stack x))
       (32-bit-integer-listp (32-bit-integer-stack x))
       (integerp (big-clock-entry x))
       (integer-listp (idates x))
       (true-listp (acl2-oracle x))
       (file-clock-p (file-clock x))
       (readable-files-p (readable-files x))
       (written-files-p (written-files x))
       (read-files-p (read-files x))
       (writeable-files-p (writeable-files x))
       (true-list-listp (list-all-package-names-lst x))
       (symbol-alistp (user-stobj-alist1 x))))

(defthm state-p1-forward
  (implies (state-p1 x)
           (and
            (true-listp x)
            (equal (length x) 15)
            (open-channels-p (nth 0 x))
            (open-channels-p (nth 1 x))
            (ordered-symbol-alistp (nth 2 x))
            (all-boundp *initial-global-table*
                        (nth 2 x))
            (plist-worldp (cdr (assoc 'current-acl2-world (nth 2 x))))
            (symbol-alistp
             (getprop 'acl2-defaults-table 'table-alist nil
                      'current-acl2-world
                      (cdr (assoc 'current-acl2-world (nth 2 x)))))
            (timer-alistp (cdr (assoc 'timer-alist (nth 2 x))))
            (known-package-alistp
             (getprop 'known-package-alist 'global-value nil
                      'current-acl2-world
                      (cdr (assoc 'current-acl2-world (nth 2 x)))))
            (true-listp (nth 3 x))
            (32-bit-integer-listp (nth 4 x))
            (integerp (nth 5 x))
            (integer-listp (nth 6 x))
            (true-listp (nth 7 x))
            (file-clock-p (nth 8 x))
            (readable-files-p (nth 9 x))
            (written-files-p (nth 10 x))
            (read-files-p (nth 11 x))
            (writeable-files-p (nth 12 x))
            (true-list-listp (nth 13 x))
            (symbol-alistp (nth 14 x))))
  :rule-classes :forward-chaining
  ;; The hints can speed us up from over 40 seconds to less than 2.
  :hints (("Goal" :in-theory
           (disable nth length open-channels-p ordered-symbol-alistp
                    all-boundp plist-worldp assoc timer-alistp
                    known-package-alistp true-listp
                    32-bit-integer-listp integer-listp rational-listp
                    file-clock-p readable-files-p written-files-p
                    read-files-p writeable-files-p true-list-listp
                    symbol-alistp))))

(defun state-p (state-state)
  (declare (xargs :guard t))
  (state-p1 state-state))

; Let us use state-p1 in our theorem-proving.
(in-theory (disable state-p1))

; The following could conceivably be useful before rewriting a literal
; containing state-p.

(defthm state-p-implies-and-forward-to-state-p1
  (implies (state-p state-state)
           (state-p1 state-state))
  :rule-classes (:forward-chaining :rewrite))

; On STATE-STATE

; No one should imagine calling any of the state accessors or updaters
; in executable code.  These fields are all ``magic'' in some sense,
; in that they don't actually exist -- or, to put it more accurately,
; we do not represent them concretely as the ACL2 objects we alleged
; them to be in the axioms.  In some cases, we might have gone to the
; trouble of supporting these things, at considerable cost, e.g.
; keeping a giant list of all characters printed this year or code to
; recover the logical value of written-files (which shows the times at
; which channels to files were opened and closed) from the actual file
; system.  In other cases, such as big-clock-entry, the cost of
; support would have been intuitively equivalent to infinite: no ACL2.

; The user should be grateful that he can even indirectly access these
; fields at all in executable code, and should expect to study the
; means of access with excruciating pain and care.  Although the
; fields of states may be THOUGHT of as ordinary logical objects (e.g.
; in theorems), the severe restriction on runtime access to them is
; the PRICE ONE PAYS for (a) high efficiency and (b) real-time
; effects.

; How do we prevent the user from applying, say, written-files, to the
; live state?  Well, that is pretty subtle.  We simply make the formal
; parameter to written-files be ST rather than STATE.  Translate
; enforces the rule that a function may receive STATE only in a slot
; whose STOBJS-IN flag is STATE.  And, with only one exception, the
; STOBJS-IN setting is always calculated by noting which formal is
; called STATE.  So by giving written-files ST and never resetting its
; STOBJS-IN, we prevent it from being fed the live state (or any
; state) in code (such as defuns and top-level commands) where we are
; checking the use of state.  (In theorems, anything goes.)  As noted,
; this is the price one pays.

; So what is the exception to the rule that (the STATE flag in)
; STOBJS-IN is determined by STATE's position?  The exception is
; managed by super-defun-wart and is intimately tied up with the use
; of STATE-STATE.  The problem is that even though we don't permit
; written-files to be called by the user, we wish to support some
; functions (like close-output-channel) which do take state as an
; argument, which may be called by the user and which -- logically
; speaking -- are defined in terms of written-files.

; So consider close-output-channel.  We would like to make its second
; parameter be STATE.  But it must pass that parameter down to
; written-files in the logical code that defines close-output-channel.
; If that happened, we would get a translate error upon trying to
; define close-output-channel, because we would be passing STATE into
; a place (namely ST) where no state was allowed.  So we use
; STATE-STATE instead.  But while that lets close-output-channel be
; defined, it doesn't let the user apply it to state.  However, after
; the definitional principle has translated the body and during the
; course of its storage of the many properties of the newly defined
; function, it calls super-defun-wart which asks "is this one of the
; special functions I was warned about?"  If so, it sets STOBJS-IN and
; STOBJS-OUT for the function properly.  A fixed number of functions
; are so built into super-defun-wart, which knows the location of the
; state-like argument and value for each of them.  Once
; super-defun-wart has done its job, state must be supplied to
; close-output-channel, where expected.

; "But," you ask, "if state is supplied doesn't it find its way down
; to written-files and then cause trouble because written files isn't
; expecting the live state?"  Yes, it would cause trouble if it ever
; got there, but it doesn't.  Because for each of the functions that
; use STATE-STATE and are known to super-defun-wart, we provide raw
; lisp code to do the real work.  That is, there are two definitions
; of close-output-channel.  One, the logical one, is read in
; #+acl2-loop-only mode and presents the prissy logical definition in
; terms of written-files.  This definition gets processed during our
; system initialization and generates the usual properties about a
; defined function that allow us to do theorem proving about the
; function.  The other, in #-acl2-loop-only, is raw Lisp that knows
; how to close a channel when its given one in the live state.

; So the convention is that those functions (all defined in
; axioms.lisp) which (a) the user is permitted to call with real
; states but which (b) can only be logically defined in terms of calls
; to the primitive state accessors and updaters are (i) defined with
; STATE-STATE as a formal parameter, (ii) have their property list
; smashed appropriately for STOBJS-IN and STOBJS-OUT right after
; their admission, to reflect their true state character, and (iii)
; are operationally defined with raw lisp at some level between the
; defun and the use of the primitive state accessors and updaters.

;  We need the following theorem to make sure that we cannot introduce
;  via build-state something that fails to be a state.

(defmacro build-state
  (&key open-input-channels open-output-channels global-table t-stack
        32-bit-integer-stack (big-clock '4000000) idates acl2-oracle
        (file-clock '1) readable-files written-files
        read-files writeable-files list-all-package-names-lst
        user-stobj-alist)
  (list 'build-state1
        (list 'quote open-input-channels)
        (list 'quote open-output-channels)
        (list 'quote (or global-table
                         *initial-global-table*))
        (list 'quote t-stack)
        (list 'quote 32-bit-integer-stack)
        (list 'quote big-clock)
        (list 'quote idates)
        (list 'quote acl2-oracle)
        (list 'quote file-clock)
        (list 'quote readable-files)
        (list 'quote written-files)
        (list 'quote read-files)
        (list 'quote writeable-files)
        (list 'quote list-all-package-names-lst)
        (list 'quote user-stobj-alist)))

(defconst *default-state*
  (list nil nil
        *initial-global-table*
        nil nil 4000000 nil nil 1 nil nil nil nil nil nil))

(defun build-state1 (open-input-channels
   open-output-channels global-table t-stack 32-bit-integer-stack big-clock
   idates acl2-oracle file-clock readable-files written-files
   read-files writeable-files list-all-package-names-lst user-stobj-alist)
  (declare (xargs :guard (state-p1 (list open-input-channels
   open-output-channels global-table t-stack 32-bit-integer-stack big-clock
   idates acl2-oracle file-clock readable-files written-files
   read-files writeable-files list-all-package-names-lst
   user-stobj-alist))))

; The purpose of this function is to provide a means for constructing
; a state other than the live state.

  (let ((s
         (list open-input-channels open-output-channels global-table
               t-stack 32-bit-integer-stack big-clock idates acl2-oracle
               file-clock readable-files written-files
               read-files writeable-files list-all-package-names-lst
               user-stobj-alist)))
    (cond ((state-p1 s)
           s)
          (t *default-state*))))

; Although the two following functions are only identity functions
; from the logical point of view, in the von Neumann machinery
; implementation they are potentially dangerous and should not
; be used anywhere besides trans-eval.

(defun coerce-state-to-object (x)
  (declare (xargs :guard t))
  x)

(defun coerce-object-to-state (x)
  (declare (xargs :guard t))
  x)

(verify-termination-boot-strap create-state)


;                              GLOBALS

#-acl2-loop-only
(defun-one-output strip-numeric-postfix (sym)
  (coerce
   (reverse (do ((x (reverse (coerce (symbol-name sym) 'list)) (cdr x)))
                ((or (null x)
                     (eq (car x) #\-))
                 (cdr x))))
   'string))

(defun global-table-cars1 (state-state)

; Wart: We use state-state instead of state because of a bootstrap problem.

  (declare (xargs :guard (state-p1 state-state)))
  #-acl2-loop-only
  (cond ((live-state-p state-state)
         (return-from
          global-table-cars1
          (let (ans)
            (dolist (package-entry
                     (global-val 'known-package-alist (w *the-live-state*)))
                    (do-symbols (sym (find-package
                                      (concatenate 'string
                                                   *global-package-prefix*
                                                   (package-entry-name
                                                    package-entry))))
                                (cond ((boundp sym)
                                       (push (intern (symbol-name sym)
                                                     (package-entry-name
                                                      package-entry))
                                             ans)))))
            (sort ans (function symbol-<))))))
  (strip-cars (global-table state-state)))

(defun global-table-cars (state-state)

; Wart: We use state-state instead of state because of a bootstrap problem.

  (declare (xargs :guard (state-p1 state-state)))
  (global-table-cars1 state-state))

(defun boundp-global1 (x state-state)
  (declare (xargs :guard (and (symbolp x)
                              (state-p1 state-state))))
  #-acl2-loop-only
  (cond ((live-state-p state-state)
         (return-from boundp-global1 (boundp (global-symbol x)))))
  (cond ((assoc x (global-table state-state)) t)
        (t nil)))

(defun boundp-global (x state-state)

; Wart: We use state-state instead of state because of a bootstrap problem.

  (declare (xargs :guard (and (symbolp x)
                              (state-p1 state-state))))
  (boundp-global1 x state-state))

(defmacro f-boundp-global (x st)
  #-acl2-loop-only
  (cond ((and (consp x)
              (eq 'quote (car x))
              (symbolp (cadr x))
              (null (cddr x)))
         (let ((s (gensym)))
           `(let ((,s ,st))
              (declare (special ,(global-symbol (cadr x))))
              (cond ((eq ,s *the-live-state*)
                     (boundp ',(global-symbol (cadr x))))
                    (t (boundp-global ,x ,s))))))
        (t `(boundp-global ,x ,st)))
  #+acl2-loop-only
  (list 'boundp-global x st))

(defun makunbound-global (x state-state)

; Wart: We use state-state instead of state because of a bootstrap problem.

; This function is not very fast because it calls global-symbol.  A
; faster version could easily be created.

  (declare (xargs :guard (and (symbolp x)
                              (state-p1 state-state))))
  #-acl2-loop-only
  (cond ((live-state-p state-state)
         (cond (*wormholep*
                (cond
                 ((boundp-global1 x state-state)

; If the variable is not bound, then the makunbound below doesn't do
; anything and we don't have to save undo information.  (Furthermore,
; there is nothing to save.)

                  (push-wormhole-undo-formi 'put-global x
                                            (get-global x state-state))))))
         (makunbound (global-symbol x))
         (return-from makunbound-global *the-live-state*)))
  (update-global-table (delete-assoc-eq
                        x
                        (global-table state-state))
                       state-state))

#+acl2-loop-only
(defun get-global (x state-state)

; Wart: We use state-state instead of state because of a bootstrap problem.

; Keep this in sync with the #+acl2-loop-only definition of get-global (which
; uses qfuncall).

  (declare (xargs :guard (and (symbolp x)
                              (state-p1 state-state)
                              (boundp-global1 x state-state))))
  (cdr (assoc x (global-table state-state))))

(defun put-global (key value state-state)

; Wart: We use state-state instead of state because of a bootstrap problem.

  (declare (xargs :guard (and (symbolp key)
                              (state-p1 state-state))))
  #-acl2-loop-only
  (cond ((live-state-p state-state)
         (cond (*wormholep*
                (cond ((boundp-global1 key state-state)
                       (push-wormhole-undo-formi 'put-global key
                                                 (get-global key state-state)))
                      (t
                       (push-wormhole-undo-formi 'makunbound-global key nil)))))
         (setf (symbol-value (global-symbol key)) value)
         (return-from put-global state-state)))
  (update-global-table
   (add-pair key value
             (global-table state-state))
   state-state))

(defmacro f-put-global (key value st)

  ":Doc-Section ACL2::ACL2-built-ins

  assign to a global variable in ~ilc[state]~/
  ~bv[]
  Examples:
  (f-put-global 'x (expt 2 10) state)
  (f-put-global 'a (aset1 'ascii-map-array (@ a) 66 'Upper-case-B) state)~/

  General Form:
  (f-put-global (quote symbol) term state)
  ~ev[]
  where ~c[symbol] is any symbol (with certain enforced exclusions to
  avoid overwriting ACL2 system ``globals'') and ~c[term] is any ACL2
  term that could be evaluated at the top-level.  ~c[F-put-global] evaluates
  the term, stores the result as the value of the given symbol in the
  ~c[global-table] of ~ilc[state], and returns the new ~c[state].  (Note:  the
  actual implementation of the storage of this value is much more
  efficient than this discussion of the logic might suggest.)

  The macro ~ilc[assign] is closely related to ~c[f-put-global]:
  ~c[(assign var val)] macroexpands to ~c[(f-put-global 'var val state)].

  The macros ~ilc[@] and ~ilc[f-get-global] give convenient access to the value
  of such globals.  The ~c[:]~ilc[ubt] operation has no effect on the
  ~c[global-table] of ~ilc[state].  Thus, you may use these globals to hang
  onto useful data structures even though you may undo back past where you
  computed and saved them.~/"

  #-acl2-loop-only
  (cond ((and (consp key)
              (eq 'quote (car key))
              (symbolp (cadr key))
              (null (cddr key)))
         (let ((v (gensym))
               (s (gensym)))
           `(let ((,v ,value)
                  (,s ,st))
              (cond ((live-state-p ,s)
                     (cond
                      (*wormholep*
                       (cond
                        ((boundp-global1 ,key ,s)
                         (push-wormhole-undo-formi 'put-global ,key
                                                   (get-global ,key ,s)))
                        (t
                         (push-wormhole-undo-formi 'makunbound-global
                                                   ,key
                                                   nil)))))
                     (let ()
                       (declare (special ,(global-symbol (cadr key))))
                       ,@(when (eq (cadr key) 'acl2-raw-mode-p)
                           `((observe-raw-mode-setting ,v ,s)))
                       (setq ,(global-symbol (cadr key))
                             ,v)
                       ,s))
                    (t (put-global ,key ,v ,s))))))
        (t `(put-global ,key ,value ,st)))
  #+acl2-loop-only
  (list 'put-global key value st))

#+acl2-par
(defmacro f-put-global@par (key value st)

; WARNING: Every use of this macro deserves an explanation that addresses the
; following concern!  This macro is used to modify the live ACL2 state, without
; passing state back!  This is particularly dangerous if we are calling
; f-put-global@par in two threads that are executing concurrently, since the
; second use will override the first.

  (declare (ignorable key value st))
  #+acl2-loop-only
  nil
  #-acl2-loop-only
  `(progn (f-put-global ,key ,value ,st)
          nil))

; We now define state-global-let*, which lets us "bind" state
; globals.

(defconst *initial-ld-special-bindings*

; This alist is used by initialize-acl2 to set the initial values of the LD
; specials.  It is assumed by reset-ld-specials that the first three are the
; channels.

  `((standard-oi . ,*standard-oi*)
    (standard-co . ,*standard-co*)
    (proofs-co . ,*standard-co*)
    (ld-skip-proofsp . nil)
    (ld-redefinition-action . nil)
    (ld-prompt . t)
    (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 . :continue)
    (ld-query-control-alist . nil)
    (ld-verbose . "~sv.  Level ~Fl.  Cbd ~xc.~|System books ~
                   directory ~xb.~|Type :help for help.~%Type (good-bye) to ~
                   quit completely out of ACL2.~|~%")))

(defun always-boundp-global (x)
  (declare (xargs :guard (symbolp x)))
  (or (assoc-eq x
                *initial-global-table*)
      (assoc-eq x
                *initial-ld-special-bindings*)))

(defun state-global-let*-bindings-p (lst)

; This function returns t iff lst is a true-list and each element is
; a doublet of the form (symbolp anything) or a triplet of the form (symbolp
; anything symbolp).

  (declare (xargs :guard t))
  (cond ((atom lst) (eq lst nil))
        (t (and (consp (car lst))
                (symbolp (caar lst))
                (consp (cdar lst))
                (or (null (cddar lst))
                    (and (consp (cddar lst))
                         (symbolp (car (cddar lst)))
                         (null (cdr (cddar lst)))))
                (state-global-let*-bindings-p (cdr lst))))))

(defun state-global-let*-get-globals (bindings)

; This function is used to generate code for the macroexpansion of
; state-global-let*.  Roughly speaking, it returns a list, lst, of f-get-global
; forms that fetch the values of the variables we are about to smash.  The
; expansion of state-global-let* will start with (LET ((temp (LIST ,@lst)))
; ...) and we will use the value of temp to restore the globals after the
; execution of the body.

; Now there is a subtlety.  Some of the vars we are to "bind" might NOT be
; already bound in state.  So we don't want to call f-get-global on them until
; we know they are bound, and for those that are not, "restoring" their old
; values means making them unbound again.  So a careful specification of the
; value of temp (i.e., the value of (LIST ,@lst) where lst is what we are
; producing here) is that it is a list in 1:1 correspondence with the vars
; bound in bindings such that the element corresponding to the var x is nil if
; x is unbound in the pre-body state and is otherwise a singleton list
; containing the value of x in the pre-body state.

  (declare (xargs :guard (state-global-let*-bindings-p bindings)))
  (cond ((endp bindings) nil)
        (t (cons
            (if (always-boundp-global (caar bindings))
                `(list (f-get-global ',(caar bindings) state))
              `(if (f-boundp-global ',(caar bindings) state)
                   (list (f-get-global ',(caar bindings) state))
                 nil))
            (state-global-let*-get-globals (cdr bindings))))))

(defun state-global-let*-put-globals (bindings)

; This function is used to generate code for the macroexpansion of
; state-global-let*.  It generates a list of f-put-globals that will set the
; bound variables in bindings to their desired local values, except that
; ``setters'' are used instead where provided (see the discussion of setters in
; state-global-let*).  We insist that those initialization forms not mention
; the temporary variable state-global-let* uses to hang onto the restoration
; values.

  (declare (xargs :guard (state-global-let*-bindings-p bindings)))
  (cond ((endp bindings) nil)
        (t (cons (let ((val-form `(check-vars-not-free
                                   (state-global-let*-cleanup-lst)
                                   ,(cadar bindings))))
                   (cond ((cddr (car bindings))
                          `(if (f-boundp-global ',(caar bindings) state)
                               (,(caddr (car bindings)) ; setter
                                ,val-form
                                state)
                             (prog2$
                              (er hard 'state-global-let*
                                  "It is illegal to bind an unbound variable ~
                                   in state-global-let*, in this case, ~x0, ~
                                   when a setter function is supplied."
                                  ',(caar bindings))
                              state)))
                         (t
                          `(f-put-global ',(caar bindings)
                                         ,val-form
                                         state))))
                 (state-global-let*-put-globals (cdr bindings))))))

(defun state-global-let*-cleanup (bindings index)

; This function is used to generate code for the macroexpansion of
; state-global-let*.  We generate a list of forms that when executed will
; restore the "bound" variables to their original values, using the list of
; restoration values.  Recall that each restoration value is either a nil,
; indicating the variable was unbound, or a singleton listing the original
; value.  We are generating that code.  Index is the number of CDRs to be taken
; of the restoration values list that begins with the value for the first
; variable in bindings.  It is initially 0, to represent the temporary variable
; used by state-global-let*, and is incremented by 1 on each call so that the
; restoration values list is symbolically CDRd ever time we recurse here.

; Note: Once upon a time we used a recursive function to do the cleanup.  It
; essentially swept through the names of the state globals as it swept through
; the list of their initial values and did an f-put-global on each (here
; ignoring the unbound variable problem).  That was dangerous because it
; violated the rules that f-put-global was only called on a quoted var.  Those
; rules allow translate to enforce untouchables.  To get away with it, we had
; to exempt that function from translate's restrictions on f-put-global.  We
; thought we could regain security by then putting that function name on
; untouchables.  But since calls to that function were laid down in macros, it
; can't be untouchable if the user is to use the macros.  So we did it this
; way, which makes each f-put-global explicit and needs no special treatment.

; Finally, note that we use setters in place of f-put-global, when they are
; provided; see the discussion of setters in state-global-let*.

  (declare (xargs :guard (and (state-global-let*-bindings-p bindings)
                              (natp index))))
  (let ((cdr-expr 'state-global-let*-cleanup-lst))
    (cond ((endp bindings) nil)
          (t (cons (cond
                    ((cddr (car bindings))
                     `(,(caddr (car bindings))
                       (car (nth ,index ,cdr-expr))
                       state))
                    ((always-boundp-global (caar bindings))
                     `(f-put-global ',(caar bindings)
                                    (car (nth ,index ,cdr-expr))
                                    state))
                    (t
                     `(if (nth ,index ,cdr-expr)
                          (f-put-global ',(caar bindings)
                                        (car (nth ,index ,cdr-expr))
                                        state)
                        (makunbound-global ',(caar bindings) state))))
                   (state-global-let*-cleanup (cdr bindings)
                                              (1+ index)))))))

#+(and acl2-par (not acl2-loop-only))
(defparameter *possible-parallelism-hazards*

; If *possible-parallelism-hazards* is non-nil and state global
; 'parallelism-hazards-action is non-nil, then any operation known to cause
; problems in a parallel environment will print a warning (and maybe cause an
; error).  For example, we know that calling state-global-let* in any
; environment where parallel execution is enabled could cause problems.  See
; the use of with-parallelism-hazard-warnings inside waterfall and the use of
; warn-about-parallelism-hazard inside state-global-let* for how we warn the
; user of such potential pitfalls.

; Note that the ACL2 developer is not anticipated to set and clear this
; variable with a call like "setf" -- this should probably be done by using
; with-parallelism-hazard-warnings.

; Here is a simple example that demonstrates their use:

;   (set-state-ok t)

;   (skip-proofs
;    (defun foo (state)
;      (declare (xargs :guard t))
;      (state-global-let*
;       ((x 3))
;       (value (f-get-global 'x state)))))

;   (skip-proofs
;    (defun bar (state)
;      (declare (xargs :guard t))
;      (with-parallelism-hazard-warnings
;       (foo state))))

;   (set-waterfall-parallelism :full)

;   (bar state) ; prints the warning

; See also the comment in warn-about-parallelism-hazard for a detailed
; specification of how this all works.

  nil)

(defmacro with-parallelism-hazard-warnings (body)

; See the comment in warn-about-parallelism-hazard.

  #+(and acl2-par (not acl2-loop-only))
  `(let ((*possible-parallelism-hazards* t))
     ,body)
  #-(and acl2-par (not acl2-loop-only))
  body)

(defmacro warn-about-parallelism-hazard (call body)

; This macro can cause a warning or error if raw Lisp global
; *possible-parallelism-hazards* is bound to t or :error, respectively.  Such
; binding takes place with a call of with-parallelism-hazard-warnings.  This
; macro is essentially a no-op when not in the scope of such a call, since
; *possible-parallelism-hazards* is nil by default.

; It is the programmer's responsibility to wrap this macro around any code (or
; callers that lead to such code) that can result in any "bad" behavior due to
; executing that code in a multi-threaded setting.  For example, we call this
; macro in state-global-let*, which we know can be unsafe to execute in
; parallel with other state-modifying code.  And that's a good thing, since for
; example state-global-let* is called by wormhole printing, which is invoked by
; the code (io? prove t ...) in waterfall-msg when parallelism is enabled.

; Recall the first paragraph above.  Thus, state-global-let* does not cause any
; such warning or error by default, which is why in a #+acl2-par build, there
; is a call of with-parallelism-hazard-warnings in waterfall.

  #-(and acl2-par (not acl2-loop-only))
  (declare (ignore call))
  #+(and acl2-par (not acl2-loop-only))
  `(progn
     (when (and *possible-parallelism-hazards*
                (f-get-global 'waterfall-parallelism state)
                (f-get-global 'parallelism-hazards-action *the-live-state*))

; If a user sends an "offending call" as requested in the email below, consider
; adding a parallelism wart in the definition of the function being called,
; documenting that a user has actually encountered an execution of ACL2(p) that
; ran a function that we have indentified as not thread-safe (via
; warn-about-parallelism-hazard) inside a context that we have identified as
; eligible for parallel execution (via with-parallelism-hazard-warnings).  (Or
; better yet, make a fix.)  See the comments at the top of this function for
; more explanation.

       (format t
               "~%WARNING: A macro or function has been called that is not~%~
                thread-safe.  Please email this message, including the~%~
                offending call and call history just below, to the ACL2 ~%~
                implementors.~%")
       (let ((*print-length* 10)
             (*print-level* 10))
         (pprint ',call)
         (print-call-history))
       (format t
               "~%~%To disable the above warning, issue the form:~%~%~
                ~s~%~%"
               '(f-put-global 'parallelism-hazards-action nil state))
       (when (eq (f-get-global 'parallelism-hazards-action *the-live-state*)
                 :error)
         (error "Encountered above parallelism hazard")))
     ,body)
  #-(and acl2-par (not acl2-loop-only))
  body)

(defmacro with-ensured-parallelism-finishing (form)
  #+(or acl2-loop-only (not acl2-par))
  form
  #-(or acl2-loop-only (not acl2-par))
  `(our-multiple-value-prog1
    ,form
    (loop while (futures-still-in-flight)
          as i from 1
          do
          (progn (when (eql (mod i 10) 5)
                   (cw "Waiting for all proof threads to finish~%"))
                 (sleep 0.1)))))

(defmacro state-global-let* (bindings body)

; NOTE: In April 2010 we discussed the possibility that we could simplify the
; raw-Lisp code for state-global-let* to avoid acl2-unwind-protect, in favor of
; let*-binding the state globals under the hood so that clean-up is done
; automatically by Lisp; after all, state globals are special variables.  We
; see no reason why this can't work, but we prefer not to mess with this very
; stable code unless/until there is a reason.  (Note that we however do not
; have in mind any potential change to the logic code for state-global-let*.)
; See state-free-global-let* for such a variant that is appropriate to use when
; state is not available.

  ":Doc-Section ACL2::ACL2-built-ins

  bind ~il[state] global variables~/

  ~l[programming-with-state] for requisite background on programming with the
  ACL2 ~il[state].

  ~bv[]
  Example Forms:
  (state-global-let*
   ((inhibit-output-lst *valid-output-names*))
   (thm (equal x x)))

  (state-global-let*
   ((fmt-hard-right-margin 1000 set-fmt-hard-right-margin)
    (fmt-soft-right-margin 1000 set-fmt-soft-right-margin))
   (mini-proveall))~/

  General Form:
  (state-global-let* ((var1 form1) ; or (var1 form1 set-var1)
                      ...
                      (vark formk) ; or (vark formk set-vark)
                     )
                     body)
  ~ev[]
  where: each ~c[vari] is a variable; each ~c[formi] is an expression whose
  value is a single ordinary object (i.e. not multiple values, and not
  ~il[state] or any other ~il[stobj]); ~c[set-vari], if supplied, is a function
  with ~il[signature] ~c[((set-vari * state) => state)]; and ~c[body] is an
  expression that evaluates to an error triple (~pl[error-triples]).  Each
  ~c[formi] is evaluated in order, starting with ~c[form1], and with each such
  binding the state global variable ~c[vari] is bound to the value of
  ~c[formi], sequentially in the style of ~ilc[let*].  More precisely, then
  meaning of this form is to set (in order) the global values of the indicated
  ~il[state] global variables ~c[vari] to the values of ~c[formi] using
  ~ilc[f-put-global], execute ~c[body], restore the ~c[vari] to their previous
  values (but see the discussion of setters below), and return the triple
  produced by body (with its state as modified by the restoration).  The
  restoration is guaranteed even in the face of aborts.  The ``bound''
  variables may initially be unbound in state and restoration means to make
  them unbound again.

  Still referring to the General Form above, let ~c[old-vali] be the value of
  state global variable ~c[vari] at the time ~c[vari] is about to be assigned
  the value of ~c[formi].  If ~c[set-vari] is not supplied, then as suggested
  above, the following form is evaluated at the conclusion of the evaluation of
  the ~c[state-global-let*] form, whether or not an error has occurred:
  ~c[(f-put-global 'vari 'old-vali state)].  However, if ~c[set-vari] is
  supplied, then instead the form evaluated will be
  ~c[(set-vari 'old-vali state)].  This capability is particularly useful if
  ~c[vari] is untouchable (~pl[push-untouchable]), since the above call of
  ~ilc[f-put-global] is illegal.

  Note that the scope of the bindings of a ~c[state-global-let*] form is the
  body of that form.  This may seem obvious, but to drive the point home, let's
  consider the following example (~pl[set-print-base] and
  ~pl[set-print-radix]).
  ~bv[]
  ACL2 !>(state-global-let* ((print-base 16 set-print-base)
                             (print-radix t set-print-radix))
                            (mv nil 10 state))
   10
  ACL2 !>
  ~ev[]
  Why wasn't the result printed as ~c[#xA]?  The reason is that the result was
  printed after evaluation of the entire form had completed.  If you want to
  see ~c[#xA], do the printing in the scope of the bindings, for example as
  follows.
  ~bv[]
  ACL2 !>(state-global-let* ((print-base 16 set-print-base)
                             (print-radix t set-print-radix))
                            (pprogn (fms \"~~x0~~%\"
                                         (list (cons #\0 10))
                                         *standard-co* state nil)
                                    (mv nil 10 state)))

  #xA
   10
  ACL2 !>
  ~ev[]~/"

  (declare (xargs :guard (and (state-global-let*-bindings-p bindings)
                              (no-duplicatesp-equal (strip-cars bindings)))))

  `(warn-about-parallelism-hazard

; We call warn-about-parallelism-hazard, because use of this macro in a
; parallel environment is potentially dangerous.  It might work, because maybe
; no variables are rebound that are changed inside the waterfall, but we, the
; developers, want to know about any such rebinding.

    '(state-global-let* ,bindings ,body)
    (let ((state-global-let*-cleanup-lst
           (list ,@(state-global-let*-get-globals bindings))))
      ,@(and (null bindings)
             '((declare (ignore state-global-let*-cleanup-lst))))
      (acl2-unwind-protect
       "state-global-let*"
       (pprogn ,@(state-global-let*-put-globals bindings)
               (check-vars-not-free (state-global-let*-cleanup-lst) ,body))
       (pprogn
        ,@(state-global-let*-cleanup bindings 0)
        state)
       (pprogn
        ,@(state-global-let*-cleanup bindings 0)
        state)))))

#-acl2-loop-only
(defmacro state-free-global-let* (bindings body)

; This raw Lisp macro is a variant of state-global-let* that should be used
; only when state is *not* lexically available, or at least not a formal
; parameter of the enclosing function or not something we care about tracking
; (because we are in raw Lisp).  It is used to bind state globals that may have
; raw-Lisp side effects.  If state were available this sort of binding could be
; inappropriate, since one could observe a change in state globals under the
; state-free-global-let* that was not justified by the logic.

; State-free-global-let* provides a nice alternative to state-global-let* when
; we want to avoid involving the acl2-unwind-protect mechanism, for example
; during parallel evaluation.

; Comment for #+acl2-par: When using state-free-global-let* inside functions
; that might execute in parallel (for example, functions that occur inside the
; waterfall), consider modifying macro mt-future to cause child threads to
; inherit these variables' values from their parent threads.  See how we
; handled safe-mode and gc-on in macro mt-future for examples of how to cause
; such inheritance to occur.

  (cond
   ((null bindings) body)
   (t (let (bs syms)
        (dolist (binding bindings)
          (let ((sym (global-symbol (car binding))))
            (push (list sym (cadr binding))
                  bs)
            (push sym syms)))
        `(let* ,(nreverse bs)
           (declare (special ,@(nreverse syms)))
           ,body)))))

; With state-global-let* defined, we may now define a few more primitives and
; finish some unfinished business.

; We start by introducing functions that support type declarations.  We had to
; delay these because we use local in our proof, and local uses
; state-global-let*.  Bootstrapping is tough.  We could presumably do this
; earlier in the file and defer guard verification (which is why we need
; local), but since types are involved with guards, that seems dicey -- so we
; just wait till here.

(defun integer-range-p (lower upper x)

; Notice the strict inequality for upper.  This function was introduced in
; Version_2.7 in support of signed-byte-p and unsigned-byte-p, whose
; definitions were kept similar to those that had been in the ihs library for
; some time.

  (declare (xargs :guard (and (integerp lower) (integerp upper))))
  (and (integerp x)
       (<= lower x)
       (< x upper)))

(local (defthm natp-expt
         (implies (and (integerp base)
                       (integerp n)
                       (<= 0 n))
                  (integerp (expt base n)))
         :rule-classes :type-prescription))

; For the definitions of signed-byte-p and unsigned-byte-p, we were tempted to
; put (integerp n) and (< 0 n) [or for unsigned-byte-p, (<= 0 n)] in the
; guards.  However, instead we follow the approach already used for some time
; in community book books/ihs/logops-definitions.lisp, namely to include these
; as conjuncts in the bodies of the definitions, an approach that seems at
; least as reasonable.

(defun signed-byte-p (bits x)

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for signed integers that fit in a specified bit width~/

  ~c[(Signed-byte-p bits x)] is ~c[T] when ~c[bits] is a positive integer and
  ~c[x] is a signed integer whose 2's complement representation fits in a
  bit-width of ~c[bits], i.e., ~c[-2^(bits-1) <= x < 2^(bits-1)].~/

  Note that a ~il[type-spec] of ~c[(signed-byte i)] for a variable ~c[x] in a
  function's ~ilc[declare] form translates to a ~il[guard] condition of
  ~c[(signed-byte-p i x)].

  The ~il[guard] for ~c[signed-byte-p] is ~c[T].

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard t))
  (and (integerp bits)
       (< 0 bits)
       (integer-range-p (- (expt 2 (1- bits)))
                        (expt 2 (1- bits))
                        x)))

(defun unsigned-byte-p (bits x)

  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for natural numbers that fit in a specified bit width~/

  ~c[(Unsigned-byte-p bits x)] is ~c[T] when ~c[bits] is a positive integer and
  ~c[x] is a nonnegative integer that fits into a bit-width of ~c[bits], i.e.,
  ~c[0 <= x < 2^bits].~/

  Note that a ~il[type-spec] of ~c[(unsigned-byte i)] for a variable ~c[x] in a
  function's ~ilc[declare] form translates to a ~il[guard] condition of
  ~c[(unsigned-byte-p i x)].

  The ~il[guard] for ~c[unsigned-byte-p] is ~c[T].

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard t))
  (and (integerp bits)
       (<= 0 bits)
       (integer-range-p 0
                        (expt 2 bits)
                        x)))

; The following rules help built-in-clausep to succeed when guards are
; generated from type declarations.

(defthm integer-range-p-forward
  (implies (and (integer-range-p lower (1+ upper-1) x)
                (integerp upper-1))
           (and (integerp x)
                (<= lower x)
                (<= x upper-1)))
  :rule-classes :forward-chaining)

(defthm signed-byte-p-forward-to-integerp
  (implies (signed-byte-p n x)
           (integerp x))
  :rule-classes :forward-chaining)

(defthm unsigned-byte-p-forward-to-nonnegative-integerp
  (implies (unsigned-byte-p n x)
           (and (integerp x)
                (<= 0 x)))
  :rule-classes :forward-chaining)

; The logic-only definition of zpf needs to come after expt and integer-range-p.

(defmacro the-fixnum (n)
  (list 'the '(signed-byte 30) n))

#-acl2-loop-only
(defun-one-output zpf (x)
  (declare (type (unsigned-byte 29) x))
  (eql (the-fixnum x) 0))
#+acl2-loop-only
(defun zpf (x)
  (declare (type (unsigned-byte 29) x))
  ":Doc-Section ACL2::ACL2-built-ins

  testing a nonnegative fixnum against 0~/

  ~c[Zpf] is exactly the same as ~ilc[zp], except that ~c[zpf] is intended for,
  and faster for, fixnum arguments.  Its guard is specified with a type
  declaration, ~c[(type (unsigned-byte 29) x)].  (~l[declare] and
  ~pl[type-spec].)  Also ~pl[zp].

  To see the ACL2 definition of this function, ~pl[pf].~/~/"

  (if (integerp x)
      (<= x 0)
    t))

; We continue by proving the guards on substitute, all-vars1 and all-vars.

(local
 (defthm character-listp-substitute-ac
   (implies (and (characterp new)
                 (character-listp x)
                 (character-listp acc))
            (character-listp (substitute-ac new old x acc)))))

(verify-guards substitute)

(local
 (encapsulate
  ()

; We wish to prove symbol-listp-all-vars1, below, so that we can verify the
; guards on all-vars1.  But it is in a mutually recursive clique.  Our strategy
; is simple: (1) define the flagged version of the clique, (2) prove that it is
; equal to the given pair of official functions, (3) prove that it has the
; desired property and (4) then obtain the desired property of the official
; function by instantiation of the theorem proved in step 3, using the theorem
; proved in step 2 to rewrite the flagged flagged calls in that instance to the
; official ones.

; Note: It would probably be better to make all-vars1/all-vars1-lst local,
; since it's really not of any interest outside the guard verification of
; all-vars1.  However, since we are passing through this file more than once,
; that does not seem to be an option.

  (local
   (defun all-vars1/all-vars1-lst (flg lst ans)
     (if (eq flg 'all-vars1)
         (cond ((variablep lst) (add-to-set-eq lst ans))
               ((fquotep lst) ans)
               (t (all-vars1/all-vars1-lst 'all-vars-lst1 (cdr lst) ans)))
         (cond ((endp lst) ans)
               (t (all-vars1/all-vars1-lst 'all-vars-lst1 (cdr lst)
                                           (all-vars1/all-vars1-lst 'all-vars1 (car lst) ans)))))))

  (local
   (defthm step-1-lemma
     (equal (all-vars1/all-vars1-lst flg lst ans)
            (if (equal flg 'all-vars1) (all-vars1 lst ans) (all-vars1-lst lst ans)))))

  (local
   (defthm step-2-lemma
     (implies (and (symbol-listp ans)
                   (if (equal flg 'all-vars1)
                       (pseudo-termp lst)
                       (pseudo-term-listp lst)))
              (symbol-listp (all-vars1/all-vars1-lst flg lst ans)))))

  (defthm symbol-listp-all-vars1
    (implies (and (symbol-listp ans)
                  (pseudo-termp lst))
             (symbol-listp (all-vars1 lst ans)))
    :hints (("Goal" :use (:instance step-2-lemma (flg 'all-vars1)))))))

(verify-guards all-vars1)

(verify-guards all-vars)

(local (defthm symbol-listp-implies-true-listp
         (implies (symbol-listp x)
                  (true-listp x))))

(verify-guards check-vars-not-free-test)

; Next, we verify the guards of getprops, which we delayed for the same
; reasons.

(encapsulate
 ()

 (defthm string<-l-asymmetric
   (implies (and (eqlable-listp x1)
                 (eqlable-listp x2)
                 (integerp i)
                 (string<-l x1 x2 i))
            (not (string<-l x2 x1 i)))
   :hints (("Goal" :in-theory (disable member))))

 (defthm symbol-<-asymmetric
   (implies (and (symbolp sym1)
                 (symbolp sym2)
                 (symbol-< sym1 sym2))
            (not (symbol-< sym2 sym1)))
   :hints (("Goal" :in-theory
            (set-difference-theories
             (enable string< symbol-<)
             '(string<-l)))))

 (defthm string<-l-transitive
   (implies (and (string<-l x y i)
                 (string<-l y z j)
                 (integerp i)
                 (integerp j)
                 (integerp k)
                 (character-listp x)
                 (character-listp y)
                 (character-listp z))
            (string<-l x z k))
   :rule-classes ((:rewrite :match-free :all))
   :hints (("Goal" :induct t
            :in-theory (disable member))))

 (in-theory (disable string<-l))

 (defthm symbol-<-transitive
   (implies (and (symbol-< x y)
                 (symbol-< y z)
                 (symbolp x)
                 (symbolp y)
                 (symbolp z))
            (symbol-< x z))
   :rule-classes ((:rewrite :match-free :all))
   :hints (("Goal" :in-theory (enable symbol-< string<))))

 (local
  (defthm equal-char-code-rewrite
    (implies (and (characterp x)
                  (characterp y))
             (implies (equal (char-code x) (char-code y))
                      (equal (equal x y) t)))
    :hints (("Goal" :use equal-char-code))))

 (defthm string<-l-trichotomy
   (implies (and (not (string<-l x y i))
                 (integerp i)
                 (integerp j)
                 (character-listp x)
                 (character-listp y))
            (iff (string<-l y x j)
                 (not (equal x y))))
   :rule-classes ((:rewrite :match-free :all))
   :hints (("Goal" :in-theory
            (set-difference-theories
             (enable string<-l)
             '(member))
            :induct t)))

 (local
  (defthm equal-coerce
    (implies (and (stringp x)
                  (stringp y))
             (equal (equal (coerce x 'list)
                           (coerce y 'list))
                    (equal x y)))
    :hints (("Goal" :use
             ((:instance coerce-inverse-2 (x x))
              (:instance coerce-inverse-2 (x y)))
             :in-theory (disable coerce-inverse-2)))))

 (local
  (defthm symbol-equality-rewrite
    (implies (and (symbolp s1)
                  (symbolp s2)
                  (equal (symbol-name s1)
                         (symbol-name s2))
                  (equal (symbol-package-name s1)
                         (symbol-package-name s2)))
             (equal (equal s1 s2) t))
    :hints (("Goal" :use symbol-equality))))

 (defthm symbol-<-trichotomy
   (implies (and (symbolp x)
                 (symbolp y)
                 (not (symbol-< x y)))
            (iff (symbol-< y x)
                 (not (equal x y))))
   :hints (("Goal" :in-theory (enable symbol-< string<))))

 (defthm ordered-symbol-alistp-delete-assoc-eq
   (implies (ordered-symbol-alistp l)
            (ordered-symbol-alistp (delete-assoc-eq key l))))

 (defthm symbol-<-irreflexive
   (implies (symbolp x)
            (not (symbol-< x x)))
   :hints (("Goal" :use
            ((:instance symbol-<-asymmetric
                        (sym1 x) (sym2 x)))
            :in-theory (disable symbol-<-asymmetric))))

 (defthm ordered-symbol-alistp-add-pair
   (implies (and (ordered-symbol-alistp gs)
                 (symbolp w5))
            (ordered-symbol-alistp (add-pair w5 w6 gs))))

 (defthm ordered-symbol-alistp-getprops
   (implies (and (plist-worldp w)
                 (symbolp world-name)
                 (symbolp key))
            (ordered-symbol-alistp (getprops key world-name w)))
   :hints (("Goal" :in-theory (enable symbol-<))))

 (local (defthm ordered-symbol-alistp-implies-symbol-alistp
          (implies (ordered-symbol-alistp x)
                   (symbol-alistp x))))

 (local (defthm symbol-alistp-implies-alistp
          (implies (symbol-alistp x)
                   (alistp x))))

 (verify-guards getprops)

 )

; Functions such as logand require significant arithmetic to prove.  Therefore
; part of the proofs for their "warming" will be deferred.

; Bishop Brock has contributed the lemma justify-integer-floor-recursion that
; follows.  Although he has proved this lemma as part of a larger proof effort,
; we are not yet in a hurry to isolate its proof just now.

(local
 (skip-proofs
  (defthm justify-integer-floor-recursion

; To use this, be sure to disable acl2-count and floor.  If you leave
; acl2-count enabled, then prove a version of this appropriate to that setting.

    (implies
     (and (integerp i)
          (integerp j)
          (not (equal i 0))
          (not (equal i -1))
          (> j 1))
     (< (acl2-count (floor i j)) (acl2-count i)))
    :rule-classes :linear)))

#+acl2-loop-only
(defmacro logand (&rest args)

  ":Doc-Section ACL2::ACL2-built-ins

  bitwise logical `and' of zero or more integers~/

  When integers are viewed in their two's complement representation,
  ~c[logand] returns their bitwise logical `and'.  In ACL2 ~c[logand] is a
  macro that expands into calls of the binary function ~c[binary-logand],
  except that ~c[(logand)] expands to ~c[-1] and ~c[(logand x)] expands to ~c[x].~/

  The ~il[guard] for ~c[binary-logand] requires its arguments to be integers.
  ~c[Logand] is defined in Common Lisp.  See any Common Lisp
  documentation for more information.~/"

  (cond
   ((null args)
    -1)
   ((null (cdr args))
    (car args))
   (t (xxxjoin 'binary-logand args))))

#+acl2-loop-only
(defmacro logeqv (&rest args)

  ":Doc-Section ACL2::ACL2-built-ins

  bitwise logical equivalence of zero or more integers~/

  When integers are viewed in their two's complement representation,
  ~c[logeqv] returns their bitwise logical equivalence.  In ACL2 ~c[logeqv] is a
  macro that expands into calls of the binary function ~c[binary-logeqv],
  except that ~c[(logeqv)] expands to ~c[-1] and ~c[(logeqv x)] expands to ~c[x].~/

  The ~il[guard] for ~c[binary-logeqv] requires its arguments to be integers.
  ~c[Logeqv] is defined in Common Lisp.  See any Common Lisp
  documentation for more information.~/"

  (cond
   ((null args)
    -1)
   ((null (cdr args))
    (car args))
   (t (xxxjoin 'binary-logeqv args))))

#+acl2-loop-only
(defmacro logior (&rest args)

  ":Doc-Section ACL2::ACL2-built-ins

  bitwise logical inclusive or of zero or more integers~/

  When integers are viewed in their two's complement representation,
  ~c[logior] returns their bitwise logical inclusive or.  In ACL2 ~c[logior] is a
  macro that expands into calls of the binary function ~c[binary-logior],
  except that ~c[(logior)] expands to ~c[0] and ~c[(logior x)] expands to ~c[x].~/

  The ~il[guard] for ~c[binary-logior] requires its arguments to be integers.
  ~c[Logior] is defined in Common Lisp.  See any Common Lisp
  documentation for more information.~/"

  (cond
   ((null args)
    0)
   ((null (cdr args))
    (car args))
   (t (xxxjoin 'binary-logior args))))

#+acl2-loop-only
(defmacro logxor (&rest args)

  ":Doc-Section ACL2::ACL2-built-ins

  bitwise logical exclusive or of zero or more integers~/

  When integers are viewed in their two's complement representation,
  ~c[logxor] returns their bitwise logical exclusive or.  In ACL2 ~c[logxor] is a
  macro that expands into calls of the binary function ~c[binary-logxor],
  except that ~c[(logxor)] expands to ~c[0] and ~c[(logxor x)] expands to ~c[x].~/

  The ~il[guard] for ~c[binary-logxor] requires its arguments to be integers.
  ~c[Logxor] is defined in Common Lisp.  See any Common Lisp
  documentation for more information.~/"

  (cond
   ((null args)
    0)
   ((null (cdr args))
    (car args))
   (t (xxxjoin 'binary-logxor args))))

#+acl2-loop-only
(defun integer-length (i)

; Bishop Brock contributed the following definition.  We believe it to be
; equivalent to one on p. 361 of CLtL2:
; (log2 (if (< x 0) (- x) (1+ x))).

  ":Doc-Section ACL2::ACL2-built-ins

  number of bits in two's complement integer representation~/

  For non-negative integers, ~c[(integer-length i)] is the minimum number
  of bits needed to represent the integer.  Any integer can be
  represented as a signed two's complement field with a minimum of
  ~c[(+ (integer-length i) 1)] bits.~/

  The ~il[guard] for ~c[integer-length] requires its argument to be an
  integer.  ~c[Integer-length] is defined in Common Lisp.  See any
  Common Lisp documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (integerp i)
                  :hints (("Goal" :in-theory (disable acl2-count floor)))))
  (if (zip i)
      0
    (if (= i -1)
        0
      (+ 1 (integer-length (floor i 2))))))

(defun binary-logand (i j)
  (declare (xargs :guard (and (integerp i)
                              (integerp j))
                  :hints (("Goal" :in-theory (disable acl2-count floor)))))
  (cond ((zip i) 0)
        ((zip j) 0)
        ((eql i -1) j)
        ((eql j -1) i)
        (t (let ((x (* 2 (logand (floor i 2) (floor j 2)))))
             (+ x (cond ((evenp i) 0)
                        ((evenp j) 0)
                        (t 1)))))))

#+acl2-loop-only
(defun lognand (i j)

  ":Doc-Section ACL2::ACL2-built-ins

  bitwise logical `nand' of two integers~/

  When integers are viewed in their two's complement representation,
  ~c[lognand] returns their bitwise logical `nand'.~/

  The ~il[guard] for ~c[lognand] requires its arguments to be integers.
  ~c[Lognand] is defined in Common Lisp.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (integerp i)
                              (integerp j))))
  (lognot (logand i j)))

(defun binary-logior (i j)
  (declare (xargs :guard (and (integerp i)
                              (integerp j))))
  (lognot (logand (lognot i) (lognot j))))

#+acl2-loop-only
(defun logorc1 (i j)

  ":Doc-Section ACL2::ACL2-built-ins

  bitwise logical inclusive or of two ints, complementing the first~/

  When integers are viewed in their two's complement representation,
  ~c[logorc1] returns the bitwise logical inclusive or of the second
  with the bitwise logical `not' of the first.~/

  The ~il[guard] for ~c[logorc1] requires its arguments to be integers.
  ~c[Logorc1] is defined in Common Lisp.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (integerp i)
                              (integerp j))))
  (logior (lognot i) j))

#+acl2-loop-only
(defun logorc2 (i j)

  ":Doc-Section ACL2::ACL2-built-ins

  bitwise logical inclusive or of two ints, complementing the second~/

  When integers are viewed in their two's complement representation,
  ~c[logorc2] returns the bitwise logical inclusive or of the first
  with the bitwise logical `not' of the second.~/

  The ~il[guard] for ~c[logorc2] requires its arguments to be integers.
  ~c[Logorc2] is defined in Common Lisp.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (integerp i)
                              (integerp j))))
  (logior i (lognot j)))

#+acl2-loop-only
(defun logandc1 (i j)

  ":Doc-Section ACL2::ACL2-built-ins

  bitwise logical `and' of two ints, complementing the first~/

  When integers are viewed in their two's complement representation,
  ~c[logandc1] returns the bitwise logical `and' of the second with the
  bitwise logical `not' of the first.~/

  The ~il[guard] for ~c[logandc1] requires its arguments to be integers.
  ~c[Logandc1] is defined in Common Lisp.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (integerp i)
                              (integerp j))))
  (logand (lognot i) j))

#+acl2-loop-only
(defun logandc2 (i j)

  ":Doc-Section ACL2::ACL2-built-ins

  bitwise logical `and' of two ints, complementing the second~/

  When integers are viewed in their two's complement representation,
  ~c[logandc2] returns the bitwise logical `and' of the first with the
  bitwise logical `not' of the second.~/

  The ~il[guard] for ~c[logandc2] requires its arguments to be integers.
  ~c[Logandc2] is defined in Common Lisp.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (integerp i)
                              (integerp j))))
  (logand i (lognot j)))

(defun binary-logeqv (i j)
  (declare (xargs :guard (and (integerp i)
                              (integerp j))))
  (logand (logorc1 i j)
          (logorc1 j i)))

(defun binary-logxor (i j)
  (declare (xargs :guard (and (integerp i)
                              (integerp j))))
  (lognot (logeqv i j)))

#+acl2-loop-only
(defun lognor (i j)

  ":Doc-Section ACL2::ACL2-built-ins

  bitwise logical `nor' of two integers~/

  When integers are viewed in their two's complement representation,
  ~c[lognor] returns the bitwise logical `nor' of the first with the
  second.~/

  The ~il[guard] for ~c[lognor] requires its arguments to be integers.
  ~c[Lognor] is defined in Common Lisp.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (integerp i)
                              (integerp j))))
  (lognot (logior i j)))

#+acl2-loop-only
(defun logtest (x y)

; p. 360 of CLtL2

  ":Doc-Section ACL2::ACL2-built-ins

  test if two integers share a `1' bit~/

  When integers ~c[x] and ~c[y] are viewed in their two's complement
  representation, ~c[(logtest x y)] is true if and only if there is
  some position for which both ~c[x] and ~c[y] have a `1' bit in that
  position.~/

  The ~il[guard] for ~c[logtest] requires its arguments to be integers.
  ~c[Logtest] is defined in Common Lisp.  See any Common Lisp
  documentation for more information.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (integerp x) (integerp y))))
  (not (zerop (logand x y))))

; Warning: Keep the following defconst forms in sync with *boole-array*.

(defconst *BOOLE-1*      0)
(defconst *BOOLE-2*      1)
(defconst *BOOLE-AND*    2)
(defconst *BOOLE-ANDC1*  3)
(defconst *BOOLE-ANDC2*  4)
(defconst *BOOLE-C1*     5)
(defconst *BOOLE-C2*     6)
(defconst *BOOLE-CLR*    7)
(defconst *BOOLE-EQV*    8)
(defconst *BOOLE-IOR*    9)
(defconst *BOOLE-NAND*  10)
(defconst *BOOLE-NOR*   11)
(defconst *BOOLE-ORC1*  12)
(defconst *BOOLE-ORC2*  13)
(defconst *BOOLE-SET*   14)
(defconst *BOOLE-XOR*   15)

(defun boole$ (op i1 i2)

  ":Doc-Section ACL2::ACL2-built-ins

  perform a bit-wise logical operation on 2 two's complement integers~/

  When integers ~c[x] and ~c[y] are viewed in their two's complement
  representation, ~c[(boole$ op x y)] returns the result of applying the
  bit-wise logical operation specified by ~c[op].  The following table is
  adapted from documentation for analogous Common Lisp function ~c[boole] in
  the Common Lisp HyperSpec
  (~url[http://www.lisp.org/HyperSpec/Body/fun_boole.html#boole]).  Note that
  the values of ~c[op] for ~c[boole$] are ACL2 constants, rather than
  corresponding values of ~c[op] for the Common Lisp function ~c[boole].
  ~bv[]
  op               result
  -----------      ---------
  *boole-1*        x
  *boole-2*        y
  *boole-andc1*    and complement of x with y
  *boole-andc2*    and x with complement of y
  *boole-and*      and
  *boole-c1*       complement of x
  *boole-c2*       complement of y
  *boole-clr*      the constant 0 (all zero bits)
  *boole-eqv*      equivalence (exclusive nor)
  *boole-ior*      inclusive or
  *boole-nand*     not-and
  *boole-nor*      not-or
  *boole-orc1*     or complement of x with y
  *boole-orc2*     or x with complement of y
  *boole-set*      the constant -1 (all one bits)
  *boole-xor*      exclusive or
  ~ev[]~/

  The guard of ~c[boole$] specifies that ~c[op] is the value of one of the
  constants above and that ~c[x] and ~c[y] are integers.

  See any Common Lisp documentation for analogous information about
  Common Lisp function ~c[boole].

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (type (integer 0 15) op)
           (type integer i1 i2))
  #-acl2-loop-only
  (boole (aref *boole-array* op) i1 i2)
  #+acl2-loop-only
  (cond
    ((eql op *BOOLE-1*)      i1)
    ((eql op *BOOLE-2*)      i2)
    ((eql op *BOOLE-AND*)    (logand i1 i2))
    ((eql op *BOOLE-ANDC1*)  (logandc1 i1 i2))
    ((eql op *BOOLE-ANDC2*)  (logandc2 i1 i2))
    ((eql op *BOOLE-C1*)     (lognot i1))
    ((eql op *BOOLE-C2*)     (lognot i2))
    ((eql op *BOOLE-CLR*)    0)
    ((eql op *BOOLE-EQV*)    (logeqv i1 i2))
    ((eql op *BOOLE-IOR*)    (logior i1 i2))
    ((eql op *BOOLE-NAND*)   (lognand i1 i2))
    ((eql op *BOOLE-NOR*)    (lognor i1 i2))
    ((eql op *BOOLE-ORC1*)   (logorc1 i1 i2))
    ((eql op *BOOLE-ORC2*)   (logorc2 i1 i2))
    ((eql op *BOOLE-SET*)    1)
    ((eql op *BOOLE-XOR*)    (logxor i1 i2))
    (t 0) ; added so that we get an integer type for integer i1 and i2
    ))

;                        PRINTING and READING

(deflabel io
  :doc
  ":Doc-Section IO

  input/output facilities in ACL2~/
  ~bv[]
  Example:
  (mv-let
    (channel state)
    (open-input-channel \"foo.lisp\" :object state)
    (mv-let (eofp obj state)
            (read-object channel state)
            (.
              .
               (let ((state (close-input-channel channel state)))
                     (mv final-ans state))..)))
  ~ev[]
  Also ~pl[file-reading-example].

  For advanced ways to control printing, ~pl[print-control].

  For a discussion of formatted printing, ~pl[fmt].

  To control ACL2 abbreviation (``evisceration'') of objects before printing
  them, ~pl[set-evisc-tuple], ~pl[without-evisc], and ~pl[set-iprint].

  To redirect output to a file, ~pl[output-to-file].~/

  ACL2 supports input and output facilities equivalent to a subset of those
  found in Common Lisp.  ACL2 does not support random access to files or
  bidirectional streams.  In Common Lisp, input and output are to or from
  objects of type ~c[stream].  In ACL2, input and output are to or from objects
  called ``channels,'' which are actually symbols.  Although a channel is a
  symbol, one may think of it intuitively as corresponding to a Common Lisp
  stream.  Channels are in one of two ACL2 packages, ~c[\"ACL2-INPUT-CHANNEL\"]
  and ~c[\"ACL2-OUTPUT-CHANNEL\"].  When one ``opens'' a file one gets back a
  channel whose ~ilc[symbol-name] is the file name passed to ``open,''
  postfixed with ~c[-n], where ~c[n] is a counter that is incremented every
  time an open or close occurs.

  There are three channels which are open from the beginning and which cannot
  be closed:
  ~bv[]
    acl2-input-channel::standard-character-input-0
    acl2-input-channel::standard-object-input-0
    acl2-input-channel::standard-character-output-0
  ~ev[]
  All three of these are really Common Lisp's ~c[*standard-input*] or
  ~c[*standard-output*], appropriately.

  For convenience, three global variables are bound to these rather tedious
  channel names:
  ~bv[]
    *standard-ci*
    *standard-oi*
    *standard-co*
  ~ev[]
  Common Lisp permits one to open a stream for several different kinds of
  ~c[io], e.g. character or byte.  ACL2 permits an additional type called
  ``object''.  In ACL2 an ``io-type'' is a keyword, either ~c[:character],
  ~c[:byte], or ~c[:object].  When one opens a file, one specifies a type,
  which determines the kind of io operations that can be done on the channel
  returned.  The types ~c[:character] and ~c[:byte] are familiar.  Type
  ~c[:object] is an abstraction not found in Common Lisp.  An ~c[:object] file
  is a file of Lisp objects.  One uses ~c[read-object] to read from ~c[:object]
  files and ~c[print-object$] (or ~c[print-object$-ser]) to print to
  ~c[:object] files.  (The reading and printing are really done with the Common
  Lisp ~c[read] and ~c[print] functions.  For those familiar with ~c[read], we
  note that the ~c[recursive-p] argument is ~c[nil].)  The function
  ~c[read-object-suppress] is logically the same as ~c[read-object] except that
  ~c[read-object-suppress] throws away the second returned value, i.e. the
  value that would normally be read, simply returning ~c[(mv eof state)]; under
  the hood, ~c[read-object-suppress] avoids errors, for example those caused by
  encountering symbols in packages unknown to ACL2.

  File-names are strings.  ACL2 does not support the Common Lisp type
  ~ilc[pathname].  However, for the ~c[file-name] argument of the
  output-related functions listed below, ACL2 supports a special value,
  ~c[:STRING].  For this value, the channel connects (by way of a Common Lisp
  output string stream) to a string rather than to a file: as characters are
  written to the channel they can be retrieved by using
  ~c[get-output-stream-string$].

  Here are the names, formals and output descriptions of the ACL2 io functions.
  ~bv[]
  Input Functions:
    (open-input-channel (file-name io-type state) (mv channel state))
    (open-input-channel-p (channel io-type state) boolean)
    (close-input-channel (channel state) state)
    (read-char$ (channel state) (mv char/nil state)) ; nil for EOF
    (peek-char$ (channel state) boolean)
    (read-byte$ (channel state) (mv byte/nil state)) ; nil for EOF
    (read-object (channel state) (mv eof-read-flg obj-read state))
    (read-object-suppress (channel state) (mv eof-read-flg state))

  Output Functions:
    (open-output-channel  (file-name io-type state) (mv channel state))
    (open-output-channel! (file-name io-type state) (mv channel state))
    (open-output-channel-p (channel io-type state) boolean)
    (close-output-channel (channel state) state)
    (princ$ (obj channel state) state)
    (write-byte$ (byte channel state) state)
    (print-object$ (obj channel state) state)
    (print-object$-ser (obj serialize-character channel state) state)
    (fms  (string alist channel state evisc-tuple) state)
    (fms! (string alist channel state evisc-tuple) state)
    (fmt  (string alist channel state evisc-tuple) (mv col state))
    (fmt! (string alist channel state evisc-tuple) (mv col state))
    (fmt1 (string alist col channel state evisc-tuple) (mv col state))
    (fmt1! (string alist col channel state evisc-tuple) (mv col state))
    (cw (string arg0 arg1 ... argn) nil)
    (get-output-stream-string$ (channel state
                                &optional (close-p 't)
                                          (ctx ''get-output-stream-string$))
                               (mv erp string state))
  ~ev[]
  The ``formatting'' functions are particularly useful; ~pl[fmt] and ~pl[cw].
  In particular, ~ilc[cw] prints to a ``comment window'' and does not involve
  the ACL2 ~ilc[state], so many may find it easier to use than ~ilc[fmt] and
  its variants.  The functions ~ilc[fms!], ~ilc[fmt!], and ~ilc[fmt1!] are the
  same as their respective functions without the ``~c[!],'' except that the
  ``~c[!]'' functions are guaranteed to print forms that can be read back
  in (at a slight readability cost).

  When one enters ACL2 with ~c[(lp)], input and output are taken from
  ~ilc[*standard-oi*] to ~ilc[*standard-co*].  Because these are synonyms for
  ~c[*standard-input*] and ~c[*standard-output*], one can drive ACL2 io off of
  arbitrary Common Lisp streams, bound to ~c[*standard-input*] and
  ~c[*standard-output*] before entry to ACL2.

  The macro ~c[get-output-stream-string$] returns the string accumulated into
  the given channel.  By default, a call of this macro closes the supplied
  output channel.  However, a third argument is optional (default ~c[t]), and
  if it evaluates to ~c[nil] then the channel remains open.  The fourth
  argument is an optional context, which generally evaluates to a symbol, for
  error reporting.  The following example illustrates.
  ~bv[]
  ACL2 !>
  (mv-let
     (channel state)
     (open-output-channel :string :object state)
     (pprogn (print-object$-ser 17 nil channel state)
             (print-object$-ser '(a b (c d)) nil channel state)
             (er-let*
               ((str1 (get-output-stream-string$
                       channel state
                       nil))) ; keep the channel open
               (pprogn (print-object$-ser 23 nil channel state)
                       (print-object$-ser '((e f)) nil channel state)
                       (er-let* ; close the channel
                         ((str2 (get-output-stream-string$ channel state)))
                         (value (cons str1 str2)))))))
   (\"
  17
  (A B (C D))\" . \"
  23
  ((E F))\")
  ACL2 !>
  ~ev[]
  Also ~pl[printing-to-strings] for a discussion of formatted printing
  functions such as ~c[fmt-to-string] that do not take a channel or ~ilc[state]
  argument and return a string.

  By default, symbols are printed in upper case when vertical bars are not
  required, as specified by Common Lisp.  ~l[set-print-case] for how to get
  ACL2 to print symbols in lower case.

  By default, numbers are printed in radix 10 (base 10).  ~l[set-print-base]
  for how to get ACL2 to print numbers in radix 2, 8, or 16.

  To see the ~il[guard] of an IO function, or indeed any function, ~pl[args] or
  call the function ~c[guard]; but some built-in functions (including some IO
  functions) will print the result using the variable ~c[STATE-STATE].  While
  that is logically correct, if you want to execute the guard then you should
  replace that variable by ~c[STATE] and also replace each built-in function
  symbol of the form ~c[xxx-p1] by corresponding function symbol ~c[xxx-p].
  Consider the following example.
  ~bv[]
  ACL2 !>:args princ$

  Function         PRINC$
  Formals:         (X CHANNEL STATE-STATE)
  Signature:       (PRINC$ * * STATE)
                   => STATE
  Guard:           (AND (OR (ACL2-NUMBERP X)
                            (CHARACTERP X)
                            (STRINGP X)
                            (SYMBOLP X))
                        (STATE-P1 STATE-STATE)
                        (SYMBOLP CHANNEL)
                        (OPEN-OUTPUT-CHANNEL-P1 CHANNEL
                                                :CHARACTER STATE-STATE))
  Guards Verified: T
  Defun-Mode:      :logic
  Type:            (CONSP (PRINC$ X CHANNEL STATE-STATE))
  Documentation available via :DOC
   PRINC$
  ACL2 !>(untranslate (guard 'princ$ nil (w state)) t (w state))
  (AND (OR (ACL2-NUMBERP X)
           (CHARACTERP X)
           (STRINGP X)
           (SYMBOLP X))
       (STATE-P1 STATE-STATE)
       (SYMBOLP CHANNEL)
       (OPEN-OUTPUT-CHANNEL-P1 CHANNEL
                               :CHARACTER STATE-STATE))
  ACL2 !>
  ~ev[]
  If you want to execute the guard for ~ilc[princ$], then according to the
  suggestion above, you should consider the guard for
  ~c[(princ$ x channel state)] to be as follows.
  ~bv[]
  (AND (OR (ACL2-NUMBERP X)
           (CHARACTERP X)
           (STRINGP X)
           (SYMBOLP X))
       (STATE-P STATE)
       (SYMBOLP CHANNEL)
       (OPEN-OUTPUT-CHANNEL-P CHANNEL :CHARACTER STATE))
  ~ev[]
  For example, we can check the guard for a given value and channel as follows.
  ~bv[]
  ACL2 !>(let ((x 3) (channel *standard-co*))
           (AND (OR (ACL2-NUMBERP X)
                    (CHARACTERP X)
                    (STRINGP X)
                    (SYMBOLP X))
                (STATE-P STATE)
                (SYMBOLP CHANNEL)
                (OPEN-OUTPUT-CHANNEL-P CHANNEL :CHARACTER STATE)))
  T
  ACL2 !>
  ~ev[]

  Comment for advanced users: Function ~ilc[open-output-channel!] is identical
  as a function to ~c[open-output-channel], except that the former may be
  called even during ~ilc[make-event] expansion and ~ilc[clause-processor]
  ~il[hints], but requires that there is an active trust tag (~pl[defttag]).

  Finally, we note that the community book ~c[books/misc/file-io.lisp] contains
  useful file io functions whose definitions illustrate some of the features
  described above.~/")

(defdoc output-to-file
  ":Doc-Section IO

  redirecting output to a file~/

  For a general discussion of ACL2 input/output and of the ACL2 read-eval-print
  loop, ~pl[io] and ~pl[ld] (respectively).  Here we use an example to
  illustrate how to use some of the options provided by ~c[ld] to redirect ACL2
  output to a file, other than the printing of the prompt (which continues to
  go to the terminal).

  There are two ~c[ld] specials that control output from the ~c[ld] command:
  ~ilc[proofs-co] for proof output and ~ilc[standard-co] for other output.  The
  following example shows how to use these to redirect output to a file
  ~c[\"tmp.out\"].  The following command opens a character output channel to
  to the file ~c[\"tmp.out\"] and redirects proof output to that channel, i.e.,
  to file ~c[\"tmp.out\"].
  ~bv[]
  (mv-let (chan state)
          (open-output-channel \"tmp.out\" :character state)
          (set-proofs-co chan state))
  ~ev[]
  Next, we redirect standard output to that same channel.
  ~bv[]
  (set-standard-co (proofs-co state) state)
  ~ev[]
  Now we can load an input file, in this case file ~c[\"tmp.lisp\"], and output
  will be redirected to file ~c[\"tmp.out\"].  (The use of
  ~c[:ld-pre-eval-print t] is optional; ~pl[ld].)
  ~bv[]
  (ld \"tmp.lisp\" :ld-pre-eval-print t)
  ~ev[]
  Having completed our load operation, we restore both proof output and
  standard output to the terminal, as follows.
  ~bv[]
  (set-standard-co *standard-co* state)
  (close-output-channel (proofs-co state) state)
  (set-proofs-co *standard-co* state)
  ~ev[]

  The following variant of the above example shows how to redirect output as
  above except without changing the global settings of the two ~ilc[ld]
  specials, ~ilc[proofs-co] and ~ilc[standard-co].  This approach uses
  a notion of ``global variables'' stored in the ACL2 ~il[state]; ~pl[assign]
  and ~pl[@].
  ~bv[]
  (mv-let (chan state)
          (open-output-channel \"tmp.out\" :character state)
          (assign tmp-channel chan))
  (ld \"tmp.lisp\" :ld-pre-eval-print t
                 :proofs-co (@ tmp-channel)
                 :standard-co (@ tmp-channel))
  (close-output-channel (@ tmp-channel) state)
  ~ev[]~/~/")

(defdoc *standard-co*
  ":Doc-Section IO

  the ACL2 analogue of CLTL's ~c[*standard-output*]~/

  The value of the ACL2 constant ~c[*standard-co*] is an open character
  output channel that is synonymous to Common Lisp's
  ~c[*standard-output*].~/

  ACL2 character output to ~c[*standard-co*] will go to the stream named
  by Common Lisp's ~c[*standard-output*].  That is, by changing the
  setting of ~c[*standard-output*] in raw Common Lisp you can change the
  actual destination of ACL2 output on the channel named by
  ~c[*standard-co*].  Observe that this happens without changing the
  logical value of ~c[*standard-co*] (which is some channel symbol).
  Changing the setting of ~c[*standard-output*] in raw Common Lisp
  essentially just changes the map that relates ACL2 to the physical
  world of terminals, files, etc.

  To see the value of this observation, consider the following.
  Suppose you write an ACL2 function which does character output to
  the constant channel ~c[*standard-co*].  During testing you see that the
  output actually goes to your terminal.  Can you use the function to
  output to a file?  Yes, if you are willing to do a little work in
  raw Common Lisp: open a stream to the file in question, set
  ~c[*standard-output*] to that stream, call your ACL2 function, and then
  close the stream and restore ~c[*standard-output*] to its nominal value.
  Similar observations can be made about the two ACL2 input channels,
  ~ilc[*standard-oi*] and ~ilc[*standard-ci*], which are analogues of
  ~c[*standard-input*].

  Another reason you might have for wanting to change the actual
  streams associated with ~ilc[*standard-oi*] and ~c[*standard-co*] is to drive
  the ACL2 top-level loop, ~ilc[ld], on alternative input and output
  streams.  This end can be accomplished easily within ACL2 by either
  calling ~ilc[ld] on the desired channels or file names or by resetting the
  ACL2 ~ilc[state] global variables ~c[']~ilc[standard-oi] and ~c[']~ilc[standard-co] which are
  used by ~ilc[ld].  ~l[standard-oi] and ~pl[standard-co].")

(defdoc *standard-oi*
  ":Doc-Section IO

  an ACL2 object-based analogue of CLTL's ~c[*standard-input*]~/

  The value of the ACL2 constant ~c[*standard-oi*] is an open object input
  channel that is synonymous to Common Lisp's ~c[*standard-input*].~/

  ACL2 object input from ~c[*standard-oi*] is actually obtained by reading
  from the stream named by Common Lisp's ~c[*standard-input*].  That is,
  by changing the setting of ~c[*standard-input*] in raw Common Lisp you
  can change the source from which ACL2 reads on the channel
  ~c[*standard-oi*].  ~l[*standard-co*].")

(defdoc *standard-ci*
  ":Doc-Section IO

  an ACL2 character-based analogue of CLTL's ~c[*standard-input*]~/

  The value of the ACL2 constant ~c[*standard-ci*] is an open character
  input channel that is synonymous to Common Lisp's
  ~c[*standard-input*].~/

  ACL2 character input from ~c[*standard-ci*] is actually obtained by
  reading ~il[characters] from the stream named by Common Lisp's
  ~c[*standard-input*].  That is, by changing the setting of
  ~c[*standard-input*] in raw Common Lisp you can change the source from
  which ACL2 reads on the channel ~c[*standard-ci*].
  ~l[*standard-co*].")

(defdoc print-control

  ":Doc-Section IO

  advanced controls of ACL2 printing~/

  ~l[IO] for a summary of printing in ACL2.  Here we document some advanced
  ways to control what is printed by ACL2's primary printing routines.

  ~l[set-print-base], ~pl[set-print-radix], and ~pl[set-print-case] for
  discussions of the most common ways to control what is printed.  Indeed,
  these are the only ways to control the behavior of ~ilc[princ$] and
  ~c[prin1$].

  The rest of this topic is for advanced users of ACL2.  We refer to Common
  Lisp behavior, as described in any good Common Lisp documentation.

  ~st[Print-control variables].  ~ilc[Set-print-base], ~ilc[set-print-radix],
  and ~ilc[set-print-case] assign to corresponding so-called ``~il[state]
  global variables'' ~c['print-base], ~c['print-radix], and ~c['print-case],
  which can be accessed using the expressions ~c[(@ print-base)],
  ~c[(@ print-radix)], and ~c[(@ print-case)], respectively; ~pl[assign].  Here
  is a table showing all print-control variables, their setters, and their
  defaults.

  ~bv[]
  print-base          set-print-base          10
  print-case          set-print-case          :upcase
  print-circle        set-print-circle        nil
    [but see remark on print-circle-files, below]
  print-escape        set-print-escape        t
  print-length        set-print-length        nil
  print-level         set-print-level         nil
  print-lines         set-print-lines         nil
  print-pretty        set-print-pretty        nil
  print-radix         set-print-radix         nil
  print-readably      set-print-readably      nil
  print-right-margin  set-print-right-margin  nil
  ~ev[]

  Each ACL2 print-control variable ~c[print-xxx] can correspond in function to
  Common Lisp variable ~c[*PRINT-XXX*].  Specifically, the evaluation of forms
  ~c[(set-print-base t)], ~c[(set-print-radix t)], and ~c[(set-print-case t)]
  affects ACL2 printing functions in much the same way that setting to ~c[t]
  Common Lisp variables ~c[*PRINT-BASE*], ~c[*PRINT-RADIX*], and
  ~c[*PRINT-CASE*], respectively, affects Common Lisp printing.  The same is
  true for ~c[print-escape], except that this does not affect ~ilc[princ$] or
  ~c[prin1$], which correspond to Common Lisp functions ~c[princ] and
  ~c[prin1]: ~c[princ] treats ~c[*PRINT-ESCAPE*] as ~c[nil] while ~c[prin1]
  treats ~c[*PRINT-ESCAPE*] as ~c[t].  Moreover, all print-control variables
  not mentioned in this paragraph are set to their defaults in ~ilc[princ$] and
  ~c[prin1$], as indicated by ACL2 constant ~c[*print-control-defaults*],
  except that ~c[print-readably] is set to ~c[nil] in ~c[princ$].

  ~ilc[Fmt] and its related functions are sensitive to state globals
  ~c['print-base], ~c['print-radix], ~c['print-case], ~c['print-escape], and
  ~c['print-readably], in analogy with Common Lisp functions that don't fix
  ~c[*PRINT-ESCAPE*] or ~c[*PRINT-READABLY*].  But the ~ilc[fmt] functions do
  not respect settings of other print-control variables; for example, they act
  as though ~c['print-circle] is ~c[nil].  Since ACL2 output is produced using
  the same underlying print routines as the ~ilc[fmt] functions, it also is
  insensitive to all print-control variables except for the five above.  To
  control the print-level and print-length used for producing ACL2 output,
  ~pl[set-evisc-tuple].

  ~il[Print-object$] is sensitive to all of the print-control variables.

  Remark on ~c[print-circle-files]: ACL2 typically binds ~c['print-circle] to
  ~c[t] before writing ~il[certificate] files, or auxiliary files that are
  compiled when ~ilc[make-event] forms are present in a book, or files in
  support of ~c[:]~ilc[comp] commands.  This binding allows for structure
  sharing that can keep these files from growing large.  However, this behavior
  is defeated in GCL (Gnu Common Lisp), because of the small number of indices
  ~c[n] available by default (1024) for the ~c[#n=] reader macro.  For the
  files described above, what actually happens is that ~c['print-circle] is
  bound to the value of ~c['print-circle-files], which by default is ~c[t]
  unless the underlying Lisp is GCL, in which case it is set to ~c[nil].
  ~l[assign] for how to set ~il[state] globals such as ~c['print-circle-files].
  For example, if you build GCL with a larger number of ~c[#n=] indices
  available, you may wish to restore the ~c[print-circle] behavior for
  ~il[certificate] files by following these instructions from Camm Maguire:
  ~bq[]
  This can trivially be revised to any larger constant by editing the
  following line of read.d and recompiling:

  ~c[#ifndef SHARP_EQ_CONTEXT_SIZE]~nl[]
  ~c[#define SHARP_EQ_CONTEXT_SIZE 500]~nl[]
  #endif~eq[]
  End of Remark.

  Evaluate ~c[(reset-print-control)] to restore all print-control variables to
  their original settings, as stored in constant ~c[*print-control-defaults*].

  (Remark for those using ACL2 built on Gnu Common Lisp (GCL) versions that are
  non-ANSI, which as of October 2008 is all GCL versions recommended for ACL2:
  Note that Common Lisp variables ~c[*PRINT-LINES*], ~c[*PRINT-MISER-WIDTH*],
  ~c[*PRINT-READABLY*], ~c[*PRINT-PPRINT-DISPATCH*], and
  ~c[*PRINT-RIGHT-MARGIN*] do not have any effect for such GCL versions.)~/~/")

(defdoc character-encoding

; Without the setting of custom:*default-file-encoding* for clisp in
; acl2.lisp, the build breaks with the following string (note the accented "i"
; in Martin, below):
;   Francisco J. Martín Mateos
; With that setting, we do not need an explicit :external-format argument for
; the call of with-open-file in acl2-check.lisp that opens a stream for
; "acl2-characters".

; Because of the comment above, save an Emacs buffer connected to this file
; after setting the necessary buffer-local variable as follows.

; (setq save-buffer-coding-system 'iso-8859-1)

  ":Doc-Section IO

  how bytes are parsed into characters~/

  When the Common Lisp reader comes across bytes in a file or at the terminal,
  they are parsed into characters.  The simplest case is when each byte that is
  read is a standard character (~pl[standard-char-p]).  It is actually quite
  common that each byte that is read corresponds to a single character.  The
  parsing of bytes into characters is based on a ~em[character encoding], that
  is, a mapping that associates one or more bytes with each legal character.

  In order to help guarantee the portability of files (including ~il[books]),
  ACL2 installs a common character encoding for reading files, often known as
  iso-8859-1 or latin-1.  For some host Lisps this character encoding is also
  used for reading from the terminal; but, sadly, this may not hold for all
  host Lisps, and may not even be possible for some of them.

  The use of the above encoding could in principle cause problems if one's
  editor produces files using an encoding other than iso-8859-1, at least if
  one uses non-standard characters.  In particular, the default Emacs buffer
  encoding may be utf-8.  If your file has non-standard characters, then in
  Emacs you can evaluate the form
  ~bv[]
  (setq save-buffer-coding-system 'iso-8859-1)
  ~ev[]
  before saving the buffer into a file.  This will happen automatically for
  users who load distributed file ~c[emacs/emacs-acl2.el] into their Emacs
  sessions.

  For an example of character encodings in action, see the community book
  ~c[books/misc/character-encoding-test.lisp].~/~/")

(defun set-forms-from-bindings (bindings)
  (declare (xargs :guard (and (symbol-alistp bindings)
                              (true-list-listp bindings))))
  (cond ((endp bindings)
         nil)
        (t (cons `(,(intern$
                     (concatenate 'string "SET-" (symbol-name (caar bindings)))
                     "ACL2")
                   ,(cadar bindings)
                   state)
                 (set-forms-from-bindings (cdr bindings))))))

(defconst *print-control-defaults*
  `((print-base ',(cdr (assoc-eq 'print-base *initial-global-table*))
                set-print-base)
    (print-case ',(cdr (assoc-eq 'print-case *initial-global-table*))
                set-print-case)
    (print-circle ',(cdr (assoc-eq 'print-circle *initial-global-table*))
                  set-print-circle)
    (print-escape ',(cdr (assoc-eq 'print-escape *initial-global-table*))
                  set-print-escape)
    (print-length ',(cdr (assoc-eq 'print-length *initial-global-table*))
                  set-print-length)
    (print-level ',(cdr (assoc-eq 'print-level *initial-global-table*))
                 set-print-level)
    (print-lines ',(cdr (assoc-eq 'print-lines *initial-global-table*))
                 set-print-lines)
    (print-pretty ',(cdr (assoc-eq 'print-pretty *initial-global-table*))
                  set-print-pretty)
    (print-radix ',(cdr (assoc-eq 'print-radix *initial-global-table*))
                  set-print-radix)
    (print-readably ',(cdr (assoc-eq 'print-readably *initial-global-table*))
                    set-print-readably)
    (print-right-margin ',(cdr (assoc-eq 'print-right-margin
                                         *initial-global-table*))
                        set-print-right-margin)))

(defun alist-difference-eq (alist1 alist2)

; We return the elements of alist1 whose keys don't exist in the domain of
; alist2.

  (declare (xargs :guard (and (alistp alist1)
                              (alistp alist2)
                              (or (symbol-alistp alist1)
                                  (symbol-alistp alist2)))))
  (if (endp alist1)
      nil
    (if (assoc-eq (caar alist1) alist2)
        (alist-difference-eq (cdr alist1) alist2)
      (cons (car alist1)
            (alist-difference-eq (cdr alist1) alist2)))))

(defmacro with-print-defaults (bindings form)
  `(state-global-let* ,(append bindings
                               (cons '(serialize-character
                                       (f-get-global 'serialize-character-system
                                                     state))
                                     (alist-difference-eq *print-control-defaults*
                                                          bindings)))
                      ,form))

(defmacro reset-print-control ()
  (cons 'pprogn
        (set-forms-from-bindings *print-control-defaults*)))

(defun digit-to-char (n)

  ":Doc-Section ACL2::ACL2-built-ins

  map a digit to a character~/
  ~bv[]
  Example:
  ACL2 !>(digit-to-char 8)
  #\\8
  ~ev[]
  For an integer ~c[n] from 0 to 15, ~c[(digit-to-char n)] is the character
  corresponding to ~c[n] in hex notation, using uppercase letters for digits
  exceeding 9.  If ~c[n] is in the appropriate range, that result is of course
  also the binary, octal, and decimal digit.~/

  The ~il[guard] for ~c[digit-to-char] requires its argument to be an
  integer between 0 and 15, inclusive.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (integerp n)
                              (<= 0 n)
                              (<= n 15))))
  (case n
        (1 #\1)
        (2 #\2)
        (3 #\3)
        (4 #\4)
        (5 #\5)
        (6 #\6)
        (7 #\7)
        (8 #\8)
        (9 #\9)
        (10 #\A)
        (11 #\B)
        (12 #\C)
        (13 #\D)
        (14 #\E)
        (15 #\F)
        (otherwise #\0)))

(defun print-base-p (print-base)

; Warning: Keep this in sync with check-print-base.

  (declare (xargs :guard t))
  (member print-base '(2 8 10 16)))

(defun explode-nonnegative-integer (n print-base ans)

  ":Doc-Section ACL2::ACL2-built-ins

  the list of ~il[characters] in the radix-r form of a number~/
  ~bv[]
  Examples:
  ACL2 !>(explode-nonnegative-integer 925 10 nil)
  (#\9 #\2 #\5)
  ACL2 !>(explode-nonnegative-integer 325 16 nil)
  (#\3 #\9 #\D)
  ~ev[]
  For a non-negative integer ~c[n], ~c[(explode-nonnegative-integer n r nil)]
  is the list of ~il[characters] in the radix-~c[r] (base-~c[r]) representation
  of ~c[n].~/

  The ~il[guard] for ~c[explode-nonnegative-integer] requires the first
  argument to be a nonnegative integer and second argument to be a valid radix
  for ACL2 (2, 8, 10, or 16).

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (integerp n)
                              (>= n 0)
                              (print-base-p print-base))
                  :mode :program))
  (cond ((or (zp n)
             (not (print-base-p print-base)))
         (cond ((null ans)

; We could use endp instead of null above, but what's the point?  Ans could be
; other than a true-listp for reasons other than that it's a non-nil atom, so
; why treat this case specially?

                '(#\0))
               (t ans)))
        (t (explode-nonnegative-integer
            (floor n print-base)
            print-base
            (cons (digit-to-char (mod n print-base))
                  ans)))))

(verify-termination-boot-strap
 explode-nonnegative-integer
 (declare (xargs :mode :logic
                 :verify-guards nil
                 :hints (("Goal" :in-theory (disable acl2-count floor))))))

(defthm true-listp-explode-nonnegative-integer

; This was made non-local in order to support the verify-termination-boot-strap
; for chars-for-tilde-@-clause-id-phrase/periods in file
; boot-strap-pass-2.lisp.

  (implies (true-listp ans)
           (true-listp (explode-nonnegative-integer n print-base ans)))
  :rule-classes :type-prescription)

(local
 (skip-proofs
  (defthm mod-n-linear
    (implies (and (not (< n 0))
                  (integerp n)
                  (print-base-p print-base))
             (and (not (< (mod n print-base) 0))
                  (not (< (1- print-base) (mod n print-base)))))
    :rule-classes :linear)))

(local
 (defthm integerp-mod
   (implies (and (integerp n) (< 0 n) (print-base-p print-base))
            (integerp (mod n print-base)))
   :rule-classes :type-prescription))

(verify-guards explode-nonnegative-integer
               :hints (("Goal" :in-theory (disable mod))))

(defun explode-atom (x print-base)

; This function prints as though the print-radix is nil.  For a version that
; uses the print-radix, see explode-atom+.

  (declare (xargs :guard (and (or (acl2-numberp x)
                                  (characterp x)
                                  (stringp x)
                                  (symbolp x))
                              (print-base-p print-base))
                  :mode :program))
  (cond ((rationalp x)
         (cond ((integerp x)
                (cond
                 ((< x 0)
                  (cons #\- (explode-nonnegative-integer
                             (- x) print-base nil)))
                 (t (explode-nonnegative-integer x print-base nil))))
               (t (append
                   (explode-atom (numerator x) print-base)
                   (cons #\/ (explode-nonnegative-integer
                              (denominator x)
                              print-base
                              nil))))))
        ((complex-rationalp x)
         (list* #\# #\C #\(
               (append (explode-atom (realpart x) print-base)
                       (cons #\Space
                             (append (explode-atom (imagpart x) print-base)
                                     '(#\)))))))
        ((characterp x) (list x))
        ((stringp x) (coerce x 'list))
        #+:non-standard-analysis
        ((acl2-numberp x)

; This case should never arise!

         (coerce "SOME IRRATIONAL OR COMPLEX IRRATIONAL NUMBER" 'list))
        (t (coerce (symbol-name x) 'list))))

(verify-termination-boot-strap ; and guards
 explode-atom
 (declare (xargs :mode :logic)))

(defun explode-atom+ (x print-base print-radix)
  (declare (xargs :guard (and (or (acl2-numberp x)
                                  (characterp x)
                                  (stringp x)
                                  (symbolp x))
                              (print-base-p print-base))
                  :mode :program))
  (cond ((null print-radix)
         (explode-atom x print-base))
        ((rationalp x)
         (cond ((eql print-base 10)
                (cond ((integerp x)
                       (append (explode-atom x 10)
                               '(#\.)))
                      (t (append '(#\# #\1 #\0 #\r)
                                 (explode-atom x 10)))))
               (t `(#\#
                    ,(case print-base
                       (2 #\b)
                       (8 #\o)
                       (otherwise #\x))
                    ,@(explode-atom x print-base)))))
        ((complex-rationalp x)
         (list* #\# #\C #\(
                (append (explode-atom+ (realpart x) print-base print-radix)
                        (cons #\Space
                              (append (explode-atom+ (imagpart x)
                                                     print-base
                                                     print-radix)
                                      '(#\)))))))
        (t (explode-atom x print-base))))

(verify-termination-boot-strap ; and guards
 explode-atom+
 (declare (xargs :mode :logic)))

(defthm true-list-listp-forward-to-true-listp-assoc-equal

; This theorem (formerly two theorems
; true-list-listp-forward-to-true-listp-assoc-eq and
; true-list-listp-forward-to-true-listp-assoc-equal) may have been partly
; responsible for a 2.5% real-time regression slowdown (3.2% user time) after
; implementing equality variants, after Version_4.2.  In particular, as a
; :type-prescription rule contributed to a significant slowdown in example4 of
; examples.lisp in community book
; books/workshops/2000/moore-manolios/partial-functions/tjvm.lisp.  So we are
; disabling the type-prescription rule by default, later below, but adding the
; :forward-chaining rule (which is necessary for admitting event file-measure
; in community book books/unicode/file-measure.lisp).

  (implies (true-list-listp l)
           (true-listp (assoc-equal key l)))
  :rule-classes (:type-prescription
                 (:forward-chaining :trigger-terms ((assoc-equal key l)))))

(defthm true-listp-cadr-assoc-eq-for-open-channels-p

; As with rule consp-assoc-equal this rule is now potentially expensive because
; of equality variants.  We disable it later, below.

  (implies (open-channels-p alist)
           (true-listp (cadr (assoc-eq key alist))))
  :rule-classes ((:forward-chaining
                  :trigger-terms ((cadr (assoc-eq key alist))))))

; It is important to disable nth in order for the rule state-p1-forward to
; work.

(local (in-theory (disable nth open-channels-p)))

(defun open-input-channel-p1 (channel typ state-state)
  (declare (xargs :guard (and (symbolp channel)
                              (state-p1 state-state)
                              (member-eq typ *file-types*))))
  #-acl2-loop-only
  (cond ((live-state-p state-state)
         (return-from open-input-channel-p1
                      (and (get channel *open-input-channel-key*)
                           (eq (get channel
                                    *open-input-channel-type-key*)
                               typ)))))
  (let ((pair (assoc-eq channel (open-input-channels state-state))))
    (and pair
         (eq (cadr (car (cdr pair))) typ))))

(defun open-output-channel-p1 (channel typ state-state)
  (declare (xargs :guard (and (symbolp channel)
                              (state-p1 state-state)
                              (member-eq typ *file-types*))))
  #-acl2-loop-only
  (cond ((live-state-p state-state)
         (return-from open-output-channel-p1
                      (and (get channel *open-output-channel-key*)
                           (eq (get channel *open-output-channel-type-key*)
                               typ)))))
  (let ((pair (assoc-eq channel (open-output-channels state-state))))
         (and pair
              (eq (cadr (car (cdr pair))) typ))))

(defun open-input-channel-p (channel typ state-state)
  (declare (xargs :guard (and (symbolp channel)
                              (state-p1 state-state)
                              (member-eq typ *file-types*))))
  (open-input-channel-p1 channel typ state-state))

(defun open-output-channel-p (channel typ state-state)
  (declare (xargs :guard (and (symbolp channel)
                              (state-p1 state-state)
                              (member-eq typ *file-types*))))
  (open-output-channel-p1 channel typ state-state))

(defun open-output-channel-any-p1 (channel state-state)
  (declare (xargs :guard (and (symbolp channel)
                              (state-p1 state-state))))
  (or (open-output-channel-p1 channel :character state-state)
      (open-output-channel-p1 channel :byte state-state)
      (open-output-channel-p1 channel :object state-state)))

(defun open-output-channel-any-p (channel state-state)
  (declare (xargs :guard (and (symbolp channel)
                              (state-p1 state-state))))
  (open-output-channel-any-p1 channel state-state))

(defun open-input-channel-any-p1 (channel state-state)
  (declare (xargs :guard (and (symbolp channel)
                              (state-p1 state-state))))
  (or (open-input-channel-p1 channel :character state-state)
      (open-input-channel-p1 channel :byte state-state)
      (open-input-channel-p1 channel :object state-state)))

(defun open-input-channel-any-p (channel state-state)
  (declare (xargs :guard (and (symbolp channel)
                              (state-p1 state-state))))
  (open-input-channel-any-p1 channel state-state))

(defmacro print-case ()
  '(f-get-global 'print-case state))

; (defmacro acl2-print-case (&optional (st 'state))
;   (declare (ignore st))
;   `(er soft 'acl2-print-case
;        "Macro ~x0 has been replaced by macro ~x1."
;        'acl2-print-case 'print-case))

(defmacro acl2-print-case (&optional (st 'state))
  `(print-case ,st))

(defun set-print-case (case state)

  ":Doc-Section IO

  control whether symbols are printed in upper case or in lower case~/

  By default, symbols are printed in upper case when vertical bars are
  not required, as specified by Common Lisp.  As with Common Lisp,
  ACL2 supports printing in a \"downcase\" mode, where symbols are
  printed in lower case.  Many printing functions (some details below)
  print characters in lower case for a symbol when the ACL2 ~il[state]
  global variable ~c[print-case] has value ~c[:downcase] and vertical bars
  are not necessary for printing that symbol.  (Thus, this state global
  functions in complete analogy to the Common Lisp global ~c[*print-case*].)
  The value ~c[print-case] is returned by ~c[(print-case)], and may be set
  using the function ~c[set-print-case] as follows.
  ~bv[]
    (set-print-case :upcase   state) ; Default printing
    (set-print-case :downcase state) ; Print symbols in lower case when
                                     ; vertical bars are not required
  ~ev[]
  The ACL2 user can expect that the ~c[:downcase] setting will have an effect
  for formatted output (~pl[fmt] and ~pl[fms]) when the directives are ~c[~~p],
  ~c[~~P], ~c[~~q], or ~c[~~Q], for built-in functions ~c[princ$] and
  ~c[prin1$], and the ~c[ppr] family of functions, and ~em[not] for built-in
  function ~c[print-object$].  For other printing functions, the effect of
  ~c[:downcase] is unspecified.~/

  Also ~pl[print-control] for other user-settable print controls.~/"

  (declare (xargs :guard (and (or (eq case :upcase) (eq case :downcase))
                              (state-p state))))
  (prog2$ (or (eq case :upcase)
              (eq case :downcase)
              (illegal 'set-print-case
                       "The value ~x0 is illegal as an ACL2 print-case, which ~
                        must be :UPCASE or :DOWNCASE."
                       (list (cons #\0 case))))
          (f-put-global 'print-case case state)))

(defmacro set-acl2-print-case (case)
  (declare (ignore case))
  '(er soft 'set-acl2-print-case
       "Macro ~x0 has been replaced by function ~x1."
       'set-acl2-print-case 'set-print-case))

(defmacro print-base (&optional (st 'state))
  `(f-get-global 'print-base ,st))

(defmacro acl2-print-base (&optional (st 'state))
  `(print-base ,st))

(defmacro print-radix (&optional (st 'state))
  `(f-get-global 'print-radix ,st))

(defmacro acl2-print-radix (&optional (st 'state))
  `(print-radix ,st))

(defun check-print-base (print-base ctx)

; Warning: Keep this in sync with print-base-p, and keep the format warning
; below in sync with princ$.

  (declare (xargs :guard t))
  (if (print-base-p print-base)
      nil
    (hard-error ctx
                "The value ~x0 is illegal as a print-base, which must be 2, ~
                 8, 10, or 16"
                (list (cons #\0 print-base))))
  #+(and (not acl2-loop-only) allegro)
  (when (> print-base 10)
    (format
     t
     "NOTE: Printing of numbers in Allegro CL may be a bit slow.  Allegro ~%~
      CL's function PRINC prints alphabetic digits in lower case, unlike ~%~
      other Lisps we have seen.  While Allegro CL is compliant with the ~%~
      Common Lisp spec in this regard, we have represented printing in the ~%~
      logic in a manner consistent with those other Lisps, and hence ~%~
      Allegro CL's PRINC violates our axioms.  Therefore, ACL2 built on ~%~
      Allegro CL prints radix-16 numbers without using the underlying ~%~
      lisp's PRINC function.~%"))
  #+(and (not acl2-loop-only) (not allegro))
  (when (int= print-base 16)
    (let ((*print-base* 16)
          (*print-radix* nil))
      (or (equal (prin1-to-string 10) "A")

; If we get here, simply include the underlying Lisp as we handle allegro in
; the raw Lisp code for princ$.

          (illegal 'check-print-base
                   "ERROR:  This Common Lisp does not print in radix 16 using ~
                    upper-case alphabetic hex digits: for example, it prints ~
                    ~x0 instead of ~x1.  Such printing is consistent with the ~
                    Common Lisp spec but is not reflected in ACL2's axioms ~
                    about printing (function digit-to-char, in support of ~
                    functions princ$ and prin1$), which in turn reflect the ~
                    behavior of the majority of Common Lisp implementations of ~
                    which we are aware.  If the underlying Common Lisp's ~
                    implementors can make a patch available to remedy this ~
                    situation, please let the ACL2 implementors know and we ~
                    will incorporate a patch for that Common Lisp.  In the ~
                    meantime, we do not see any way that this situation can ~
                    cause any unsoundness, so here is a workaround that you ~
                    can use at your own (minimal) risk.  In raw Lisp, execute ~
                    the following form:~|~%~x2~|"
                   (list (cons #\0 (prin1-to-string 10))
                         (cons #\1 "A")
                         (cons #\2 '(defun check-print-base (print-base ctx)
                                      (declare (ignore print-base ctx))
                                      nil))))))
    nil)
  #-acl2-loop-only nil)

(defun set-print-base (base state)

  ":Doc-Section IO

  control radix in which numbers are printed~/

  By default, integers and ratios are printed in base 10.  ACL2 also supports
  printing in radix 2, 8, or 16 by calling set-print-base with the desired
  radix (base).
  ~bv[]
    (set-print-base 10 state) ; Default printing
    (set-print-base 16 state) ; Print integers and ratios in hex
  ~ev[]~/

  Here is a sample log.
  ~bv[]
    ACL2 !>(list 25 25/3)
    (25 25/3)
    ACL2 !>(set-print-base 16 state)
    <state>
    ACL2 !>(list 25 25/3)
    (19 19/3)
    ACL2 !>
  ~ev[]

  ~l[set-print-radix] for how to print the radix, for example, printing the
  decimal number 25 in print-base 16 as ``~c[#x25]'' rather than ``~c[25]''.
  Also ~pl[print-control] for other user-settable print controls.

  Note: ACL2 ~il[events] and some other top-level commands (for example,
  ~ilc[thm], ~ilc[verify], and history commands such as ~c[:]~c[pe] and
  ~c[:]~c[pbt]) set the print base to 10 during their evaluation.  So
  ~ilc[set-print-base] has no effect while these forms are being
  processed.~/"

  (declare (xargs :guard (and (print-base-p base)
                              (state-p state))))
  (prog2$ (check-print-base base 'set-print-base)
          (f-put-global 'print-base base state)))

(defmacro set-acl2-print-base (base)
  (declare (ignore base))
  '(er soft 'set-acl2-print-base
       "Macro ~x0 has been replaced by function ~x1."
       'set-acl2-print-base 'set-print-base))

(defun set-print-circle (x state)
  (declare (xargs :guard (state-p state)))
  (f-put-global 'print-circle x state))

(defun set-print-escape (x state)
  (declare (xargs :guard (state-p state)))
  (f-put-global 'print-escape x state))

(defun set-print-pretty (x state)
  (declare (xargs :guard (state-p state)))
  (f-put-global 'print-pretty x state))

(defun set-print-radix (x state)

  ":Doc-Section IO

  control printing of the radix for numbers~/

  ~l[set-print-base] for background on how the print base affects the printing
  of numbers.  ~c[set-print-radix] affects whether a radix indicated when a
  number is printed.  The radix is not indicated by default, or after
  evaluating ~c[(set-print-radix nil state)].  But if ~c[set-print-radix] is
  called with a first argument that evaluates to a non~c[nil] value ~-[] for
  example, ~c[(set-print-radix t state)] ~-[] then the radix is shown when
  printing.  (This behavior is consistent with the handling of Common Lisp
  global ~c[*print-radix*].)  The following log illustrates how this works.

  ~bv[]
  ACL2 !>(list 25 25/3)
  (25 25/3)
  ACL2 !>(set-print-base 16 state)
  <state>
  ACL2 !>(list 25 25/3)
  (19 19/3)
  ACL2 !>(set-print-radix t state)
  <state>
  ACL2 !>(list 25 25/3)
  (#x19 #x19/3)
  ACL2 !>(set-print-base 10 state)
  <state>
  ACL2 !>(list 25 25/3)
  (25. #10r25/3)
  ACL2 !>(set-print-radix nil state)
  <state>
  ACL2 !>(list 25 25/3)
  (25 25/3)
  ACL2 !>
  ~ev[]

  ~/~/"

  (declare (xargs :guard (state-p state)))
  (f-put-global 'print-radix x state))

(defun set-print-readably (x state)
  (declare (xargs :guard (state-p state)))
  (f-put-global 'print-readably x state))

(defun check-null-or-natp (n fn)
  (declare (xargs :guard t))
  (or (null n)
      (natp n)
      (hard-error fn
                  "The argument of ~x0 must be ~x1 or a positive integer, but ~
                   ~x2 is neither."
                  (list (cons #\0 fn)
                        (cons #\1 nil)
                        (cons #\2 n)))))

(defun set-print-length (n state)
  (declare (xargs :guard (and (or (null n) (natp n))
                              (state-p state))))
  (prog2$ (check-null-or-natp n 'set-print-length)
          (f-put-global 'print-length n state)))

(defun set-print-level (n state)
  (declare (xargs :guard (and (or (null n) (natp n))
                              (state-p state))))
  (prog2$ (check-null-or-natp n 'set-print-level)
          (f-put-global 'print-level n state)))

(defun set-print-lines (n state)
  (declare (xargs :guard (and (or (null n) (natp n))
                              (state-p state))))
  (prog2$ (check-null-or-natp n 'set-print-lines)
          (f-put-global 'print-lines n state)))

(defun set-print-right-margin (n state)
  (declare (xargs :guard (and (or (null n) (natp n))
                              (state-p state))))
  (prog2$ (check-null-or-natp n 'set-print-right-margin)
          (f-put-global 'print-right-margin n state)))

#-acl2-loop-only
(defmacro get-input-stream-from-channel (channel)
  (list 'get
        channel
        (list 'quote *open-input-channel-key*)
        (list 'quote *non-existent-stream*)))

#-acl2-loop-only
(defmacro get-output-stream-from-channel (channel)
  (list 'get
        channel
        (list 'quote *open-output-channel-key*)
        (list 'quote *non-existent-stream*)))

#-acl2-loop-only
(defmacro with-print-controls (default bindings &rest body)

; Warning; If you bind *print-base* to value pb (in bindings), then you should
; strongly consider binding *print-radix* to t if pb exceeds 10 and to nil
; otherwise.

  (when (not (member-eq default '(:defaults :current)))
    (error "The first argument of with-print-controls must be :DEFAULT ~
            or :CURRENT."))
  (let ((raw-print-vars-alist
         '((*print-base* print-base . (f-get-global 'print-base state))
           (*print-case* print-case . (f-get-global 'print-case state))
           (*print-circle* print-circle . (f-get-global 'print-circle state))
           (*print-escape* print-escape . (f-get-global 'print-escape state))
           (*print-length* print-length . (f-get-global 'print-length state))
           (*print-level* print-level . (f-get-global 'print-level state))
           #+cltl2
           (*print-lines* print-lines . (f-get-global 'print-lines state))
           #+cltl2
           (*print-miser-width* nil . nil)
           (*print-pretty* print-pretty . (f-get-global 'print-pretty state))
           (*print-radix* print-radix . (f-get-global 'print-radix state))
           (*print-readably* print-readably . (f-get-global 'print-readably
                                                            state))

; At one time we did something with *print-pprint-dispatch* for #+cltl2.  But
; as of May 2013, ANSI GCL does not comprehend this variable.  So we skip it
; here.  In fact we skip it for all host Lisps, assuming that users who mess
; with *print-pprint-dispatch* in raw Lisp take responsibility for knowing what
; they're doing!

;          #+cltl2
;          (*print-pprint-dispatch* nil . nil)
           #+cltl2
           (*print-right-margin*
            print-right-margin . (f-get-global 'print-right-margin state)))))
    (when (not (and (alistp bindings)
                    (let ((vars (strip-cars bindings)))
                      (and (subsetp-eq vars (strip-cars raw-print-vars-alist))
                           (no-duplicatesp vars)))))
      (error "With-print-controls has illegal bindings:~%  ~s"
             bindings))
    `(let ((state *the-live-state*))
       (let ((*read-base* 10) ; just to be safe
             (*readtable* *acl2-readtable*)
             #+cltl2 (*read-eval* nil) ; to print without using #.
             (*package* (find-package-fast (current-package state)))
             ,@bindings)
         (let ,(loop for triple in raw-print-vars-alist
                     when (not (assoc-eq (car triple) bindings))
                     collect
                     (let ((lisp-var (car triple))
                           (acl2-var (cadr triple)))
                       (list lisp-var
                             (cond ((and acl2-var
                                         (eq default :defaults))
                                    (cadr (assoc-eq acl2-var
                                                    *print-control-defaults*)))
                                   (t (cddr triple))))))
              ,@body)))))

; ?? (v. 1.8) I'm not going to look at many, or any, of the skip-proofs
; events on this pass.
(skip-proofs
(defun princ$ (x channel state-state)

  ":Doc-Section ACL2::ACL2-built-ins

  print an atom~/

  Use ~c[princ$] to do basic printing of atoms (i.e., other than ~c[cons]
  pairs).  In particular, ~c[princ$] prints a string without the surrounding
  double-quotes and without escaping double-quote characters within the string.
  Note that ~c[princ$] is sensitive to the print-base, print-radix, and
  print-case; ~pl[set-print-base], ~pl[set-print-radix], and
  ~pl[set-print-case].  ~c[Princ$] returns ~ilc[state].
  ~bv[]
  Examples:
  ACL2 !>(princ$ \"Howdy ho\" (standard-co state) state)
  Howdy ho<state>
  ACL2 !>(pprogn (princ$ \"Howdy ho\" (standard-co state) state)
                 (newline (standard-co state) state))
  Howdy ho
  <state>
  ACL2 !>(princ$ \"ab\\\"cd\" *standard-co* state)
  ab\"cd<state>
  ACL2 !>
  ACL2 !>(princ$ 17 *standard-co* state)
  17<state>
  ACL2 !>(set-print-base 16 state)
  <state>
  ACL2 !>(princ$ 17 *standard-co* state)
  11<state>
  ACL2 !>(set-print-radix t state)
  <state>
  ACL2 !>(princ$ 17 *standard-co* state)
  #x11<state>
  ACL2 !>(princ$ 'xyz *standard-co* state)
  XYZ<state>
  ACL2 !>(set-print-case :downcase state)
  <state>
  ACL2 !>(princ$ 'xyz *standard-co* state)
  xyz<state>
  ACL2 !>
  ~ev[]~/

  The ~il[guard] for ~c[(princ$ x channel state)] is essentially as follows; ~pl[io]
  for an explanation of guards of certain built-in functions that take
  ~il[state], such as ~c[princ$].
  ~bv[]
  (and (or (acl2-numberp x)
           (characterp x)
           (stringp x)
           (symbolp x))
       (state-p1 state-state)
       (symbolp channel)
       (open-output-channel-p1 channel :character state-state))
  ~ev[]

  ~l[fmt] for more sophisticated printing routines, and ~pl[IO] for general
  information about input and output.~/

  :cited-by IO"

; Wart: We use state-state instead of state because of a bootstrap problem.

; The ACL2 princ$ does not handle conses because we are unsure what
; the specification of the real Common Lisp princ is concerning the
; insertion of spaces and newlines into the resulting text.

  (declare (xargs :guard (and (or (acl2-numberp x)
                                  (characterp x)
                                  (stringp x)
                                  (symbolp x))
                              (state-p1 state-state)
                              (symbolp channel)
                              (open-output-channel-p1
                               channel :character state-state))))
  #-acl2-loop-only
  (cond ((live-state-p state-state)
         (cond ((and *wormholep*
                     (not (eq channel *standard-co*)))

; If the live state is protected, then we allow output only to the
; *standard-co* channel.  This is a little unexpected.  The intuitive
; arrangement would be to allow output only to a channel whose actual
; stream was pouring into the wormhole window.  Unfortunately, we do not
; know a good way to determine the ultimate stream to which a synonym
; stream is directed and hence cannot implement the intuitive
; arrangement.  Instead we must assume that if *the-live-state-
; protected* is non-nil, then the standard channels have all been
; directed to acceptable streams and that doing i/o on them will not
; affect the streams to which they are normally directed.

                (wormhole-er 'princ$ (list x channel))))
         (let ((stream (get-output-stream-from-channel channel)))
           (cond
            ((stringp x)

; We get a potentially significant efficiency boost by using write-string when
; x is a string.  A few experiments suggest that write-string may be slightly
; more efficient than write-sequence (which isn't available in non-ANSI GCL
; anyhow), which in turn may be much more efficient than princ.  It appears
; that the various print-controls don't affect the printing of strings, except
; for *print-escape* and *print-readably*; and the binding of *print-escape* to
; nil by princ seems to give the behavior of write-string, which is specified
; simply to print the characters of the string.

             (write-string x stream))
            (t
             (with-print-controls

; We use :defaults here, binding only *print-escape* and *print-readably* (to
; avoid |..| on symbols), to ensure that raw Lisp agrees with the logical
; definition.

              :defaults
              ((*print-escape* nil)
               (*print-readably* nil) ; unnecessary if we keep current default
               (*print-base* (f-get-global 'print-base state))
               (*print-radix* (f-get-global 'print-radix state))
               (*print-case* (f-get-global 'print-case state)))
              #+allegro

; See the format call in check-print-base for why we take this extra effort for
; Allegro (in short, to print digit characters in upper case).

              (princ (cond ((and (rationalp x)
                                 (> *print-base* 10))
                            (coerce (explode-atom+ x
                                                   *print-base*
                                                   *print-radix*)
                                    'string))
                           (t x))
                     stream)
              #-allegro
              (princ x stream))))
           (cond ((eql x #\Newline)
                  (force-output stream)))
           (return-from princ$ *the-live-state*))))
  (let ((entry (cdr (assoc-eq channel (open-output-channels state-state)))))
    (update-open-output-channels
     (add-pair channel
               (cons (car entry)
                     (revappend
                      (if (and (symbolp x)

; The form (cdr (assoc-eq ...)) below is closely related to a call of
; print-case where state is replaced by state-state.  However, the problem
; explained in the essay "On STATE-STATE" hits us here.  That is, print-case
; generates a call of get-global, which, by the time this form is processed in
; the logic during boot-strap, expects state as an argument.  We do not have
; state available here.  We could modify print-case to take an optional
; argument and supply state-state for that argument, but that would not work
; either because get-global expects state.

                               (eq (cdr (assoc-eq 'print-case
                                                  (global-table state-state)))
                                   :downcase))
                          (coerce (string-downcase (symbol-name x))
                                  'list)
                        (explode-atom+ x
                                       (cdr (assoc-eq 'print-base
                                                      (global-table
                                                       state-state)))
                                       (cdr (assoc-eq 'print-radix
                                                      (global-table
                                                       state-state)))))
                      (cdr entry)))
               (open-output-channels state-state))
     state-state)))
)

(defun write-byte$ (x channel state-state)

; Wart: We use state-state instead of state because of a bootstrap problem.

  (declare (xargs :guard (and (integerp x)
                              (>= x 0)
                              (< x 256)
                              (state-p1 state-state)
                              (symbolp channel)
                              (open-output-channel-p1 channel
                                                      :byte state-state))))
  #-acl2-loop-only
  (cond ((live-state-p state-state)
         (cond ((and *wormholep*
                     (not (eq channel *standard-co*)))
                (wormhole-er 'write-byte$ (list x channel))))
         (let ((stream (get-output-stream-from-channel channel)))
           (write-byte x stream)
           (return-from write-byte$ *the-live-state*))))
  (let ((entry (cdr (assoc-eq channel (open-output-channels state-state)))))
    (update-open-output-channels
     (add-pair channel
               (cons (car entry)
                     (cons x
                           (cdr entry)))
               (open-output-channels state-state))
     state-state)))

#-acl2-loop-only
(defvar *print-circle-stream* nil)

(defmacro er (severity context str &rest str-args)

; Keep in sync with er@par.

  (declare (xargs :guard (and (true-listp str-args)
                              (member-symbol-name (symbol-name severity)
                                                  '(hard hard? hard! hard?!
                                                         soft very-soft))
                              (<= (length str-args) 10))))

; Note: We used to require (stringp str) but then we started writing such forms
; as (er soft ctx msg x y z), where msg was bound to the error message str
; (because the same string was used many times).

; The special form (er hard "..." &...) expands into a call of illegal on "..."
; and an alist built from &....  Since illegal has a guard of nil, the attempt
; to prove the correctness of a fn producing a hard error will require proving
; that the error can never occur.  At runtime, illegal causes a CLTL error.

; The form (er soft ctx "..." &...) expands into a call of error1 on ctx, "..."
; and an alist built from &....  At runtime error1 builds an error object and
; returns it.  Thus, soft errors are not errors at all in the CLTL sense and
; any function calling one which might cause an error ought to handle it.

; Just to make it easier to debug our code, we have arranged for the er macro
; to actually produce a prog2 form in which the second arg is as described
; above but the preceding one is an fmt statement which will actually print the
; error str and alist.  Thus, we can see when soft errors occur, whether or not
; the calling program handles them appropriately.

; We do not advertise the hard! or very-soft severities, at least not yet.  The
; implementation uses the former to force a hard error even in contexts where
; we would normally return nil.

  ":Doc-Section ACL2::ACL2-built-ins

  print an error message and ``cause an error''~/

  ~l[fmt] for a general discussion of formatted printing in ACL2.  All calls of
  ~c[er] print formatted strings, just as is done by ~ilc[fmt].

  ~bv[]
  Example Forms:
  (er hard  'top-level \"Illegal inputs, ~~x0 and ~~x1.\" a b)
  (er hard? 'top-level \"Illegal inputs, ~~x0 and ~~x1.\" a b)
  (er soft  'top-level \"Illegal inputs, ~~x0 and ~~x1.\" a b)
  ~ev[]
  The examples above all print an error message to standard output saying that
  ~c[a] and ~c[b] are illegal inputs.  However, the first two abort evaluation
  after printing an error message (while logically returning ~c[nil], though in
  ordinary evaluation the return value is never seen); while the third returns
  ~c[(mv t nil state)] after printing an error message.  The result in the
  third case can be interpreted as an ``error'' when programming with the ACL2
  ~ilc[state], something most ACL2 users will probably not want to do unless
  they are building systems of some sort; ~pl[programming-with-state].  If
  state is not available in the current context then you will probably want to
  use ~c[(er hard ...)] or ~c[(er hard? ...)] to cause an error; for example,
  if you are returning two values, you may write ~c[(mv (er hard ...) nil)].

  The difference between the ~c[hard] and ~c[hard?] forms is one of guards.
  Use ~c[hard] if you want the call to generate a (clearly impossible) guard
  proof obligation of (essentially) ~c[NIL].  But use ~c[hard?] if you want to
  be able to call this function in guard-verified code, since the call
  generates a (trivially satisfied) guard proof obligation of ~c[T].

  ~c[Er] is a macro, and the above three examples expand to calls of ACL2
  functions, as shown below.  ~l[illegal], ~pl[hard-error], and ~pl[error1].
  The first two have guards of (essentially) ~c[NIL] and ~c[T], respectively,
  while ~ilc[error1] is in ~c[:]~ilc[program] mode.~/
  ~bv[]
  General forms:
  (er hard  ctx fmt-string arg1 arg2 ... argk)
    ==> {macroexpands, in essence, to:}
  (ILLEGAL    CTX FMT-STRING
              (LIST (CONS #\\0 ARG1) (CONS #\\1 ARG2) ... (CONS #\\k ARGk)))

  (er hard? ctx fmt-string arg1 arg2 ... argk)
    ==> {macroexpands, in essence, to:}
  (HARD-ERROR CTX FMT-STRING
              (LIST (CONS #\\0 ARG1) (CONS #\\1 ARG2) ... (CONS #\\k ARGk)))

  (er soft  ctx fmt-string arg1 arg2 ... argk)
    ==> {macroexpands, in essence, to:}
  (ERROR1     CTX FMT-STRING
              (LIST (CONS #\\0 ARG1) (CONS #\\1 ARG2) ... (CONS #\\k ARGk)))
  ~ev[]~/"

  (let ((alist (make-fmt-bindings '(#\0 #\1 #\2 #\3 #\4
                                    #\5 #\6 #\7 #\8 #\9)
                                  str-args))
        (severity-name (symbol-name severity)))
    (cond ((equal severity-name "SOFT")
           (list 'error1 context str alist 'state))
          ((equal severity-name "VERY-SOFT")
           (list 'error1-safe context str alist 'state))
          ((equal severity-name "HARD?")
           (list 'hard-error context str alist))
          ((equal severity-name "HARD")
           (list 'illegal context str alist))
          ((equal severity-name "HARD!")
           #+acl2-loop-only (list 'illegal context str alist)
           #-acl2-loop-only `(let ((*hard-error-returns-nilp* nil))
                              (illegal ,context ,str ,alist)))
          ((equal severity-name "HARD?!")
           #+acl2-loop-only (list 'hard-error context str alist)
           #-acl2-loop-only `(let ((*hard-error-returns-nilp* nil))
                              (hard-error ,context ,str ,alist)))
          (t

; The final case should never happen.

           (illegal 'top-level
                    "Illegal severity, ~x0; macroexpansion of ER failed!"
                    (list (cons #\0 severity)))))))

#+acl2-par
(defmacro er@par (severity context str &rest str-args)

; Keep in sync with er.

  (declare (xargs :guard (and (true-listp str-args)
                              (member-symbol-name (symbol-name severity)
                                                  '(hard hard? hard! soft
                                                         very-soft))
                              (<= (length str-args) 10))))
  (let ((alist (make-fmt-bindings '(#\0 #\1 #\2 #\3 #\4
                                    #\5 #\6 #\7 #\8 #\9)
                                  str-args))
        (severity-name (symbol-name severity)))
    (cond ((equal severity-name "SOFT")
           (list 'error1@par context str alist 'state))
          (t

; The final case should never happen.

           (illegal 'top-level
                    "Illegal severity, ~x0; macroexpansion of ER@PAR failed!"
                    (list (cons #\0 severity)))))))

(defun get-serialize-character (state)
  (declare (xargs :guard (and (state-p state)
                              (boundp-global 'serialize-character state))))
  (f-get-global 'serialize-character state))

(defun w (state)
  (declare (xargs :guard (state-p state)

; We have moved the definition of w up to here, so that we can call it from
; hons-enabledp, which is called from set-serialize-character, which we prefer
; to define before print-object$.  We have verified its guards successfully
; later in this file, where w was previously defined.  So rather fight that
; battle here, we verify guards at the location of its original definition.

                  :verify-guards nil))
  (f-get-global 'current-acl2-world state))

(defun hons-enabledp (state)
  (declare (xargs :verify-guards nil ; wait for w
                  :guard (state-p state)))
  (global-val 'hons-enabled (w state)))

(defun set-serialize-character (c state)
  (declare (xargs :verify-guards nil ; wait for hons-enabledp
                  :guard (and (state-p state)
                              (or (null c)
                                  (and (hons-enabledp state)
                                       (member c '(#\Y #\Z)))))))
  (cond
   ((or (null c)
        (and (hons-enabledp state)
             (member c '(#\Y #\Z))))
    (f-put-global 'serialize-character c state))
   (t ; presumably guard-checking is off
    (prog2$
     (cond ((not (hons-enabledp state)) ; and note that c is not nil
            (er hard 'set-serialize-character
                "It is currently only legal to call ~x0 with a non-nil first ~
                 argument in a hons-enabled version of ACL2.  If this ~
                 presents a problem, feel free to contact the ACL2 ~
                 implementors."
                'set-serialize-character))
           (t
            (er hard 'set-serialize-character
                "The first argument of a call of ~x0 must be ~v1.  The ~
                 argument ~x2 is thus illegal."
                'set-serialize-character '(nil #\Y #\Z) c)))
     state))))

(defun print-object$-ser (x serialize-character channel state-state)

; Wart: We use state-state instead of state because of a bootstrap problem.

; This function is a version of print-object$ that allows specification of the
; serialize-character, which can be nil (the normal case for #-hons), #\Y, or
; #\Z (the normal case for #+hons).  However, we currently treat this as nil in
; the #-hons version.

; See print-object$ for additional comments.

  (declare (ignorable serialize-character) ; only used when #+hons
           (xargs :guard (and (state-p1 state-state)
                              (member serialize-character '(nil #\Y #\Z))
                              (symbolp channel)
                              (open-output-channel-p1 channel
                                                      :object state-state))))
  #-acl2-loop-only
  (cond ((live-state-p state-state)
         (cond (*wormholep*

; There is no standard object output channel and hence this channel is
; directed to some unknown user-specified sink and we can't touch it.

                (wormhole-er 'print-object$ (list x channel))))
         (let ((stream (get-output-stream-from-channel channel)))
           (declare (special acl2_global_acl2::current-package))

; Note: If you change the following bindings, consider changing the
; corresponding bindings in print-object$.

           (with-print-controls
            :current
            ((*print-circle* (and *print-circle-stream*
                                  (f-get-global 'print-circle state-state))))
            (terpri stream)
            (or #+hons
                (cond (serialize-character
                       (write-char #\# stream)
                       (write-char serialize-character stream)
                       (ser-encode-to-stream x stream)
                       t))
                (prin1 x stream))
            (force-output stream)))
         (return-from print-object$-ser *the-live-state*)))
  (let ((entry (cdr (assoc-eq channel (open-output-channels state-state)))))
    (update-open-output-channels
     (add-pair channel
               (cons (car entry)
                     (cons x
                           (cdr entry)))
               (open-output-channels state-state))
     state-state)))

(defthm all-boundp-preserves-assoc-equal
  (implies (and (all-boundp tbl1 tbl2)
                (assoc-equal x tbl1))
           (assoc-equal x tbl2))
  :rule-classes nil)

(local
 (defthm all-boundp-initial-global-table
  (implies (and (state-p1 state)
                (assoc-eq x *initial-global-table*))
           (assoc x (nth 2 state)))
  :hints (("Goal" :use
           ((:instance all-boundp-preserves-assoc-equal
                       (tbl1 *initial-global-table*)
                       (tbl2 (nth 2 state))))
           :in-theory (disable all-boundp)))))

(defun print-object$ (x channel state)

; WARNING: In the HONS version, be sure to use with-output-object-channel-sharing
; rather than calling open-output-channel directly, so that
; *print-circle-stream* is initialized.

; We believe that if in a single Common Lisp session, one prints an object and
; then reads it back in with print-object$ and read-object, one will get back
; an equal object under the assumptions that (a) the package structure has not
; changed between the print and the read and (b) that *package* has the same
; binding.  On a toothbrush, all calls of defpackage will occur before any
; read-objecting or print-object$ing, so the package structure will be the
; same.  It is up to the user to set current-package back to what it was at
; print time if he hopes to read back in the same object.

; Warning: For soundness, we need to avoid using iprinting when writing to
; certificate files.  We do all such writing with print-object$, so we rely on
; print-object$ not to use iprinting.

  (declare (xargs :guard (and (state-p state)

; We might want to modify state-p (actually, state-p1) so that the following
; conjunct is not needed.

                              (member (get-serialize-character state)
                                      '(nil #\Y #\Z))
                              (symbolp channel)
                              (open-output-channel-p channel
                                                     :object state))))
  (print-object$-ser x (get-serialize-character state) channel state))

;  We start the file-clock at one to avoid any possible confusion with
; the wired in standard-input/output channels, whose names end with
; "-0".

#-acl2-loop-only
(defparameter *file-clock* 1)

(skip-proofs
(defun make-input-channel (file-name clock)
  (declare (xargs :guard (and (rationalp clock)
                              (standard-char-listp (explode-atom clock 10))
                              (stringp file-name)
                              (standard-char-listp (coerce file-name 'list)))))
  (intern (coerce
           (append (coerce file-name 'list)
                   (cons '#\-
                         (explode-atom clock 10)))
           'string)
          "ACL2-INPUT-CHANNEL"))
)

(skip-proofs
(defun make-output-channel (file-name clock)
  (declare (xargs :guard (and (rationalp clock)
                              (standard-char-listp (explode-atom clock 10))
                              (or (eq file-name :string)
                                  (and (stringp file-name)
                                       (standard-char-listp
                                        (coerce file-name 'list)))))))
  (intern (coerce (cond ((eq file-name :string)
                         (explode-atom clock 10))
                        (t (append (coerce file-name 'list)
                                   (cons '#\-
                                         (explode-atom clock 10)))))
                  'string)
          "ACL2-OUTPUT-CHANNEL"))
)

; We here set up the property list of the three channels that are open
; at the beginning.  The order of the setfs and the superfluous call
; of symbol-name are to arrange, in AKCL, for the stream component to
; be first on the property list.

#-acl2-loop-only
(defun-one-output setup-standard-io ()
  (symbol-name 'acl2-input-channel::standard-object-input-0)
  (setf (get 'acl2-input-channel::standard-object-input-0
             *open-input-channel-type-key*)
        :object)
  (setf (get 'acl2-input-channel::standard-object-input-0

; Here, and twice below, we use *standard-input* rather than
; (make-synonym-stream '*standard-input*) because Allegro doesn't
; seem to print to such a synonym stream.  Perhaps it's relevant
; that (interactive-stream-p (make-synonym-stream '*standard-input*))
; evaluates to nil in Allegro, but
; (interactive-stream-p *standard-input*) evaluates to t.

             *open-input-channel-key*)
        *standard-input*)
  (symbol-name 'acl2-input-channel::standard-character-input-0)
  (setf (get 'acl2-input-channel::standard-character-input-0
             *open-input-channel-type-key*)
        :character)
  (setf (get 'acl2-input-channel::standard-character-input-0
             *open-input-channel-key*)
        *standard-input*)
  (symbol-name 'acl2-output-channel::standard-character-output-0)
  (setf (get 'acl2-output-channel::standard-character-output-0
             *open-output-channel-type-key*)
        :character)
  (setf (get 'acl2-output-channel::standard-character-output-0
             *open-output-channel-key*)
        *standard-output*))

#-acl2-loop-only
(eval-when
 #-cltl2
 (load eval compile)
 #+cltl2
 (:load-toplevel :execute :compile-toplevel)
 (setup-standard-io))

#-acl2-loop-only
(defun-one-output lisp-book-syntaxp1 (s stream)

; See the parent function.  This is a tail-recursive finite state acceptor.
; Our state s is one of:

; 0 - scanning spaces, tabs and newlines,
; semi - scanning thru the next newline (we saw a ; on this line)
; n>0    - (positive integer) scanning to the balancing bar hash sign.
; (hash . s) - just saw a hash sign in state s:  if next char is
;              a vertical bar, we've entered a new comment level.
;              The s here is either 0 or n>0, i.e., we were in a
;              state where hash bar opens a comment.
; (bar . s) - just saw a vertical bar in state s:  if next char is hash
;             we've exited a comment level.  The s here is always an n>0,
;             i.e., we were in a state where bar hash closes a comment.
; charlist - we insist that the n next chars in the file be the n chars
;            in charlist; we return t if so and nil if not.
; list-of-charlist - we insist that the next char be one of the keys in
;            this alist and that subsequent chars be as in corresponding
;            value.

  (let ((char1 (read-char stream nil nil)))
    (cond
     ((null char1) nil)
     ((eq s 'semi)
      (cond
       ((eql char1 #\Newline)
        (lisp-book-syntaxp1 0 stream))
       (t (lisp-book-syntaxp1 'semi stream))))
     ((integerp s)
      (cond
       ((= s 0)
        (cond
         ((member char1 '(#\Space #\Tab #\Newline))
          (lisp-book-syntaxp1 0 stream))
         ((eql char1 #\;)
          (lisp-book-syntaxp1 'semi stream))
         ((eql char1 #\#)
          (lisp-book-syntaxp1 '(hash . 0) stream))
         ((eql char1 #\()
          (lisp-book-syntaxp1
           '((#\I #\N #\- #\P #\A #\C #\K #\A #\G #\E #\Space #\")
             (#\L #\I #\S #\P #\:
              . (    (#\I #\N #\- #\P #\A #\C #\K #\A #\G #\E #\Space #\")
                     (#\: #\I #\N #\- #\P #\A #\C #\K #\A #\G #\E #\Space #\")))
             (#\A #\C #\L #\2 #\: #\:
              #\I #\N #\- #\P #\A #\C #\K #\A #\G #\E #\Space #\")) stream))
         (t nil)))
       ((eql char1 #\#)
        (lisp-book-syntaxp1 (cons 'hash s) stream))
       ((eql char1 #\|)
        (lisp-book-syntaxp1 (cons 'bar s) stream))
       (t (lisp-book-syntaxp1 s stream))))
     ((null s) t)
     ((eq (car s) 'hash)
      (cond
       ((eql char1 #\|)
        (lisp-book-syntaxp1 (1+ (cdr s)) stream))
       ((= (cdr s) 0) #\#)
       ((eql char1 #\#)
        (lisp-book-syntaxp1 s stream))
       (t (lisp-book-syntaxp1 (cdr s) stream))))
     ((eq (car s) 'bar)
      (cond
       ((eql char1 #\#)
        (lisp-book-syntaxp1 (1- (cdr s)) stream))
       ((eql char1 #\|)
        (lisp-book-syntaxp1 s stream))
       (t (lisp-book-syntaxp1 (cdr s) stream))))
     ((characterp (car s))
      (cond
       ((eql (char-upcase char1) (car s))
        (lisp-book-syntaxp1 (cdr s) stream))
       (t nil)))
     (t ; (car s) is a list of alternative character states
      (let ((temp (assoc (char-upcase char1) s)))
        (cond
         ((null temp) nil)
         (t (lisp-book-syntaxp1 (cdr temp) stream))))))))

#-acl2-loop-only
(defun-one-output lisp-book-syntaxp (file)

; We determine whether file is likely to be an ACL2 book in lisp syntax.  In
; particular, we determine whether file starts with an optional Lisp comment
; followed by (IN-PACKAGE "....  The comment may be any number of lines;
; (possibly empty) whitespace, semi-colon style comments and nested #|...|#
; comments are recognized as "comments" here.  We further allow the IN-PACKAGE
; to be written in any case and we allow the optional package designators:
; LISP:, LISP::, and ACL2::.  We insist that there be no space between the
; open-parenthesis and the IN-PACKAGE symbol.  Finally, after the IN-PACKAGE,
; we insist that there be exactly one space followed by a string quote followed
; by at least one more character in the file.  If these conditions are met we
; return t; otherwise we return nil.

  (cond
   ((null (f-get-global 'infixp *the-live-state*))
    t)
   (t
    (let ((stream (safe-open file :direction :input :if-does-not-exist nil)))
      (if stream
          (unwind-protect (lisp-book-syntaxp1 0 stream)
            (close stream))
        nil)))))

#-acl2-loop-only
(defparameter *parser* nil)

; If *parser* is non-nil then it should be set to a string that names a Unix
; command that parses a file.  Suppose *parser* is set to "infixparse".  Then
; we will use the Unix command

; % infixparse < foo.lisp > foo.lisp.mirror

; to generate from "foo.lisp" a file of s-expressions "foo.lisp.mirror".  The
; unix command should return error code 3 if the parse fails.  Otherwise, the
; parse is assumed to have worked.

#-acl2-loop-only
(defun-one-output parse-infix-file (infile outfile)

; This function is only used with the silly $ infix syntax.  It is the analogue
; of the *parse* Unix command that transforms a $ infix file to its
; s-expression image.  Rather than make it be a Unix command and pay the
; complexity and performance cost of firing off another process, we just
; implement it it directly in this image for the $ syntax.

  (with-open-file
   (file1 infile :direction :input)
   (with-open-file
    (file2 outfile :direction :output)
    (prog ((form nil)
           (eof (cons nil nil)))
          loop
          (setq form (read file1 nil eof))
          (cond ((eq form eof) (return nil))
                ((eq form '$)
                 (setq form (read file1 nil eof))
                 (cond ((eq form eof)
                        (error "Bad $ infix syntax in ~s.  Ended with a $."
                               (namestring file1)))
                       (t (print form file2))))
                (t (error "Bad $ infix syntax in file ~s.   Missing $ before ~
                           s-expr ending at position ~a."
                          (namestring file1)
                          (file-position file1))))
          (go loop)))))

(skip-proofs
(defun open-input-channel (file-name typ state-state)

; Wart: We use state-state instead of state because of a bootstrap problem.

; Here, file-name is an ACL2 file name (i.e., with Unix-style syntax).

; It is possible to get an error when opening an output file.  We consider that
; a resource error for purposes of the story.  Note that starting after
; Version_6.1, an error is unlikely except for non-ANSI GCL because of our use
; of safe-open.

  (declare (xargs :guard (and (stringp file-name)
                              (member-eq typ *file-types*)
                              (state-p1 state-state))))
  #-acl2-loop-only
  (cond ((live-state-p state-state)
         (cond (*wormholep*
                (wormhole-er 'open-input-channel (list file-name typ))))
         (return-from
          open-input-channel
          (progn
            (setq *file-clock* (1+ *file-clock*))

; We do two different opens here because the default :element-type is
; different in CLTL and CLTL2.

            (let ((os-file-name
                   (pathname-unix-to-os file-name *the-live-state*)))

; Protect against the sort of behavior Bob Boyer has pointed out for GCL, as
; the following kills all processes:

              (cond
               ((and (not (equal os-file-name ""))
                     (eql (char os-file-name 0) #\|))
                (error "It is illegal in ACL2 to open a filename whose ~%~
                        first character is |, as this may permit dangerous ~%~
                        behavior.  For example, in GCL the following kills ~%~
                        all processes:~%~%~s~%"
                       '(open "|kill -9 -1"))))
              (let ((stream
                     (case
                       typ
                       ((:character :object)
                        (safe-open os-file-name :direction :input
                                   :if-does-not-exist nil))
                       (:byte (safe-open os-file-name :direction :input
                                         :element-type '(unsigned-byte 8)
                                         :if-does-not-exist nil))
                       (otherwise
                        (interface-er "Illegal input-type ~x0." typ)))))
                (cond
                 ((null stream) (mv nil *the-live-state*))
                 #+akcl
                 ((and (eq typ :object)
                       (not (lisp-book-syntaxp os-file-name)))

; Note that lisp-book-syntaxp returns t unless state global 'infixp is t.  So
; ignore the code below unless you're thinking about the infix case!

                  (let* ((mirror-file-name
                          (concatenate 'string
                                       (namestring stream)
                                       ".mirror"))
                         (er-code
                          (cond
                           (*parser*
                            (si::system
                             (format nil "~s < ~s > ~s"
                                     *parser*
                                     (namestring stream)
                                     mirror-file-name)))
                           (t (parse-infix-file file-name
                                                mirror-file-name)
                              0))))
                    (cond
                     ((not (equal er-code 3))
                      (let ((channel
                             (make-input-channel mirror-file-name
                                                 *file-clock*))
                            (mirror-stream
                             (open mirror-file-name :direction :input)))
                        (symbol-name channel)
                        (setf (get channel *open-input-channel-type-key*) typ)
                        (setf (get channel *open-input-channel-key*)
                              mirror-stream)
                        (mv channel *the-live-state*)))
                     (t (mv nil *the-live-state*)))))
                 (t (let ((channel
                           (make-input-channel file-name *file-clock*)))
                      (symbol-name channel)
                      (setf (get channel *open-input-channel-type-key*) typ)
                      (setf (get channel *open-input-channel-key*) stream)
                      (mv channel *the-live-state*))))))))))

  (let ((state-state
        (update-file-clock (1+ (file-clock state-state)) state-state)))
    (let ((pair (assoc-equal (list file-name typ (file-clock state-state))
                             (readable-files state-state))))
      (cond (pair
             (let ((channel
                    (make-input-channel file-name (file-clock state-state))))
               (mv
                channel
                (update-open-input-channels
                 (add-pair channel
                           (cons (list :header typ file-name
                                       (file-clock state-state))
                                 (cdr pair))
                           (open-input-channels state-state))
                 state-state))))
            (t (mv nil state-state))))))

)

(defthm nth-update-nth
  (equal (nth m (update-nth n val l))
         (if (equal (nfix m) (nfix n))
             val
           (nth m l)))
  :hints (("Goal" :in-theory (enable nth))))

(defthm true-listp-update-nth
  (implies (true-listp l)
           (true-listp (update-nth key val l)))
  :rule-classes :type-prescription)

(local
 (defthm nth-zp
   (implies (and (syntaxp (not (equal n ''0)))
                 (zp n))
            (equal (nth n x)
                   (nth 0 x)))
   :hints (("Goal" :expand ((nth n x) (nth 0 x))))))

(defthm nth-update-nth-array
  (equal (nth m (update-nth-array n i val l))
         (if (equal (nfix m) (nfix n))
             (update-nth i val (nth m l))
           (nth m l))))

(defun close-input-channel (channel state-state)

; Wart: We use state-state instead of state because of a bootstrap problem.

  (declare (xargs :guard
                  (and (not (member-eq
                             channel
                             '(acl2-input-channel::standard-character-input-0
                               acl2-input-channel::standard-object-input-0)))
                       (state-p1 state-state)
                       (symbolp channel)
                       (open-input-channel-any-p1 channel state-state))))
  #-acl2-loop-only
  (cond ((live-state-p state-state)
         (cond (*wormholep*
                (wormhole-er 'close-input-channel (list channel))))
         (return-from
          close-input-channel
          (progn
            (setq *file-clock* (1+ *file-clock*))
            (let ((stream (get channel *open-input-channel-key*)))
              (remprop channel *open-input-channel-key*)
              (remprop channel *open-input-channel-type-key*)
              (close stream))
            *the-live-state*))))
  (let ((state-state
         (update-file-clock (1+ (file-clock state-state)) state-state)))
    (let ((header-entries
           (cdr (car (cdr (assoc-eq channel
                                    (open-input-channels state-state)))))))
      (let ((state-state
             (update-read-files
              (cons (list (cadr header-entries) ; file-name
                          (car header-entries) ; type
                          (caddr header-entries) ; open-time
                          (file-clock state-state)) ; close-time
                    (read-files state-state))
              state-state)))
        (let ((state-state
               (update-open-input-channels
                (delete-assoc-eq channel (open-input-channels state-state))
                state-state)))
          state-state)))))

(skip-proofs
(defun open-output-channel (file-name typ state-state)

; Wart: We use state-state instead of state because of a bootstrap problem.

; Here, file-name is an ACL2 file name (i.e., with Unix-style syntax).

; It is possible to get an error when opening an output file.  We consider that
; a resource error for purposes of the story.  Note that starting after
; Version_6.1, an error is unlikely except for non-ANSI GCL because of our use
; of safe-open.

  (declare (xargs :guard (and (or (stringp file-name)
                                  (eq file-name :string))
                              (member-eq typ *file-types*)
                              (state-p1 state-state))))
  #-acl2-loop-only
  (cond ((live-state-p state-state)
         (cond ((eq file-name :string))
               (*wormholep*
                (wormhole-er 'open-output-channel (list file-name typ)))
               ((and (not (f-get-global 'writes-okp state-state))

; Sol Swords observed that calling open-output-channel! outside the ACL2 loop
; causes an error (which is due to its use of state-global-let*).  But it's
; really not necessary to protect against bad file access in raw Lisp, because
; it's impossible!  So we eliminate the check on writes-okp if the ld-level is
; 0, i.e., if we are outside the ACL2 loop.

                     (not (eql 0 (f-get-global 'ld-level state-state))))
                (mv (hard-error 'open-output-channel
                                "It is illegal to call open-output-channel in ~
                                 contexts that can appear in books, such as ~
                                 make-event expansion and clause-processor ~
                                 hint evaluation.  The attempt to open an ~
                                 output channel to file ~x0 has thus failed.  ~
                                 Consider using open-output-channel! instead, ~
                                 which is legal if there is an active trust ~
                                 tag; see :DOC defttag."
                                (list (cons #\0 file-name)))
                    state-state)))
         (return-from
          open-output-channel
          (progn
            (setq *file-clock* (1+ *file-clock*))
            (let* ((os-file-name
                    (and (not (eq file-name :string))
                         (pathname-unix-to-os file-name *the-live-state*)))
                   (stream
                    (case typ
                      ((:character :object)
                       (cond ((eq file-name :string)
                              (make-string-output-stream))
                             (t (safe-open os-file-name :direction :output
                                           :if-exists :supersede

; In ACL2(p) using CCL, we have seen an error caused when standard-co was
; connected to a file.  Specifically, waterfall-print-clause-id@par was
; printing to standard-co -- i.e., to that file -- and CCL complained because
; the default is for a file stream to be private to the thread that created it.

                                           #+(and acl2-par ccl) :sharing
                                           #+(and acl2-par ccl) :lock))))
                      (:byte
                       (cond ((eq file-name :string)
                              (make-string-output-stream
                               :element-type '(unsigned-byte 8)))
                             (t (safe-open os-file-name :direction :output
                                           :if-exists :supersede
                                           :element-type '(unsigned-byte 8)
                                           #+(and acl2-par ccl) :sharing
                                           #+(and acl2-par ccl) :lock))))
                      (otherwise
                       (interface-er "Illegal output-type ~x0." typ)))))
              (cond
               ((null stream) (mv nil *the-live-state*))
               (t (let ((channel (make-output-channel file-name *file-clock*)))
                    (symbol-name channel)
                    (setf (get channel *open-output-channel-type-key*)
                          typ)
                    (setf (get channel *open-output-channel-key*) stream)
                    (mv channel *the-live-state*)))))))))
  (let ((state-state
         (update-file-clock (1+ (file-clock state-state)) state-state)))
    (cond ((member-equal (list file-name typ (file-clock state-state))
                         (writeable-files state-state))
           (let ((channel (make-output-channel file-name
                                               (file-clock state-state))))
             (mv
              channel
              (update-open-output-channels
               (add-pair channel
                         (cons (list :header typ file-name
                                     (file-clock state-state))
                               nil)
                         (open-output-channels state-state))
               state-state))))
          (t (mv nil state-state)))))
)

(skip-proofs
(defun open-output-channel! (file-name typ state)

  ":Doc-Section io

  when trust tags are needed to open output channels~/

  Use this function in place of ~c[open-output-channel] if you want to open a
  channel for output at times this would otherwise be prohibited, for example
  during ~ilc[make-event] expansion and ~ilc[clause-processor] ~il[hints].  If
  this functionality doesn't quite seem like what you need, take a look at the
  definition of ~c[open-output-channel!] in axioms.lisp, specifically the
  binding of ~ilc[state] global variable ~c[writes-okp].  The following
  example, taken from community book ~c[books/hons-archive/hons-archive.lisp],
  illustrates the latter approach.
  ~bv[]
  (defmacro har-zip! (x filename &key sortp)
    \"See :doc hons-archive\"
    `(mv-let (erp val state)
             (progn!
              :state-global-bindings
              ((temp-touchable-vars t set-temp-touchable-vars))
              (state-global-let*
               ((writes-okp t))
               (let ((state (har-zip-fn ,x ,filename ,sortp state)))
                 (mv nil nil state))))
             (declare (ignore erp val))
             state))
  ~ev[]

  The book below illustrates the soundness loophole plugged in ACL2 Version_3.2
  related to file writes during book certification.~/
  ~bv[]
  ; The following example is adapted (with only very slight changes)
  ; from one written by Peter Dillinger.  It illustrates the prohibition
  ; against writing files enforced by with-output-channel during book
  ; certification (more specifically, during make-event expansion).

  ; This book certifies in ACL2 Version_3.1 before the fix discussed in the
  ; paragraph about it being ``possible to write files during book
  ; certification'' in :DOC NOTE-3-2.  The fix was actually made to ACL2
  ; function open-output-channel.

  ; After the fix, in order for certification to succeed one needs to do
  ; two things.  First, in raw lisp:
  ;   (push :after-writes-okp-fix *features*)
  ; Second, certify with this command:
  ;   (certify-book \"writes-okp\" 0 nil :ttags (:writes-okp))

  (in-package \"ACL2\")

  (local
   (defun write-objects-to-channel (obj-lst chan state)
     (declare (xargs :mode :program
                     :stobjs state
                     :guard (true-listp obj-lst)))
     (if (consp obj-lst)
         (pprogn (print-object$ (car obj-lst) chan state)
                 (write-objects-to-channel (cdr obj-lst) chan state)
                 state)
       state)))

  #+after-writes-okp-fix
  (defttag :writes-okp)

  (local
   (defun write-objects-to-file (obj-lst filename state)
     (declare (xargs :mode :program
                     :stobjs state
                     :guard (and (stringp filename)
                                 (true-listp obj-lst))))
     (mv-let (chan state)
             #-after-writes-okp-fix
             (open-output-channel filename :object state)
             #+after-writes-okp-fix
             (open-output-channel! filename :object state)
             (if chan
                 (pprogn (write-objects-to-channel obj-lst chan state)
                         (close-output-channel chan state)
                         (value :done))
               (er soft 'write-object-to-file
                   \"Could not open for writing: ~~x0\"
                   filename)))))

  (local
   (defconst *nil.lisp*
     '((in-package \"ACL2\")
       (defthm bad nil :rule-classes nil))))

  (local
   (defconst *nil.cert*
     '((IN-PACKAGE \"ACL2\")
       \"ACL2 Version 3.1\"
       :BEGIN-PORTCULLIS-CMDS
       :END-PORTCULLIS-CMDS
       NIL
       ((\"/home/peterd/test/nil.lisp\" \"nil\" \"nil\"
         ((:SKIPPED-PROOFSP) (:AXIOMSP) (:TTAGS)) . 134094174))
       62589544
       )))

  (local
   (make-event (er-progn
                (write-objects-to-file *nil.lisp* \"nil.lisp\" state)
                (write-objects-to-file *nil.cert* \"nil.cert\" state)
                (value '(value-triple :invisible)))))

  (local (include-book
          \"nil\" :load-compiled-file nil))

  (defthm bad nil :rule-classes nil)
  ~ev[]"

  (declare (xargs :guard (and (stringp file-name)
                              (member-eq typ *file-types*)
                              (state-p state))))
  (cond
   ((eql 0 (f-get-global 'ld-level state))

; See the comment about this case in open-output-channel.

    (open-output-channel file-name typ state))
   (t (mv-let (erp chan state)
              (state-global-let*
               ((writes-okp t))
               (mv-let (chan state)
                       (open-output-channel file-name typ state)
                       (value chan)))
              (declare (ignore erp))
              (mv chan state)))))
)

(defmacro assert$ (test form)

  ":Doc-Section ACL2::ACL2-built-ins

  cause a hard error if the given test is false~/

  ~bv[]
  General Form:
  (assert$ test form)
  ~ev[]
  where ~c[test] returns a single value and ~c[form] is arbitrary.
  Semantically, this call of ~c[assert$] is equivalent to ~c[form].  However,
  it causes a hard error if the value of ~c[test] is ~c[nil].  That hard error
  invokes the function ~ilc[illegal], which has a ~il[guard] that is equal to
  ~c[nil]; so if you use ~c[assert$] in code for which you verify guards, then
  a proof obligation will be that the occurrence of ~c[test] is never
  ~c[nil].~/~/"

  `(prog2$ (or ,test
               (er hard 'assert$
                   "Assertion failed:~%~x0"
                   '(assert$ ,test ,form)))
           ,form))

(defun fmt-to-comment-window (str alist col evisc-tuple)

; WARNING: Keep this in sync with fmt-to-comment-window!.

; Logically, this is the constant function returning nil.  However, it
; has a side-effect on the "comment window" which is imagined to be a
; separate window on the user's screen that cannot possibly be
; confused with the normal ACL2 display of the files in STATE.  Using
; this function it is possible for an ACL2 expression to cause
; characters to appear in the comment window.  Nothing whatsoever can
; be proved about these characters.  If you want to prove something
; about ACL2 output, it must be directed to the channels and files in
; STATE.

  ":Doc-Section ACL2::ACL2-built-ins

  print to the comment window~/

  ~l[cw] for an introduction to the comment window and the usual way
  to print it.

  Function ~c[fmt-to-comment-window] is identical to ~c[fmt1] (~pl[fmt]),
  except that the channel is ~ilc[*standard-co*] and the ACL2
  ~ilc[state] is neither an input nor an output.  An analogous function,
  ~c[fmt-to-comment-window!], prints with ~ilc[fmt!] instead of ~ilc[fmt],
  in order to avoid insertion of backslash (\\) characters for margins;
  also ~pl[cw!].  Note that even if you change the value of ~ilc[ld] special
  ~c[standard-co] (~pl[standard-co]), ~c[fmt-to-comment-window] will print to
  ~ilc[*standard-co*], which is the original value of ~ilc[standard-co].~/
  ~bv[]
  General Form:
  (fmt-to-comment-window fmt-string alist col evisc-tuple)
  ~ev[]
  where these arguments are as desribed for ~ilc[fmt1]; ~pl[fmt].~/"

  (declare (xargs :guard t))

  #+acl2-loop-only
  (declare (ignore str alist col evisc-tuple))
  #+acl2-loop-only
  nil

; Note:  One might wish to bind *wormholep* to nil around this fmt1 expression,
; to avoid provoking an error if this fn is called while *wormholep* is t.
; However, the fact that we're printing to *standard-co* accomplishes the
; same thing.  See the comment on synonym streams in princ$.

  #-acl2-loop-only
  (progn (fmt1 str alist col *standard-co* *the-live-state* evisc-tuple)
         nil))

(defun fmt-to-comment-window! (str alist col evisc-tuple)

; WARNING: Keep this in sync with fmt-to-comment-window.

  (declare (xargs :guard t))
  #+acl2-loop-only
  (declare (ignore str alist col evisc-tuple))
  #+acl2-loop-only
  nil
  #-acl2-loop-only
  (progn (fmt1! str alist col *standard-co* *the-live-state*
                evisc-tuple)
         nil))

(defun pairlis2 (x y)
; Like pairlis$ except is controlled by y rather than x.
  (declare (xargs :guard (and (true-listp x)
                              (true-listp y))))
  (cond ((endp y) nil)
        (t (cons (cons (car x) (car y))
                 (pairlis2 (cdr x) (cdr y))))))

(defmacro cw (str &rest args)

; WARNING: Keep this in sync with cw!.

; A typical call of this macro is:
; (cw "The goal is ~p0 and the alist is ~x1.~%"
;     (untranslate term t nil)
;     unify-subst)
; Logically, this expression is equivalent to nil.  However, it has
; the effect of first printing to the comment window the fmt string
; as indicated.  It uses fmt-to-comment-window above, and passes it the
; column 0 and evisc-tuple nil, after assembling the appropriate
; alist binding the fmt vars #\0 through #\9.  If you want
; (a) more than 10 vars,
; (b) vars other than the digit chars,
; (c) a different column, or
; (d) a different evisc-tuple,
; then call fmt-to-comment-window instead.

; Typically, calls of cw are embedded in prog2$ forms,
; e.g.,
; (prog2$ (cw ...)
;         (mv a b c))
; which has the side-effect of printing to the comment window and
; logically returning (mv a b c).

  ":Doc-Section ACL2::ACL2-built-ins

  print to the comment window~/

  Example:
  ~bv[]
  (cw \"The goal is ~~p0 and the alist is ~~x1.~~%\"
      (untranslate term t nil)
      unify-subst)
  ~ev[]
  Logically, this expression is equivalent to ~c[nil].  However, it has
  the effect of first printing to the so-called ``comment window'' the
  ~ilc[fmt] string as indicated.  Thus, ~c[cw] is like ~c[fmt] (~pl[fmt]) except
  in three important ways.  First, it is a macro whose calls expand to calls of
  a ~c[:]~ilc[logic] mode function.  Second, it neither takes nor returns the
  ACL2 ~ilc[state]; logically ~c[cw] simply returns ~c[nil], although it prints
  to a ~em[comment window] that just happens to share the terminal screen with
  the standard character output ~ilc[*standard-co*].  Third, its ~c[fmt] args
  are positional references, so that for example
  ~bv[]
  (cw \"Answers: ~~p0 and ~~p1\" ans1 ans2)
  ~ev[]
  prints in the same manner as:
  ~bv[]
  (fmt \"Answers: ~~p0 and ~~p1\"
       (list (cons #\\0 ans1) (cons #\\1 ans2))
       *standard-co* state nil)
  ~ev[]
  Typically, calls of ~c[cw] are embedded in ~ilc[prog2$] forms, e.g.,
  ~bv[]
  (prog2$ (cw ...)
          (mv a b c))
  ~ev[]
  which has the side-effect of printing to the comment window and
  logically returning ~c[(mv a b c)].~/
  ~bv[]
  General Form:
  (cw fmt-string arg1 arg2 ... argn)
  ~ev[]
  where n is between 0 and 9 (inclusive).
  The macro uses ~ilc[fmt-to-comment-window], passing it the column ~c[0] and
  ~il[evisc-tuple] ~c[nil], after assembling the appropriate alist binding the
  ~ilc[fmt] vars #\\0 through #\\9; ~pl[fmt].  If you want
  ~bf[]
  (a) more than 10 vars,
  (b) vars other than the digit chars,
  (c) a different column, or
  (d) a different evisc-tuple,
  ~ef[]
  then call ~ilc[fmt-to-comment-window] instead.

  Also ~pl[cw!], which is useful if you want to be able to read the printed
  forms back in.

  Finally, we discuss another way to create formatted output that also avoids
  the need to pass in the ACL2 ~ilc[state].  The idea is to use wormholes;
  ~pl[wormhole].  Below is a function you can write, along with some calls,
  providing an illustration of this approach.
  ~bv[]
  (defun my-fmt-to-comment-window (str alist)
    (wormhole 'my-fmt-to-comment-window
              '(lambda (whs) whs)
              (list str alist)
              '(pprogn
                (fms (car (@ wormhole-input))
                     (cadr (@ wormhole-input))
                     *standard-co*
                     state
                     nil)
                (value :q))
              :ld-verbose nil
              :ld-error-action :return ; harmless return on error
              :ld-prompt nil))

  ; A non-erroneous call:
  (my-fmt-to-comment-window \"Here is ~~x0 for your inspection~~%\"
                            (list (cons #\\0 'foo)))

  ; An error inside the fmt string (unbound fmt var); note that even
  ; with the error, the wormhole is exited.
  (my-fmt-to-comment-window \"Here is ~~x1 for your inspection~~%\"
                            (list (cons #\\0 'foo)))

  ; A guard violation in the binding; note that even with the error,
  ; the wormhole is exited.
  (my-fmt-to-comment-window \"Here is ~~x0 for your inspection~~%\"
                            (list (cons #\\0 (car 'foo))))
  ~ev[]~/"

  `(fmt-to-comment-window ,str
                          (pairlis2 '(#\0 #\1 #\2 #\3 #\4
                                      #\5 #\6 #\7 #\8 #\9)
                                    (list ,@args))
                          0 nil))

(defmacro cw! (str &rest args)

; WARNING: Keep this in sync with cw.

  ":Doc-Section ACL2::ACL2-built-ins

  print to the comment window~/

  This is the same as ~ilc[cw], except that ~ilc[cw] inserts backslash (\\)
  characters when forced to print past the right margin, in order to make the
  output a bit clearer in that case.  Use ~c[cw!] instead if you want to be
  able to read the forms back in.~/~/"

  `(fmt-to-comment-window! ,str
                           (pairlis2 '(#\0 #\1 #\2 #\3 #\4
                                       #\5 #\6 #\7 #\8 #\9)
                                     (list ,@args))
                           0 nil))

(defun subseq-list (lst start end)
  (declare (xargs :guard (and (true-listp lst)
                              (integerp start)
                              (integerp end)
                              (<= 0 start)
                              (<= start end))
                  :mode :program))
  (take (- end start)
        (nthcdr start lst)))

#+acl2-loop-only
(defun subseq (seq start end)

  ":Doc-Section ACL2::ACL2-built-ins

  subsequence of a string or list~/

  For any natural numbers ~c[start] and ~c[end], where ~c[start] ~c[<=]
  ~c[end] ~c[<=] ~c[(length seq)], ~c[(subseq seq start end)] is the
  subsequence of ~c[seq] from index ~c[start] up to, but not including,
  index ~c[end].  ~c[End] may be ~c[nil], which which case it is treated
  as though it is ~c[(length seq)], i.e., we obtain the subsequence of
  ~c[seq] from index ~c[start] all the way to the end.~/

  The ~il[guard] for ~c[(subseq seq start end)] is that ~c[seq] is a
  true list or a string, ~c[start] and ~c[end] are integers (except,
  ~c[end] may be ~c[nil], in which case it is treated as ~c[(length seq)]
  for the rest of this discussion), and ~c[0] ~c[<=] ~c[start] ~c[<=]
  ~c[end] ~c[<=] ~c[(length seq)].

  ~c[Subseq] is a Common Lisp function.  See any Common Lisp
  documentation for more information.  Note:  In Common Lisp the third
  argument of ~c[subseq] is optional, but in ACL2 it is required,
  though it may be ~c[nil] as explained above.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (or (true-listp seq)
                                  (stringp seq))
                              (integerp start)
                              (<= 0 start)
                              (or (null end)
                                  (and (integerp end)
                                       (<= end (length seq))))
                              (<= start (or end (length seq))))
                  :mode :program))
  (if (stringp seq)
      (coerce (subseq-list (coerce seq 'list) start (or end (length seq)))
              'string)
    (subseq-list seq start (or end (length seq)))))

(defun lock-symbol-name-p (lock-symbol)
  (declare (xargs :guard t))
  (and (symbolp lock-symbol)
       (let* ((name (symbol-name lock-symbol))
              (len (length name)))
         (and (> len 2)
              (eql (char name 0) #\*)
              (eql (char name (1- len)) #\*)))))

(defun assign-lock (key)
  (declare (xargs :guard (lock-symbol-name-p key)))
  #-(and (not acl2-loop-only) acl2-par)
  (declare (ignore key))
  #+(and (not acl2-loop-only) acl2-par)
  (cond ((boundp key)
         (when (not (lockp (symbol-value key)))
           (error "Raw Lisp variable ~s is already bound to a value ~
                   that~%does not satisfy lockp."
                  key)))
        (t (proclaim (list 'special key))
           (setf (symbol-value key)
                 (make-lock (symbol-name key)))))
  t)

(table lock-table nil nil
       :guard
       (and (lock-symbol-name-p key)
            (assign-lock key)))

#+(or acl2-loop-only (not acl2-par))
(defmacro with-lock (bound-symbol &rest forms)
  (declare (xargs :guard (lock-symbol-name-p bound-symbol)))
  `(translate-and-test
    (lambda (x)
      (prog2$
       x ; x is not otherwise used
       (or (consp (assoc-eq ',bound-symbol (table-alist 'lock-table world)))
           (msg "The variable ~x0 has not been defined as a lock."
                ',bound-symbol))))
    (progn$ ,@forms)))

(defmacro deflock (lock-symbol)

; Deflock puts lock-symbol into the lock-table, and also defines a macro
; WITH-lock-symbol that is really just progn$.  However, if #+acl2-par holds,
; then deflock also defines a

; Deflock defines what some Lisps call a "recursive lock", namely a lock that
; can be grabbed more than once by the same thread, but such that if a thread
; outside the owner tries to grab it, that thread will block.  In addition to
; defining a lock, this macro also defines a macro that uses the lock to
; provide mutual-exclusion for a given list of operations.  This macro has the
; name with-<modified-lock-name>, where <modified-lock-name> is the given
; lock-symbol without the leading and trailing * characters.

; Note that if lock-symbol is already bound, then deflock will not re-bind
; lock-symbol.

  (declare (xargs :guard (lock-symbol-name-p lock-symbol)))
  (let* ((name (symbol-name lock-symbol))
         (macro-symbol (intern
                        (concatenate 'string
                                     "WITH-"
                                     (subseq name 1 (1- (length name))))
                        "ACL2")))
    `(progn
       (table lock-table ',lock-symbol t)

; The table event above calls make-lock when #+acl2-par, via assign-lock from
; the table guard of lock.  However, table events are no-ops in raw Lisp, so we
; include the following form as well.

       #+(and acl2-par (not acl2-loop-only))
       (defvar ,lock-symbol
         (make-lock (symbol-name ',lock-symbol)))
       (defmacro ,macro-symbol (&rest args)
         (list* 'with-lock ',lock-symbol args)))))

(deflock

; Keep in sync with :DOC topic with-output-lock.

  *output-lock*)

(skip-proofs ; as with open-output-channel
(defun get-output-stream-string$-fn (channel state-state)
  (declare (xargs :guard (and (state-p1 state-state)
                              (symbolp channel)
                              (open-output-channel-any-p1 channel
                                                          state-state))))
  #-acl2-loop-only
  (when (live-state-p state-state)
    (let ((stream (get-output-stream-from-channel channel)))
      (when *wormholep*
        (wormhole-er 'get-output-stream-string$-fn
                     (list channel)))
      (return-from get-output-stream-string$-fn
                   (cond #-(and gcl (not cltl2))
                         ((not (typep stream 'string-stream))
                          (mv t nil state-state))
                         #+(and gcl (not cltl2))
                         ((or (not (typep stream 'stream))
                              (si::stream-name stream)) ; stream to a file

; As of this writing, we do not have confirmation from the gcl-devel list that
; si::stream-name really does return nil if and only if the stream is to a
; string rather than to a file.  But we believe that to be the case.

                          (mv t nil state-state))
                         (t (mv nil
                                (get-output-stream-string stream)
                                state-state))))))
  #+acl2-loop-only
  (let* ((entry (cdr (assoc-eq channel (open-output-channels state-state))))
         (header (assert$ (consp entry)
                          (car entry)))
         (file-name (assert$ (and (true-listp header)
                                  (eql (length header) 4))
                             (nth 2 header))))
    (cond
     ((eq file-name :string)
      (mv nil
          (coerce (reverse (cdr entry)) 'string)
          (update-open-output-channels
           (add-pair channel
                     (cons header nil)
                     (open-output-channels state-state))
           state-state)))
     (t (mv t nil state-state)))))
)

(defmacro get-output-stream-string$ (channel state-state
                                             &optional
                                             (close-p 't)
                                             (ctx ''get-output-stream-string$))
  (declare (xargs :guard ; but *the-live-state* is OK in raw Lisp
                  (eq state-state 'state))
           (ignorable state-state))
  `(let ((chan ,channel)
         (ctx ,ctx))
     (mv-let (erp s state)
             (get-output-stream-string$-fn chan state)
             (cond (erp (er soft ctx
                            "Symbol ~x0 is not associated with a string ~
                             output channel."
                            chan))
                   (t ,(cond (close-p
                              '(pprogn (close-output-channel chan state)
                                       (value s)))
                             (t '(value s))))))))

(defun close-output-channel (channel state-state)

; Wart: We use state-state instead of state because of a bootstrap problem.

  (declare (xargs :guard
                  (and (not
                        (eq channel
                            'acl2-output-channel::standard-character-output-0))
                       (state-p1 state-state)
                       (symbolp channel)
                       (open-output-channel-any-p1 channel state-state))))
  #-acl2-loop-only
  (cond ((live-state-p state-state)
         (when (eq channel (f-get-global 'standard-co state-state))

; First, we cause a hard error if the channel is the value of state global
; 'standard-co.  Comments below say more about this, but for now we point out
; that even though we cause an error, we won't get the error from term
; evaluation during proofs, because state-state will not be the live state.

           (mv (cond
                ((eq channel *standard-co*)

; This case might seem impossible because it would be a guard violation.  But
; if a :program mode function call leads to the present call of
; close-output-channel, then the guard need not hold, so we make sure to cause
; an error here.

                 (mv (er hard! 'close-output-channel
                         "It is illegal to call close-output-channel on ~
                          *standard-co*.")))
                (t

; In Version_6.1 and probably before, we have seen an infinite loop occur
; when attempting to close standard-co.

                 (state-free-global-let*
                  ((standard-co *standard-co*))
                  (er hard! 'close-output-channel
                      "It is illegal to call close-output-channel on ~
                       standard-co.  Consider instead evaluating the ~
                       following form:~|~%~X01."
                      '(let ((ch (standard-co state)))
                         (er-progn
                          (set-standard-co *standard-co* state)
                          (pprogn
                           (close-output-channel ch state)
                           (value t))))
                      nil))))
               state-state))
         (cond (*wormholep*
                (wormhole-er 'close-output-channel (list channel))))

         #+allegro

; April 2009: It seems that the last half of this month or so, occasionally
; there have been regression failures during inclusion of books that were
; apparently already certified.  Those may all have been with Allegro CL.  In
; particular, on 4/29/09 there were two successive regression failes as
; community book books/rtl/rel8/support/lib2.delta1/reps.lisp tried to include
; "bits" in that same directory.  We saw a web page claiming an issue in old
; versions of Allegro CL for which finish-output didn't do the job, and
; force-output perhaps did.  So we add a call here of force-output for Allegro.

         (force-output (get-output-stream-from-channel channel))
         (finish-output (get-output-stream-from-channel channel))

; At one time we called sync here, as shown below, for CCL.  But Daron Vroon
; reported problems with (ccl:external-call "sync") on a PowerPC platform where
; "_sync" was expected instead.  It seems best not to try to include code that
; is this low-level unless it is really necessary, because of the unknown
; diversity of future platforms that might require further maintenance; so
; we are commenting this out.

;        #+ccl ; Bob Boyer suggestion
;        (when (ccl-at-least-1-3-p)
;          (ccl:external-call "sync"))
         (return-from
          close-output-channel
          (progn
            (setq *file-clock* (1+ *file-clock*))
            (let ((str (get channel *open-output-channel-key*)))
              (remprop channel *open-output-channel-key*)
              (remprop channel *open-output-channel-type-key*)
              (close  str))
            *the-live-state*))))
  (let ((state-state
         (update-file-clock (1+ (file-clock state-state)) state-state)))
    (let* ((pair (assoc-eq channel (open-output-channels state-state)))
           (header-entries (cdr (car (cdr pair)))))
      (let ((state-state
             (update-written-files
              (cons (cons
                     (list (cadr header-entries) ; file-name
                           (car header-entries) ; type
                           (caddr header-entries) ; open-time
                           (file-clock state-state)) ; close-time
                     (cdr (cdr pair))) ; stuff written
                    (written-files state-state))
              state-state)))
        (let ((state-state
               (update-open-output-channels
                (delete-assoc-eq channel (open-output-channels state-state))
                state-state)))
          state-state)))))

(defun maybe-finish-output$ (channel state)

; Allegro 6.0 needs explicit calls of finish-output in order to flush to
; standard output when *print-pretty* is nil.  SBCL 1.0 and 1.0.2 have
; exhibited this requirement during a redef query, for example:

; (defun foooooooooooooooooooooooooooo (x) x)
; :redef
; (defun foooooooooooooooooooooooooooo (x) (+ 1 x))

  (declare (xargs :guard (and (symbolp channel)
                              (state-p state)
                              (open-output-channel-any-p channel state)))
           (ignorable channel state))
  #+(and (not acl2-loop-only)
         (or sbcl allegro))
  (finish-output (get-output-stream-from-channel channel))
  nil)

#-acl2-loop-only
(defmacro legal-acl2-character-p (x)

; This predicate guarantees that two ACL2 characters with the same char-code
; are identical (eql).  In fact, a legal character is an 8-bit character that
; is ``canonical,'' in the sense that it's the character returned by code-char
; on its character code.

  (let ((ch (gensym)))
    `(let* ((,ch ,x)
            (code (char-code ,ch)))
       (and (integerp code)
            (<= 0 code)
            (< code 256)
            (eql (the character ,ch)
                 (the character (code-char code)))))))

(defun read-char$ (channel state-state)

; read-char$ differs from read-char in several ways.  It returns an
; mv-list of two values, the second being state.  There are no eof
; args.  Rather, nil is returned instead of character if there is no
; more input.

; Wart: We use state-state instead of state because of a bootstrap problem.

  (declare (xargs :guard (and (state-p1 state-state)
                              (symbolp channel)
                              (open-input-channel-p1
                               channel :character state-state))))
  #-acl2-loop-only
  (cond ((live-state-p state-state)
         (cond ((and *wormholep*
                     (not (eq channel *standard-ci*)))
                (wormhole-er 'read-char$ (list channel))))
         (return-from
          read-char$
          (let ((ch (read-char
                     (get-input-stream-from-channel channel) nil nil)))
            (cond ((and ch (not (legal-acl2-character-p ch)))
                   (interface-er "Illegal character read: ~x0 with code ~x1."
                                ch (char-code ch)))
                  (t (mv ch
                         *the-live-state*)))))))
  (let ((entry (cdr (assoc-eq channel (open-input-channels state-state)))))
    (mv (car (cdr entry))
        (update-open-input-channels
         (add-pair channel
                   (cons (car entry) (cdr (cdr entry)))
                   (open-input-channels state-state))
         state-state))))

(defun peek-char$ (channel state-state)

; Wart: We use state-state instead of state because of a bootstrap problem.

  (declare (xargs :guard (and (state-p1 state-state)
                              (symbolp channel)
                              (open-input-channel-p1
                               channel :character state-state))))

  #-acl2-loop-only
  (cond ((live-state-p state-state)
         (cond ((and *wormholep*
                     (not (eq channel *standard-ci*)))
                (wormhole-er 'peek-char$ (list channel))))
         (return-from
          peek-char$
          (let ((ch (peek-char nil (get-input-stream-from-channel channel)
                               nil nil)))
            (cond ((and ch (not (legal-acl2-character-p ch)))
                   (interface-er
                    "Illegal character peeked at: ~x0 with code ~x1."
                                 ch (char-code ch)))
                  (t ch))))))
  (let ((entry (cdr (assoc-eq channel (open-input-channels state-state)))))
    (car (cdr entry))))

(defun read-byte$ (channel state-state)

; read-byte$ differs from read-byte in several ways.  It returns an
; mv-list of two values, the second being state.  There are no eof
; args.  Rather, nil is returned instead if there is no more input.

; Wart: We use state-state instead of state because of a bootstrap problem.

  (declare (xargs :guard (and (state-p1 state-state)
                              (symbolp channel)
                              (open-input-channel-p1
                               channel :byte state-state))))
  #-acl2-loop-only
  (cond ((live-state-p state-state)
         (cond (*wormholep*
                (wormhole-er 'read-byte$ (list channel))))
         (return-from
          read-byte$
          (mv (read-byte (get-input-stream-from-channel channel) nil nil)
              *the-live-state*))))
  (let ((entry (cdr (assoc-eq channel (open-input-channels state-state)))))
    (mv (car (cdr entry))
        (update-open-input-channels
         (add-pair channel
                   (cons (car entry) (cdr (cdr entry)))
                   (open-input-channels state-state))
         state-state))))

#-acl2-loop-only
(defun-one-output parse-infix-from-terminal (eof)

; Eof is an arbitrary lisp object.  If the terminal input is empty, return eof.
; Otherwise, parse one well-formed expression from terminal input and return the
; corresponding s-expr.  If the file is exhausted before the parse finishes or
; if the parse is unsuccessful, cause a hard lisp error.

; In the current hackish implementation, the infix language is just a dollar
; sign followed by the s-expr.

  (let (dollar sexpr)
    (setq dollar (read *terminal-io* nil eof))
    (cond ((eq dollar eof) eof)
          ((eq dollar '$)
; The following read could cause an error if the user types bad lisp syntax.
           (setq sexpr (read *terminal-io* nil eof))
           (cond ((eq sexpr eof)
                  (error "Ill-formed infix input.  File ended on a $"))
                 (t sexpr)))
          (t (error
              "Ill-formed infix input.  You were supposed to type a $ ~
               followed by an s-expression and you typed ~s instead."
              dollar)))))

#-acl2-loop-only
(defparameter *acl2-read-suppress* nil)

(defun read-object (channel state-state)

; Read-object is somewhat like read.  It returns an mv-list of three
; values: the first is a flag that is true iff the read happened at
; eof, the second is the object read (or nil if eof), and the third is
; state.

; Note that read-object establishes a new context for #n= reader macros, as it
; calls read (or hons-read) with a recursive-p argument of nil.

; Wart: We use state-state instead of state because of a bootstrap problem.

  (declare (xargs :guard (and (state-p1 state-state)
                              (symbolp channel)
                              (open-input-channel-p1
                               channel :object state-state))))

  #-acl2-loop-only
  (cond ((live-state-p state-state)
         (cond ((and *wormholep*
                     (not (eq channel *standard-oi*)))
                (wormhole-er 'read-object (list channel))))
         (return-from
          read-object
          (let* ((read-object-eof

; Suggestion from Bob Boyer: By using dynamic-extent [see declaration below],
; we make the cons more 'secret' or 'new'.  (Added August 2009: the
; dynamic-extent declaration below is commented out, with explanation.  We are
; comfortable continuing to use a let-bound local here, since the extra cons
; seems trivial.)

                  (cons nil nil))
                 (*package* (find-package
                             (current-package *the-live-state*)))
                 (*readtable* *acl2-readtable*)
                 #+cltl2 (*read-eval* t)
                 (*read-suppress* *acl2-read-suppress*)
                 (*read-base* 10)
                 #+gcl (si:*notify-gbc* ; no gbc messages while typing
                        (if (or (eq channel *standard-oi*)
                                (eq channel *standard-ci*))
                            nil
                          si:*notify-gbc*))
                 (infixp (f-get-global 'infixp state-state))
                 (stream (get-input-stream-from-channel channel))
                 (obj
                  (cond
                   ((and (or (eq infixp t) (eq infixp :in))
                         (eq stream (get-input-stream-from-channel  *standard-ci*)))
                    (let ((obj (parse-infix-from-terminal read-object-eof)))
                      (cond ((eq obj read-object-eof)
                             read-object-eof)
                            (t (chk-bad-lisp-object obj)
                               obj))))
                   #+(and mcl (not ccl))
                   ((eq channel *standard-oi*)
                    (ccl::toplevel-read))

; (Comment for #+hons.)  In the case of #+hons, we formerly called a function
; hons-read here when (f-get-global 'hons-read-p *the-live-state*) was true.
; That had the unfortunate behavior of hons-copying every object, which can be
; too expensive for large, unhonsed structures.  This problem has been fixed
; with the addition of source files serialize[-raw].lisp, contributed by Jared
; Davis.

                   (t
                    (read stream nil read-object-eof nil)))))

; The following dynamic-extent declaration looks fine.  But there have been
; spurious ill-formed certificate and checksum problems with Allegro CL for a
; few months (as of Aug. 2009) and I am suspicious that this could be the cause
; (in which case we have hit an Allegro CL compiler bug, if I'm correct about
; this declaration being fine).  The efficiency improvement given by this
; declaration seems rather trivial, so I'll comment it out and see what
; happens.

;           #+cltl2
;           (declare (dynamic-extent read-object-eof))

            (cond ((eq obj read-object-eof)
                   (mv t nil state-state))
                  (t (or (raw-mode-p state-state)
                         (chk-bad-lisp-object obj))
                     (mv nil obj state-state)))))))
  (let ((entry (cdr (assoc-eq channel (open-input-channels state-state)))))
    (cond ((cdr entry)
           (mv nil
               (car (cdr entry))
               (update-open-input-channels
                (add-pair channel
                          (cons (car entry) (cdr (cdr entry)))
                          (open-input-channels state-state))
                state-state)))
          (t (mv t nil state-state)))))

(defun read-object-suppress (channel state)

; Logically this function is the same as read-object except that it throws away
; the second returned value, i.e. the "real" value, simply returning (mv eof
; state).  However, under the hood it uses Lisp special *read-suppress* to
; avoid errors in reading the next value, for example errors caused by
; encountering symbols in packages unknown to ACL2.

  (declare (xargs :guard (and (state-p state)
                              (symbolp channel)
                              (open-input-channel-p channel :object state))))
  (let (#-acl2-loop-only (*acl2-read-suppress* t))
    (mv-let (eof val state)
            (read-object channel state)
            (declare (ignore val))
            (mv eof state))))

(defconst *suspiciously-first-numeric-chars*

; This constant is inlined in the definition of
; *suspiciously-first-numeric-array*.

  '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\+ #\- #\. #\^ #\_))

(defconst *suspiciously-first-hex-chars*

; This constant is inlined in the definition of
; *suspiciously-first-hex-array*.

  '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
    #\A #\B #\C #\D #\E #\F
    #\a #\b #\c #\d #\e #\f
    #\+ #\- #\. #\^ #\_))

(defconst *base-10-chars*

; This constant is inlined in the definition of
; *base-10-array*.

  '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))

(defconst *hex-chars*

; This constant is inlined in the definition of
; *hex-array*.

  '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
    #\A #\B #\C #\D #\E #\F
    #\a #\b #\c #\d #\e #\f))

(defconst *letter-chars*

; This constant is inlined in the definition of
; *letter-array*.

  '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P
    #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z
    #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p
    #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z))

(defconst *slashable-chars*

; This constant is inlined in the definition of *slashable-array*.

  '(#\Newline #\Page #\Space #\" #\# #\' #\( #\) #\, #\: #\; #\\ #\`
    #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p
    #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\|))

(defun some-slashable (l)
  (declare (xargs :guard (character-listp l)))
  (cond ((endp l) nil)
        ((member (car l) *slashable-chars*)
         t)
        (t (some-slashable (cdr l)))))

(skip-proofs
(defun prin1-with-slashes1 (l slash-char channel state)
  (declare (xargs :guard
                  (and (character-listp l)
                       (characterp slash-char)
                       (state-p state)
                       (symbolp channel)
                       (open-output-channel-p channel
                                              :character
                                              state))))
  (cond ((endp l) state)
        (t (pprogn
            (cond ((or (equal (car l) #\\) (equal (car l) slash-char))
                   (princ$ #\\ channel state))
                  (t state))
            (princ$ (car l) channel state)
            (prin1-with-slashes1 (cdr l) slash-char channel state)))))
)

(skip-proofs
(defun prin1-with-slashes (s slash-char channel state)
  (declare (xargs :guard (and (stringp s)
                              (characterp slash-char)
                              (state-p state)
                              (symbolp channel)
                              (open-output-channel-p channel :character state))))
  #-acl2-loop-only
  (cond ((live-state-p state)

; We don't check *wormholep* here because it is checked in
; princ$ which is called first on each branch below.

         (let ((n (length (the string s))))
           (declare (type fixnum n))
           (do ((i 0 (1+ i))) ((= i n))
               (declare (type fixnum i))
               (let ((ch (aref (the string s) i)))
                 (cond ((or (eql ch #\\)
                            (eql ch slash-char))
                        (progn (princ$ #\\ channel state)
                               (princ$ ch channel state)))
                       (t (princ$ ch channel state))))))
         (return-from prin1-with-slashes state)))
  (prin1-with-slashes1 (coerce s 'list) slash-char channel state))
)

(defmacro suspiciously-first-numeric-chars (print-base)
  `(if (eql ,print-base 16)
       *suspiciously-first-hex-chars*
     *suspiciously-first-numeric-chars*))

(defmacro numeric-chars (print-base)
  `(if (eql ,print-base 16)
       *hex-chars*
     *base-10-chars*))

(defun may-need-slashes1 (lst flg potnum-chars)

; See may-need-slashes.  Here we check that lst (a symbol-name) consists
; entirely of digits, signs (+ or -), ratio markers (/), decimal points (.),
; extension characters (^ or _), except that it can also have letters provided
; there are no two consecutive letters.  We could check only for upper-case
; letters, since lower-case letters are already handled (see some-slashable and
; *slashable-array* in may-need-slashes).  But we might as well check for all
; letters, just to play it safe.

; Flg is t if the immediately preceding character was a letter, else nil.

  (declare (xargs :guard (and (character-listp lst)
                              (true-listp potnum-chars))))
  (cond ((endp lst)
         t)
        ((member (car lst) potnum-chars)
         (may-need-slashes1 (cdr lst) nil potnum-chars))
        ((member (car lst) *letter-chars*)
         (cond (flg nil)
               (t (may-need-slashes1 (cdr lst) t potnum-chars))))
        (t nil)))

#-acl2-loop-only
(defmacro potential-numberp (s0 n0 print-base)

; We assume that s is a non-empty string of length n.  We return t if s
; represents a potential number for the given ACL2 print-base.  (See
; may-need-slashes-fn for a discussion of potential numbers.)

; Warning: Keep this in sync with the corresponding #+acl2-loop-only code in
; may-need-slashes-fn.

  (let ((ar+ (gensym))
        (ar (gensym))
        (s (gensym))
        (n (gensym)))
    `(let ((,ar+ (suspiciously-first-numeric-array ,print-base))
           (,ar (numeric-array ,print-base))
           (,s ,s0)
           (,n ,n0))
       (declare (type fixnum ,n))
       (and

; Either the first character is a digit or: the first character is a sign,
; decimal point, or extension character, and some other character is a digit.

        (let ((ch (the fixnum (char-code (aref (the string ,s) 0)))))
          (declare (type fixnum ch))
          (or (svref ,ar ch)
              (and (svref ,ar+ ch)
                   (do ((i 1 (1+ i))) ((= i ,n) nil)
                       (declare (type fixnum i))
                       (when (svref ,ar
                                    (the fixnum
                                         (char-code (aref (the string ,s) i))))
                         (return t))))))

; The string does not end with a sign.

        (not (member (aref (the string ,s) (the fixnum (1- ,n)))
                     '(#\+ #\-)))

; The strong consists entirely of digits, signs, ratio markers, decimal points,
; extension characters, and number markers (i.e. letters, but no two in a
; row).  The logic code for this is may-need-slashes1.

        (let ((prev-letter-p nil))
          (do ((i 0 (1+ i))) ((= i ,n) t)
              (declare (type fixnum i))
              (let ((ch (char-code (aref (the string ,s) i))))
                (declare (type fixnum ch))
                (cond ((or (svref ,ar+ ch)
                           (int= ch *char-code-slash*))
                       (setq prev-letter-p nil))
                      ((svref *letter-array* ch)
                       (cond (prev-letter-p (return nil))
                             (t (setq prev-letter-p t))))
                      (t (return nil))))))))))

(local ; needed for may-need-slashes-fn; could consider making this non-local
 (defthm character-listp-cdr
   (implies (character-listp x)
            (character-listp (cdr x)))
   :rule-classes :forward-chaining))

(defun may-need-slashes-fn (x print-base)

; We determine if the string x, a symbol name or symbol-package name, should be
; printed using |..|.  The main ideas are to escape lower-case characters and
; to avoid the possibility of reading the printed result back in as a number
; instead of a symbol.

; More precisely: This function should return true if x represents a potential
; number, and ideally only if that is the case (in order to avoid needless use
; of |..|).  The notion of "potential number" is discussed below.  We perhaps
; escape more than necessary if print-base is 2, 4, or 8; the Common Lisp spec
; may not be clear on this, and anyhow it's simplest to be conservative and
; treat those bases as we treat base 10.

; The following four paragraphs from from Section 22.1.2 of CLtL2 ("Common Lisp
; the Language", 2nd Edition, by Guy L. Steele, Jr.) explains why we give
; separate consideration to the symbol-package-name and symbol-name.

;    If there is a single package marker, and it occurs at the beginning of the
;    token, then the token is interpreted as a keyword, that is, a symbol in
;    the keyword package. The part of the token after the package marker must
;    not have the syntax of a number.

;    If there is a single package marker not at the beginning or end of the
;    token, then it divides the token into two parts. The first part specifies
;    a package; the second part is the name of an external symbol available in
;    that package. Neither of the two parts may have the syntax of a number.

;    If there are two adjacent package markers not at the beginning or end of
;    the token, then they divide the token into two parts. The first part
;    specifies a package; the second part is the name of a symbol within that
;    package (possibly an internal symbol). Neither of the two parts may have
;    the syntax of a number.

;    X3J13 voted in March 1988 (COLON-NUMBER) to clarify that, in the
;    situations described in the preceding three paragraphs, the restriction on
;    the syntax of the parts should be strengthened: none of the parts may have
;    the syntax of even a potential number. Tokens such as :3600, :1/2, and
;    editor:3.14159 were already ruled out; this clarification further declares
;    that such tokens as :2^ 3, compiler:1.7J, and Christmas:12/25/83 are also
;    in error and therefore should not be used in portable
;    programs. Implementations may differ in their treatment of such
;    package-marked potential numbers.

; The following paragraph from a copy of the ANSI standard provides general
; guidance for printing symbols.  We keep things simple by doing our escaping
; using |..|.

;    When printing a symbol, the printer inserts enough single escape and/or
;    multiple escape characters (backslashes and/or vertical-bars) so that if
;    read were called with the same *readtable* and with *read-base* bound to
;    the current output base, it would return the same symbol (if it is not
;    apparently uninterned) or an uninterned symbol with the same print name
;    (otherwise).
;
;    For example, if the value of *print-base* were 16 when printing the symbol
;    face, it would have to be printed as \FACE or \Face or |FACE|, because the
;    token face would be read as a hexadecimal number (decimal value 64206) if
;    the value of *read-base* were 16.
;
; Now, ACL2 never sets the read-base to 10, and indeed it only allows setting
; of its own print-base (i.e., state global 'print-base rather than Lisp
; variable *print-base*).  Nevertheless we take a conservative interpretation
; of the paragraph immediately above: if the ACL2 print-base is 16, then we
; print a symbol as though it may be read back in base 16, which could happen
; if the user submits the result to raw Lisp.
;
; Back to the same CLtL2 section as above, we find the following syntax for
; numbers.

;    Table 22-2: Actual Syntax of Numbers
;
;    number ::= integer | ratio | floating-point-number
;    integer ::= [sign] {digit}+ [decimal-point]
;    ratio ::= [sign] {digit}+ / {digit}+
;    floating-point-number ::= [sign] {digit}* decimal-point {digit}+ [exponent]
;                           | [sign] {digit}+ [decimal-point {digit}*] exponent
;    sign ::= + | -
;    decimal-point ::= .
;    digit ::= 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9
;    exponent ::= exponent-marker [sign] {digit}+
;    exponent-marker ::= e | s | f | d | l | E | S | F | D | L

; But instead of escaping strings that represent numbers, we escape strings
; that represent potential numbers.  Quoting again from that same section of
; CLtL2:
;
;    To allow for extensions to the syntax of numbers, a syntax for
;    potential numbers is defined in Common Lisp that is more general
;    than the actual syntax for numbers. Any token that is not a
;    potential number and does not consist entirely of dots will always
;    be taken to be a symbol, now and in the future; programs may rely on
;    this fact. Any token that is a potential number but does not fit the
;    actual number syntax defined below is a reserved token and has an
;    implementation-dependent interpretation; an implementation may
;    signal an error, quietly treat the token as a symbol, or take some
;    other action. Programmers should avoid the use of such reserved
;    tokens. (A symbol whose name looks like a reserved token can always
;    be written using one or more escape characters.)
;
;    ...
;
;    A token is a potential number if it satisfies the following requirements:
;
;        * It consists entirely of digits, signs (+ or -), ratio markers
;          (/), decimal points (.), extension characters (^ or _), and
;          number markers. (A number marker is a letter. Whether a letter
;          may be treated as a number marker depends on context, but no
;          letter that is adjacent to another letter may ever be treated
;          as a number marker. Floating-point exponent markers are
;          instances of number markers.)
;
;        * It contains at least one digit. (Letters may be considered to
;          be digits, depending on the value of *read-base*, but only in
;          tokens containing no decimal points.)
;
;        * It begins with a digit, sign, decimal point, or extension character.
;
;        * It does not end with a sign.

; Below are examples.

;  (defconst *a*
;    '(
;  ; Treat symbol package and name separately.  Numeric strings need escaping.
;      :|3| :|3G| :|33| |ACL2-PC|::|3| ; pkg is numeric except single letters
;  ;   :|3| :|3G| :|33|  ACL2-PC::|3|
;
;  ; None of the following strings gives a potential number in base 10: "no letter
;  ; that is adjacent to another letter may ever be treated as a number marker".
;  ; All these strings represent numbers in base 16.
;      |ABC| |3BC| |+3BC| |-3BC|
;  ;16 |ABC| |3BC| |+3BC| |-3BC|
;  ;10  ABC   3BC   +3BC   -3BC
;
;  ; Allegro gets this wrong, but ACL2 gets it right: potential number!
;      |_345|
;  ;   |_345| ; SBCL 1.0.19, LispWorks 4.4.6, CMU CL 19e, CLISP 2.41, GCL 2.6.7
;  ;    _345  ; [wrong] Allegro 8.0, CCL 1.2
;
;  ; Also not potential numbers, even in base 16: the first because of the decimal
;  ; point (for base 16), the second because of the underscore, and the third
;  ; because of consecutive letters that are not digits even in base 16.
;      |A/B+.C| |3A3GG3|
;  ;    A/B+.C   3A3GG3
;
;  ; Potential number because letters are not consecutive.
;      |3A3G3|
;  ;   |3A3G3|
;
;  ; Not potential numbers: must begin with a digit, sign, decimal point, or
;  ; extension character, and cannot end with a sign.
;      |/12| |12+| |12C-|
;  ;    /12   12+   12C-
;
;  ; Must contain at least one digit.
;      |+A|
;  ;16 |+A|
;  ;10  +A
;      ))
;
;  (defconst *b*
;
;  ; This example is from CLtL2 with the following explanation given there:
;
;  ; As examples, the following tokens are potential numbers, but they are not
;  ; actually numbers as defined below, and so are reserved tokens. (They do
;  ; indicate some interesting possibilities for future extensions.)  So all
;  ; should have verticle bars.
;
;    '(|1B5000| ; oddly, GCL skips the vertical bars for this first one
;      |777777Q| |1.7J| |-3/4+6.7J| |12/25/83| |27^19| |3^4/5| |6//7| |3.1.2.6|
;      |^-43^| |3.141_592_653_589_793_238_4| |-3.7+2.6I-6.17J+19.6K|))
;
;  (defconst *c*
;
;  ; This example is from CLtL2 with the following explanation given there:
;
;  ; The following tokens are not potential numbers but are always treated as
;  ; symbols:
;
;    '(|/| |/5| |+| |1+| |1-| |FOO+| |AB.CD| |_| |^| |^/-|))
;
;  (defconst *d*
;
;  ; From CLtL2, we see that we need |..| for each of the following in base 16 but
;  ; for none of them in base 10.
;
;  ; This example is from CLtL2 with the following explanation given there:
;
;  ; The following tokens are potential numbers if the value of *read-base* is 16
;  ; (an abnormal situation), but they are always treated as symbols if the value
;  ; of *read-base* is 10 (the usual value):
;
;    '(|BAD-FACE| |25-DEC-83| |A/B| |FAD_CAFE| |F^|))
;
; ; Now try check the answers:
;
;  (set-print-base 16)
;  (list *a* *b* *c* *d*)
;  (set-print-base 10)
;  (list *a* *b* *c* *d*)

  (declare (type string x))

  #+acl2-loop-only
  (let* ((l (coerce x 'list))
         (print-base

; Treat the base as 10 instead of 16 if there is a decimal point, as per the
; definition of potential number.

          (if (and (eql print-base 16) (member #\. l))
              10
            print-base))
         (numeric-chars (numeric-chars print-base))
         (suspiciously-first-numeric-chars
          (suspiciously-first-numeric-chars print-base)))
    (or (null l)
; Keep the following conjunction in sync with potential-numberp.
        (and (or (member (car l) numeric-chars)
                 (and (member (car l) suspiciously-first-numeric-chars)
                      (intersectp (cdr l) numeric-chars)))
             (not (member (car (last l))
                          '(#\+ #\-)))
             (may-need-slashes1 (cdr l) nil
                                (cons #\/ suspiciously-first-numeric-chars)))
        (some-slashable l)))

  #-acl2-loop-only
  (let ((len (length (the string x))))
    (declare (type fixnum len)) ; fixnum by Section 15.1.1.2 of CL Hyperspec
    (when (eql print-base 16)
      (do ((i 0 (1+ i))) ((= i len) nil)
          (declare (type fixnum i))
          (let ((ch (aref (the string x) i)))
            (declare (type character ch))
            (cond ((eql ch #\.)
                   (setq print-base 10)
                   (return))))))
    (or (int= len 0)
        (potential-numberp x len print-base)
        (do ((i 0 (1+ i))) ((= i len) nil)
            (declare (type fixnum i))
            (let ((ch (char-code (aref (the string x) i))))
              (declare (type fixnum ch))
              (cond ((svref *slashable-array* ch)
                     (return t))))))))

(defmacro may-need-slashes (x &optional (print-base '10))

; This macro is deprecated; see needs-slashes instead.  For backward
; compatibility (e.g., in community book books/misc/hons-help.lisp), the
; print-base is optional.  For our own convenience, we allow that argument to
; be t in the normal case, where we take the print-base from the state.

  `(may-need-slashes-fn ,x ,print-base))

(defun needs-slashes (x state)
  (declare (xargs :guard (and (stringp x)
                              (state-p state)
                              (boundp-global 'print-escape state)
                              (boundp-global 'print-readably state)
                              (boundp-global 'print-base state))))
  (and (or (f-get-global 'print-escape state)
           (f-get-global 'print-readably state))
       (may-need-slashes-fn x (print-base))))


;                              T-STACK

#-acl2-loop-only
(progn

(defparameter *t-stack* (make-array$ 5))

(defparameter *t-stack-length* 0)

)


(defun t-stack-length1 (state-state)

; Wart: We use state-state instead of state because of a bootstrap problem.

  (declare (xargs :guard (state-p1 state-state)))
  #-acl2-loop-only
  (cond ((live-state-p state-state)
         (return-from t-stack-length1
                      *t-stack-length*)))
  (length (t-stack state-state)))

(defun t-stack-length (state-state)

; Wart: We use state-state instead of state because of a bootstrap problem.

  (declare (xargs :guard (state-p1 state-state)))
  (t-stack-length1 state-state))

(defun make-list-ac (n val ac)
  (declare (xargs :guard (and (integerp n)
                              (>= n 0))))
  (cond ((zp n) ac)
        (t (make-list-ac (1- n) val (cons val ac)))))

#+acl2-loop-only
(defmacro make-list (size &key initial-element)

  ":Doc-Section ACL2::ACL2-built-ins

  make a list of a given size~/

  For a nonnegative integer ~c[size], ~c[(Make-list size)] is a list of
  elements of length ~c[size], each of which is initialized to the
  ~c[:initial-element] (which defaults to ~c[nil]).~/

  ~c[Make-list] is a macro in ACL2, defined in terms of a tail
  recursive function ~c[make-list-ac] whose ~il[guard] requires ~c[size] to
  be a nonnegative integer.  ~c[Make-list] is a Common Lisp function.
  See any Common Lisp documentation for more information.~/"

  `(make-list-ac ,size ,initial-element nil))

(defun extend-t-stack (n val state-state)

; Wart: We use state-state instead of state because of a bootstrap problem.

  (declare (type (integer (0) *) n) (xargs :guard (state-p1 state-state)))
  #-acl2-loop-only
  (cond ((live-state-p state-state)
         (cond (*wormholep*
                (wormhole-er 'extend-t-stack (list n val))))
         (let ((new-length (+ *t-stack-length* n)))
           (cond ((> new-length (length (the simple-vector
                                             *t-stack*)))
                  (let ((new-length new-length))
                    (declare (type fixnum new-length))
                    (let ((new-array (make-array$ (* 2 new-length))))
                      (declare (simple-vector new-array))
                      (do ((i (1- *t-stack-length*) (1- i)))
                          ((< i 0))
                          (declare (type fixnum i))
                          (setf (svref new-array i)
                                (svref *t-stack* i)))
                      (setq *t-stack* new-array)))))
           (let ((new-length new-length))
             (declare (type fixnum new-length))
             (do ((i *t-stack-length* (1+ i)))
                 ((= i new-length))
                 (declare (type fixnum i))
                 (setf (svref *t-stack* i) val))
             (setq *t-stack-length* new-length)))
         (return-from extend-t-stack state-state)))
  (update-t-stack
   (append (t-stack state-state)
           (make-list-ac n val nil))
   state-state))

(encapsulate
 ()

 (local
  (defthm true-listp-nthcdr
    (implies (true-listp lst)
             (true-listp (nthcdr n lst)))
    :rule-classes :type-prescription))

 (verify-termination-boot-strap subseq-list)

 (local
  (defthm character-listp-first-n-ac
    (implies (and (character-listp x)
                  (character-listp y)
                  (<= n (length x)))
             (character-listp (first-n-ac n x y)))))

 (local
  (defthm len-nthcdr
    (implies (and (integerp n)
                  (<= 0 n)
                  (<= n (len x)))
             (equal (len (nthcdr n x))
                    (- (len x) n)))))

 (local
  (defthm character-listp-nthcdr
    (implies (character-listp x)
             (character-listp (nthcdr n x)))))

 (verify-termination-boot-strap subseq))

; The following constants and the next two functions, pathname-os-to-unix and
; pathname-unix-to-os, support the use of Unix-style filenames in ACL2 as
; described in the Essay on Pathnames in interface-raw.lisp.

; The following constants represent our decision to use Unix-style pathnames
; within ACL2.  See the Essay on Pathnames in interface-raw.lisp.

(defconst *directory-separator*
  #\/)

(defconst *directory-separator-string*
  (string *directory-separator*))

(defmacro os-er (os fnname)
  `(illegal ,fnname
    "The case where (os (w state)) is ~x0 has not been handled by the ~
     ACL2 implementors for the function ~x1.  Please inform them of this ~
     problem."
    (list (cons #\0 ,os)
          (cons #\1 ,fnname))))

(defun os (wrld)
  (declare (xargs :guard (plist-worldp wrld)))
  (global-val 'operating-system wrld))

(local (in-theory (enable boundp-global1)))

(verify-guards w)
(verify-guards hons-enabledp)
(verify-guards set-serialize-character)

(defun mswindows-drive1 (filename)
  (declare (xargs :mode :program))
  (let ((pos-colon (position #\: filename))
        (pos-sep (position *directory-separator* filename)))
    (cond (pos-colon (cond ((eql pos-sep (1+ pos-colon))

; 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.  Indeed, quoting
; http://msdn.microsoft.com/en-us/library/windows/desktop/aa365247(v=vs.85).aspx:

;   Volume designators (drive letters) are similarly case-insensitive. For
;   example, "D:\" and "d:\" refer to the same volume.

; So we take responsibility for canonicalizing, here.

                            (string-upcase (subseq filename 0 pos-sep)))
                           (t (illegal 'mswindows-drive1
                                       "Implementation error: Unable to ~
                                        compute mswindows-drive for ~
                                        cbd:~%~x0~%(Implementor should see ~
                                        function mswindows-drive),"
                                       (list (cons #\0 filename))))))
          (t nil))))

(defun mswindows-drive (filename state)

; We get the drive from filename if possible, else from cbd.

  (declare (xargs :mode :program))
  (or (and (eq (os (w state)) :mswindows)
           (or (and filename (mswindows-drive1 filename))
               (let ((cbd (f-get-global 'connected-book-directory state)))
                 (cond (cbd (mswindows-drive1 cbd))
                       (t (illegal 'mswindows-drive
                                   "Implementation error: Cbd is nil when ~
                                    attempting to set mswindows-drive."
                                   nil))))))
      ""))

(defun pathname-os-to-unix (str os state)

; This function takes a pathname string in the host OS syntax and converts it
; to Unix syntax.

  (declare (xargs :mode :program))
  (if (equal str "")
      str
    (case os
      (:unix str)
      ((:apple :mswindows)
       (let ((sep (if (eq os :apple) #\: #\\)))
         (let* ((relative-p-apple ; relevant only for apple
                 (eql (char str 0) sep))
                (str0 (substitute
                       *directory-separator* sep
                       (cond
                        ((eq os :mswindows)
                         str)
                        (relative-p-apple (subseq str 1 (length str)))
                        (t str)))))
           (cond
            ((and (eq os :apple)
                  (not relative-p-apple))
             (string-append *directory-separator-string* str0))
            ((and (eq os :mswindows)
                  (eql (char str0 0) *directory-separator*))

; Warning: Do not append the drive if there is already a drive present.  We
; rely on this in LP, where we initialize state global 'system-books-dir
; using unix-full-pathname (which calls pathname-os-to-unix) based on
; environment variable ACL2_SYSTEM_BOOKS, which might already have a drive that
; differs from that of the user.

             (string-append (mswindows-drive nil state)
                            str0))
            (t
             str0)))))
      (otherwise (os-er os 'pathname-os-to-unix)))))

#+(and (not acl2-loop-only) ccl)
(defun ccl-at-least-1-3-p ()
  (and (boundp 'ccl::*openmcl-major-version*)
       (boundp 'ccl::*openmcl-minor-version*)
       (if (eql (symbol-value 'ccl::*openmcl-major-version*) 1)
           (> (symbol-value 'ccl::*openmcl-minor-version*) 2)
         (> (symbol-value 'ccl::*openmcl-major-version*) 1))))

(defun pathname-unix-to-os (str state)

; This function takes a Unix-style pathname string and converts it to a
; filename in the host OS.  In the case of :mswindows, the "Unix-style"
; filename may or may not start with the drive, but the result definitely does.

  (declare (xargs :mode :program))
  #+(and (not acl2-loop-only) ccl mswindows)

; We believe that CCL 1.2 traffics in Unix-style pathnames, so it would be a
; mistake to convert them to use #\\, because then (for example) probe-file may
; fail.  However, we will allow Windows-style pathnames for CCL Versions 1.3
; and beyond, based on the following quote from
; http://trac.clozure.com/ccl/wiki/WindowsNotes (4/30/09):

;   Windows pathnames can use either forward-slash or backward-slash characters
;   as directory separators. As of the 1.3 release, CCL should handle
;   namestrings which use either forward- or backward-slashes; some prereleases
;   and release-candidates generally had difficulty with backslashes.

  (when (not (ccl-at-least-1-3-p))
    (return-from pathname-unix-to-os str))

  (if (equal str "")
      str
    (let ((os (os (w state))))
      (case os
        (:unix str)
        ((:apple :mswindows)
         (let ((sep (if (eq os :apple) #\: #\\)))
           (if (position sep str)
               (illegal 'pathname-unix-to-os
                "Unable to convert pathname ~p0 for OS ~p1 because ~
                 character ~p2 occurs in that pathname string at position ~p3."
                (list (cons #\0 str)
                      (cons #\1 os)
                      (cons #\2 sep)
                      (cons #\3 (position sep str))))
             (let* ((sep-is-first (eql (char str 0) *directory-separator*))
                    (str0 (substitute sep *directory-separator*
                                      (if (and (eq os :apple)
                                               sep-is-first)
                                          (subseq str 1 (length str))
                                        str))))
               (if (eq os :apple)
                   (if sep-is-first
                       str0
                     (string-append ":" str0))
                 (if sep-is-first
                     (string-append (mswindows-drive nil state)
                                    str0)
                   str0))))))
        (otherwise (os-er os 'pathname-unix-to-os))))))

(defun shrink-t-stack (n state-state)

; Wart: We use state-state instead of state because of a bootstrap problem.

  (declare (type (integer 0 *) n)
           (xargs :guard (state-p1 state-state)))

  #-acl2-loop-only
  (cond ((live-state-p state-state)
         (cond (*wormholep*
                (wormhole-er 'shrink-t-stack (list n))))
         (let ((old *t-stack-length*)
               (new (max 0 (- *t-stack-length* n))))
           (declare (type fixnum old new))
           (setq *t-stack-length* new)
           (do ((i new (1+ i))) ((= i old))
               (declare (type fixnum i))
               (setf (svref *t-stack* i) nil)))
         (return-from shrink-t-stack *the-live-state*)))
  (update-t-stack
   (first-n-ac (max 0 (- (length (t-stack state-state)) n))
               (t-stack state-state)
               nil)
   state-state))

(defun aref-t-stack (i state-state)

; Wart: We use state-state instead of state because of a bootstrap problem.

  #-acl2-loop-only
  (declare (type fixnum i))
  (declare (xargs :guard (and (integerp i)
                              (>= i 0)
                              (state-p1 state-state)
                              (< i (t-stack-length1 state-state)))))
  (cond #-acl2-loop-only
        ((live-state-p state-state)
         (svref *t-stack* (the fixnum i)))
        (t (nth i (t-stack state-state)))))

(defun aset-t-stack (i val state-state)

; Wart: We use state-state instead of state because of a bootstrap problem.

  #-acl2-loop-only
  (declare (type fixnum i))
  (declare (xargs :guard (and (integerp i)
                              (>= i 0)
                              (state-p1 state-state)
                              (< i (t-stack-length1 state-state)))))
  (cond #-acl2-loop-only
        ((live-state-p state-state)
         (cond (*wormholep*
                (wormhole-er 'aset-t-stack (list i val))))
         (setf (svref *t-stack* (the fixnum i))
               val)
         state-state)
        (t (update-t-stack
            (update-nth
             i val
             (t-stack state-state))
            state-state))))

; 32-bit-integer-stack

#-acl2-loop-only
(progn

(defparameter *32-bit-integer-stack*
  (make-array$ 5 :element-type '(signed-byte 32)))

(defparameter *32-bit-integer-stack-length* 0)

)

(defun 32-bit-integer-stack-length1 (state-state)
  (declare (xargs :guard (state-p1 state-state)))
  #-acl2-loop-only
  (cond ((live-state-p state-state)
         (return-from 32-bit-integer-stack-length1
                      *32-bit-integer-stack-length*)))
  (length (32-bit-integer-stack state-state)))

(defun 32-bit-integer-stack-length (state-state)

; Wart: We use state-state instead of state because of a bootstrap problem.

  (declare (xargs :guard (state-p1 state-state)))
  (32-bit-integer-stack-length1 state-state))

(defun extend-32-bit-integer-stack (n val state-state)

; Wart: We use state-state instead of state because of a bootstrap problem.

  (declare (xargs :guard (and (32-bit-integerp val)
                              (integerp n)
                              (> n 0)
                              (state-p1 state-state))))
  #-acl2-loop-only
  (cond ((live-state-p state-state)
         (cond (*wormholep*
                (wormhole-er 'extend-32-bit-integer-stack (list n val))))
         (let ((new-length (+ *32-bit-integer-stack-length* n)))
           (cond ((> new-length (length (the (array (signed-byte 32) (*))
                                         *32-bit-integer-stack*)))
                  (let ((new-length new-length))
                    (declare (type fixnum new-length))
                    (let ((new-array (make-array$
                                      (* 2 new-length)
                                      :element-type
                                      '(signed-byte 32))))
                      (declare (type (array (signed-byte 32) (*)) new-array))
                      (do ((i (1- *32-bit-integer-stack-length*) (1- i)))
                          ((< i 0))
                          (declare (type fixnum i))
                          (setf (aref (the (array (signed-byte 32) (*))
                                       new-array)
                                      i)
                                (aref (the (array (signed-byte 32) (*))
                                       *32-bit-integer-stack*)
                                      i)))
                      (setq *32-bit-integer-stack* new-array)))))
           (let ((new-length new-length))
             (declare (type fixnum new-length))
             (do ((i *32-bit-integer-stack-length* (1+ i)))
                 ((= i new-length))
                 (declare (type fixnum i))
                 (setf (aref (the (array (signed-byte 32) (*))
                              *32-bit-integer-stack*)
                             i) val))
             (setq *32-bit-integer-stack-length* new-length)))
         (return-from extend-32-bit-integer-stack
                      state-state)))
  (update-32-bit-integer-stack
   (append (32-bit-integer-stack state-state)
           (make-list-ac n val nil))
   state-state))

(defun shrink-32-bit-integer-stack (n state-state)

; Wart: We use state-state instead of state because of a bootstrap problem.

  (declare (type (integer 0 *) n)
           (xargs :guard (state-p1 state-state)))
  #-acl2-loop-only
  (cond ((live-state-p state-state)
         (cond (*wormholep*
                (wormhole-er 'shrink-32-bit-integer-stack (list n))))
         (let ((old *32-bit-integer-stack-length*)
               (new (max 0 (- *32-bit-integer-stack-length* n))))
           (declare (type fixnum old new))
           (setq *32-bit-integer-stack-length* new)
           (do ((i new (1+ i))) ((= i old))
               (declare (type fixnum i))
               (setf (aref (the (array (signed-byte 32) (*))
                            *32-bit-integer-stack*)
                           i)
                     0)))
         (return-from shrink-32-bit-integer-stack
                      state-state)))
  (update-32-bit-integer-stack
   (first-n-ac
    (max 0 (- (length (32-bit-integer-stack
                       state-state))
              n))
    (32-bit-integer-stack state-state)
    nil)
   state-state))

(defun aref-32-bit-integer-stack (i state-state)
  #-acl2-loop-only
  (declare (type fixnum i))
  (declare (xargs :guard (and (integerp i)
                              (>= i 0)
                              (state-p1 state-state)
                              (< i (32-bit-integer-stack-length1
                                    state-state)))))

; Wart: We use state-state instead of state because of a bootstrap problem.

  #-acl2-loop-only
  (the (signed-byte 32)
   (cond
    ((live-state-p state-state)
     (the (signed-byte 32)
      (aref (the (array (signed-byte 32) (*))
             *32-bit-integer-stack*)
            (the fixnum i))))
    (t (nth i (32-bit-integer-stack state-state)))))
  #+acl2-loop-only
  (nth i (32-bit-integer-stack state-state)))

(defun aset-32-bit-integer-stack (i val state-state)

; Wart: We use state-state instead of state because of a bootstrap problem.

  #-acl2-loop-only
  (declare (type fixnum i))
  (declare (type (signed-byte 32) val))
  (declare (xargs :guard (and (integerp i)
                              (>= i 0)
                              (state-p1 state-state)
                              (< i (32-bit-integer-stack-length1 state-state))
                              (32-bit-integerp val))))
  (cond #-acl2-loop-only
        ((live-state-p state-state)
         (cond (*wormholep*
                (wormhole-er 'aset-32-bit-integer-stack (list i val))))
         (setf (aref (the (array (signed-byte 32) (*))
                      *32-bit-integer-stack*)
                     (the fixnum i))
               (the (signed-byte 32)
                val))
         state-state)
        (t
         (update-32-bit-integer-stack
          (update-nth
           i val
           (32-bit-integer-stack state-state))
          state-state))))

(defmacro f-big-clock-negative-p (st)
  #-acl2-loop-only
  (let ((s (gensym)))
    `(let ((,s ,st))
       (cond ((live-state-p ,s) nil)
             (t (big-clock-negative-p ,s)))))
  #+acl2-loop-only
  (list 'big-clock-negative-p st))

(defmacro f-decrement-big-clock (st)
  #-acl2-loop-only
  (let ((s (gensym)))
    `(let ((,s ,st))
       (cond ((live-state-p ,s)

; Because there is no way to get the big-clock-entry for
; *the-live-state* we do not have to prevent the field from changing
; when *wormholep* is true.

              *the-live-state*)
             (t (decrement-big-clock ,s)))))
  #+acl2-loop-only
  (list 'decrement-big-clock st))

; ??? (v. 1.8) I think it would be simpler to check for "zero-ness" rather
; than negativity, using zp.  For now I won't touch the following or
; related functions.

(defun big-clock-negative-p (state-state)

; Wart: We use state-state instead of state because of a bootstrap problem.

; big-clock-negative-p plays a crucial role in the termination of ev,
; translate1, and rewrite.  The justification for big-clock-negative-p
; never returning t when given *the-live-state* be found in a comment
; on ld, where it is explained that a (constructive) existential
; quantifier is used in semantics of a top-level interaction with ld.
; Any ld interaction that completes will have called
; big-clock-decrement at most a finite number of times.  The number of
; these calls will provide an appropriate value for the
; big-clock-entry for that interaction.

  (declare (xargs :guard (state-p1 state-state)))
  #-acl2-loop-only
  (cond ((live-state-p state-state)
         (return-from big-clock-negative-p nil)))
  (< (big-clock-entry state-state) 0))

(defun decrement-big-clock (state-state)

; Wart: We use state-state instead of state because of a bootstrap problem.

; decrement-big-clock is the one function which is permitted to
; violate the rule that any function which is passed a state and
; modifies it must return it.  A function that is passed state may
; pass one down the result of apply decrement-big-clock to the given
; state.  decrement-big-clock is exempted from the requirement because
; there are means internal or external to ACL2 for perceiving the
; current big-clock value.

  (declare (xargs :guard (state-p1 state-state)))
  #-acl2-loop-only
  (cond ((live-state-p state-state)

; Because there is no way to get the big-clock-entry for
; *the-live-state* we do not have to prevent the field from changing
; when *wormholep* is true.

         (return-from decrement-big-clock *the-live-state*)))
  (update-big-clock-entry
   (1- (big-clock-entry state-state))
   state-state))

(defun list-all-package-names (state-state)
  (declare (xargs :guard (state-p1 state-state)))

;   Wart: We use state-state instead of state because of a bootstrap problem.

  #-acl2-loop-only
  (cond ((live-state-p state-state)
         (return-from list-all-package-names
                      (mv (mapcar (function package-name)
                                  (list-all-packages))
                          state-state))))
  (mv (car (list-all-package-names-lst state-state))
      (update-list-all-package-names-lst
       (cdr (list-all-package-names-lst state-state))
       state-state)))

(defun user-stobj-alist (state-state)
  (declare (xargs :guard (state-p1 state-state)))

;   Wart: We use state-state instead of state because of a bootstrap problem.

  #-acl2-loop-only
  (cond ((live-state-p state-state)
         (return-from user-stobj-alist *user-stobj-alist*)))
  (user-stobj-alist1 state-state))

(defun update-user-stobj-alist (x state-state)
  (declare (xargs :guard (and (symbol-alistp x)
                              (state-p1 state-state))))

;   Wart: We use state-state instead of state because of a bootstrap problem.

  #-acl2-loop-only
  (cond ((live-state-p state-state)
         (setq *user-stobj-alist* x)
         (return-from update-user-stobj-alist *the-live-state*)))
  (update-user-stobj-alist1 x state-state))

(defun power-eval (l b)
  (declare (xargs :guard (and (rationalp b)
                              (rational-listp l))))
  (if (endp l)
      0
      (+ (car l) (* b (power-eval (cdr l) b)))))

#-acl2-loop-only
(defun-one-output idate ()
  (power-eval
   (let (ans)
     (do ((i 1 (1+ i))
          (tl (multiple-value-list (get-decoded-time)) (cdr tl)))
         ((> i 6) (reverse ans))
         (push (cond ((= i 6) (- (car tl) 1900))
                     (t (car tl)))
               ans))
     (reverse ans))
   100))

(defun read-idate (state-state)

  (declare (xargs :guard (state-p1 state-state)))

;   Wart: We use state-state instead of state because of a bootstrap problem.

  #-acl2-loop-only
  (cond ((live-state-p state-state)

; Because there is no way for the user to know what the idates of the original
; state were, there is no way to tell whether we changed them.  So we permit
; read-idate to work even when *wormholep* is non-nil.

         (return-from read-idate (mv (idate) state-state))))
  (mv (cond ((null (idates state-state))
             0)
            (t (car (idates state-state))))
      (update-idates (cdr (idates state-state)) state-state)))

#-acl2-loop-only
(defun get-internal-time ()
  (if (f-get-global 'get-internal-time-as-realtime *the-live-state*)
      (get-internal-real-time)
    (get-internal-run-time)))

(defdoc get-internal-time
  ":Doc-Section Miscellaneous

  runtime vs. realtime in ACL2 timings~/

  The ACL2 system provides utilities that deal with elapsed time.  The most
  visible of these is in the time summaries printed when completing evaluation
  of ~il[events].  For others, ~pl[with-prover-time-limit], ~pl[read-run-time],
  ~pl[time-tracker], ~pl[time-tracker-tau], and ~pl[pstack].

  By default, these utilities all use an underlying notion of run time provided
  by the host Common Lisp implementation: specifically, Common Lisp function
  ~c[get-internal-run-time].  However, Common Lisp also provides function
  ~c[get-internal-run-time], which returns the real time (wall clock time).
  While the latter is specified to measure elapsed time, the former is left to
  the implementation, which might well only measure time spent in the Lisp
  process.  Consider the following example, which is a bit arcane but basically
  sleeps for 2 seconds.
  ~bv[]
    (defttag t) ; to allow sys-call
    (make-event
     (prog2$ (sys-call \"sleep\" '(\"2\"))
             (value '(value-triple nil))))
  ~ev[]
  A typical time summary might be as follows, drastically under-reporting the
  elapsed time.
  ~bv[]
    Time:  0.01 seconds (prove: 0.00, print: 0.00, other: 0.01)
  ~ev[]
  However, you can instruct ACL2 to switch to using elapsed time (run time), in
  summaries and elsewhere, by evaluating the following form.
  ~bv[]
    (assign get-internal-time-as-realtime t)
  ~ev[]
  To return to using runtime:
  ~bv[]
    (assign get-internal-time-as-realtime nil)
  ~ev[]
  While the above example is rather silly, the issue becomes significant in
  time summaries for proofs that call out to external tools (~pl[sys-call] and
  ~pl[clause-processor]).

  Note that a function ~c[get-internal-time] is defined in raw Lisp but is not
  available inside the ACL2 loop.  However, the expression
  ~c[(read-run-time state)] provides an interface to this function that is
  available inside the ACL2 loop; ~pl[read-run-time].

  We are open to changing the default to elapsed wall-clock time (realtime),
  and may do so in future ACL2 releases.~/~/")

(defun read-run-time (state-state)

  ":Doc-Section ACL2::ACL2-built-ins

  read elapsed runtime~/

  By default, ~c[(read-run-time state)] returns ~c[(mv runtime state)], where
  runtime is the elapsed runtime in seconds since the start of the current ACL2
  session and ~c[state] is the resulting ACL2 ~il[state].  But
  ~c[read-run-time] can be made to return elapsed realtime (wall clock time)
  instead; ~pl[get-internal-time].~/

  The logical definition probably won't concern many users, but for
  completeness, we say a word about it here.  That definition uses the function
  ~c[read-acl2-oracle], which modifies state by popping the value to return
  from its acl2-oracle field.~/"

  (declare (xargs :guard (state-p1 state-state)))

;   Wart: We use state-state instead of state because of a bootstrap problem.

; See also read-acl2-oracle.

  #-acl2-loop-only
  (cond ((live-state-p state-state)

; Because there is no way for the user to know the acl2-oracle of the original
; state, there is no way to tell whether we changed it.  So we permit
; read-run-time to work even when *wormholep* is non-nil.

         (return-from read-run-time
                      (mv (/ (get-internal-time)
                             internal-time-units-per-second)
                          state-state))))
  (mv (cond ((or (null (acl2-oracle state-state))
                 (not (rationalp (car (acl2-oracle state-state)))))
             0)
            (t (car (acl2-oracle state-state))))
      (update-acl2-oracle (cdr (acl2-oracle state-state)) state-state)))

#-acl2-loop-only
(defparameter *next-acl2-oracle-value* nil)

(defun read-acl2-oracle (state-state)

; Keep in sync with #+acl2-par read-acl2-oracle@par.

  (declare (xargs :guard (state-p1 state-state)))

;   Wart: We use state-state instead of state because of a bootstrap problem.

; See also read-run-time.

  #-acl2-loop-only
  (cond ((live-state-p state-state)
         (return-from read-acl2-oracle
                      (let ((val *next-acl2-oracle-value*))
                        (setq *next-acl2-oracle-value* nil)
                        (mv nil val state-state)))))
  (mv (null (acl2-oracle state-state))
      (car (acl2-oracle state-state))
      (update-acl2-oracle (cdr (acl2-oracle state-state)) state-state)))

#+acl2-par
(defun read-acl2-oracle@par (state-state)

; Keep in sync with read-acl2-oracle.

; Note that this function may make it possible to evaluate (equal X X) and
; return nil, for a suitable term X.  Specifically, it may be the case that the
; term (equal (read-acl2-oracle@par state) (read-acl2-oracle@par state)) can
; evaluate to nil.  More likely, something like
; (equal (read-acl2-oracle@par state)
;        (prog2$ <form> (read-acl2-oracle@par state)))
; could evaluate to nil, if <form> sets *next-acl2-oracle-value* under the
; hood.  However, we are willing to live with such low-likelihood risks in
; ACL2(p).

  (declare (xargs :guard (state-p1 state-state)))
  #-acl2-loop-only
  (cond ((live-state-p state-state)
         (return-from read-acl2-oracle@par
                      (let ((val *next-acl2-oracle-value*))
                        (setq *next-acl2-oracle-value* nil)
                        (mv nil val state-state)))))
  (mv (null (acl2-oracle state-state))
      (car (acl2-oracle state-state))))

#-acl2-par
(defun read-acl2-oracle@par (state-state)

; We have included read-acl2-oracle@par in *super-defun-wart-table*, in support
; of ACL2(p).  But in order for ACL2(p) and ACL2 to be logically compatible, a
; defconst should have the same value in #+acl2-par as in #-acl2-par; so
; read-acl2-oracle@par is in *super-defun-wart-table* for #-acl2-par too, not
; just #+acl2-par.

; Because of that, if the function read-acl2-oracle@par were only defined in
; #+acl2-par, then a normal ACL2 user could define read-acl2-oracle@par and
; take advantage of such special treatment, which we can imagine is
; problematic.  Rather than think hard about whether we can get away with that,
; we eliminate such a user option by defining this function in #-acl2-par.

  (declare (xargs :guard (state-p1 state-state))
           (ignore state-state))
  (mv (er hard? 'read-acl2-oracle@par
          "The function symbol ~x0 is reserved but may not be executed."
          'read-acl2-oracle@par)
      nil))

(defun getenv$ (str state)

  ":Doc-Section ACL2::ACL2-built-ins

  read an environment variable~/

  ~c[(Getenv$ str state)], where ~c[str] is a string, reads the value of
  environment variable ~c[str], returning a value of ~c[nil] if none is found
  or if the read fails.  The logical story is that ~c[getenv$] reads its value
  from the ~c[oracle] field of the ACL2 ~ilc[state].  The return value is thus
  a triple of the form ~c[(mv erp val state)], where ~c[erp] will always be
  ~c[nil] in practice, and logically, ~c[val] is the top of the acl2-oracle
  field of the state and the returned state has the updated (popped)
  acl2-oracle.
  ~bv[]
  Example:
  (getenv$ \"PWD\" state) ==> (mv nil \"/u/joe/work\" state)
  ~ev[]
  Also ~pl[setenv$].~/~/"

  (declare (xargs :stobjs state :guard (stringp str)))
  #+acl2-loop-only
  (declare (ignore str))
  #-acl2-loop-only
  (when (live-state-p state)
    (return-from getenv$
                 (value (and (stringp str) (getenv$-raw str)))))
  (read-acl2-oracle state))

(defun setenv$ (str val)

  ":Doc-Section ACL2::ACL2-built-ins

  set an environment variable~/

  ~c[(Setenv$ str val)], where ~c[str] and ~c[val] are strings, sets the
  environment variable ~c[str] to have value ~c[val], for subsequent read by
  ~c[getenv$] (~pl[getenv$]), and returns ~c[nil].  Or, if this operation is
  not implemented for the host Common Lisp, an error will occur.
  ~bv[]
  Example:
  (setenv$ \"FOO\" \"BAR\")
  ~ev[]~/
  It may be surprising that ~c[setenv$] returns ~c[nil]; indeed, it neither
  takes nor returns the ACL2 ~il[state].  The reason is that ~ilc[getenv$]
  takes responsibility for trafficking in ~il[state]; it is defined in the
  logic using the function ~c[read-acl2-oracle], which (again, in the logic)
  does modify state, by popping an entry from its acl2-oracle field.
  ~il[getenv$].~/"

  (declare (xargs :guard (and (stringp str)
                              (stringp val))))
  #+acl2-loop-only
  (declare (ignore str val))
  #-acl2-loop-only
  (when (and (stringp str) (stringp val))
    (or #+cmu
        (and (boundp ext::*environment-list*)
             (let* ((key (intern str :keyword))
                    (pair (cdr (assoc-eq key ext::*environment-list*))))
               (cond (pair (setf (cdr pair) val))
                     (t (push (cons key val) ext::*environment-list*)))))
;     #+sbcl

; The following is the best we could come up with for SBCL, but it
; didn't work.

;     (nconc (posix-environ) (list (format nil "~a=~a" str val)))
        #+allegro
        (setf (sys::getenv str) val)
        #+clisp
        (setf (ext::getenv str) val)
        #+(or gcl allegro lispworks ccl sbcl clisp)
        (let ((fn
               #+gcl       'si::setenv
               #+lispworks 'hcl::setenv
               #+ccl       'ccl::setenv))
          (and (fboundp fn)
               (funcall fn str val)))
        (error "Setenv$ is not available for this host Common Lisp.  ~%~
                If you know a way to provide this functionality for ~%~
                this host Common Lisp, please contact the ACL2 ~%~
                implementors.")))
  nil)

(defun random$ (limit state)

  ":Doc-Section ACL2::ACL2-built-ins

  obtain a random value~/

  ~bv[]
  Example:
  (random$ 10 state) ==> (mv 7 <state>)
  ~ev[]

  ~c[(Random$ limit state)], where ~c[limit] is a positive integer, returns a
  random non-negative integer together with a new ~ilc[state].  Logically, it
  simply returns the first element of a list that is a field of the ACL2
  ~ilc[state], called the ~c[acl2-oracle], together with the new state
  resulting from removing that element from that list.  (Except, if that
  element is not in range as specified above, then 0 is returned.)  However,
  ~c[random$] actually invokes a Common Lisp function to choose the integer
  returned.  Quoting from the Common Lisp HyperSpec(TM),
  ~url[http://www.lispworks.com/documentation/HyperSpec/Front]:
  ``An approximately uniform choice distribution is used...  each of the
  possible results occurs with (approximate) probability 1/limit.''

  Consider enabling rules ~c[natp-random$] and ~c[random$-linear] if you want
  to reason about ~c[random$].~/~/"

  (declare (type (integer 1 *) limit)
           (xargs :stobjs state))
  #-acl2-loop-only
  (when (live-state-p state)
    (return-from random$
                 (mv (random limit) state)))
  (mv-let (erp val state)
          (read-acl2-oracle state)
          (mv (cond ((and (null erp) (natp val) (< val limit))
                     val)
                    (t 0))
              state)))

(defthm natp-random$
  (natp (car (random$ n state)))
  :rule-classes :type-prescription)

(defthm random$-linear
  (and (<= 0 (car (random$ n state)))
       (implies (posp n)
                (< (car (random$ n state)) n)))
  :rule-classes :linear)

(in-theory (disable random$

; We keep the following rules disabled because it seems sad to pay the
; potential performance penalty (as they are hung on car) given how rarely they
; are likely to be used.

                    natp-random$ random$-linear))

; System calls

#-acl2-loop-only
(defvar *last-sys-call-status* 0)

(defun sys-call (command-string args)

  ":Doc-Section ACL2::ACL2-built-ins

  make a system call to the host operating system~/
  ~bv[]
  Example Forms:
  (sys-call \"cp\" '(\"foo.lisp\" \"foo-copied.lisp\"))
  (prog2$ (sys-call \"cp\" '(\"foo.lisp\" \"foo-copied.lisp\"))
          (sys-call-status state))
  ~ev[]
  The first argument of ~c[sys-call] is a command for the host operating
  system, and the second argument is a list of strings that are the arguments
  for that command.  In GCL and perhaps some other lisps, you can put the
  arguments with the command; but this is not the case, for example, in Allegro
  CL running on Linux.

  For a related utility, ~pl[sys-call+].

  The use of ~ilc[prog2$] above is optional, but illustrates a typical sort
  of use when one wishes to get the return status.  ~l[sys-call-status].~/
  ~bv[]
  General Form:
  (sys-call cmd args)
  ~ev[]
  This function logically returns ~c[nil].  However, it makes the indicated
  call to the host operating system, as described above, using a function
  supplied ``under the hood'' by the underlying Lisp system.  On occasions
  where one wishes to obtain the numeric status returned by the host operating
  system (or more precisely, by the Lisp function under the hood that passes
  the system call to the host operating system), one may do so;
  ~pl[sys-call-status].  The status value is the value returned by that Lisp
  function, which may well be the same numeric value returned by the host
  operating system for the underlying system call.

  Note that ~c[sys-call] does not touch the ACL2 ~ilc[state]; however,
  ~ilc[sys-call-status] updates the ~c[acl2-oracle] field of the ~c[state].

  Be careful if you use ~c[sys-call]!  It can be used for example to overwrite
  files, or worse!  We view a use of ~c[sys-call] as a call to the operating
  system that is made outside ACL2.  The following example from Bob Boyer shows
  how to use ~c[sys-call] to execute, in effect, arbitrary Lisp forms.  ACL2
  provides a ``trust tag'' mechanism that requires execution of a ~ilc[defttag]
  form before you can use ~c[sys-call]; ~pl[defttag].  (Note: The setting of
  the raw Lisp variable ~c[*features*] below is just to illustrate that any
  such mischief is possible.  Normally ~c[*features*] is a list with more than
  a few elements.)
  ~bv[]
  % cat foo
  print *0x85d2064=0x838E920
  detach
  q
  % acl2
  ... boilerplate deleted
  ACL2 !>(sys-call \"gdb -p $PPID -w < foo >& /dev/null \" nil)
  NIL
  ACL2 !>:q

  Exiting the ACL2 read-eval-print loop.  To re-enter, execute (LP).
  ACL2>*features*

  (:AKCL-SET-MV)

  ACL2>
  ~ev[]

  Finally, we make a comment about output redirection, which also applies to
  other related features that one may expect of a shell.  ~c[Sys-call] does not
  directly support output redirection.  If you want to run a program, ~c[P],
  and redirect its output, one option is to create a wrapper script, ~c[W]
  to call instead.  Thus ~c[W] might be a shell script containing the line:
  ~bv[]
  P $* >& foo.out
  ~ev[]
  For a different, more direct solution, ~pl[sys-call+]."

  (declare (xargs :guard t))
  #+acl2-loop-only
  (declare (ignore command-string args))
  #-acl2-loop-only
  (let ((rslt (system-call command-string args)))
    (progn (setq *last-sys-call-status* rslt)
           nil))
  #+acl2-loop-only
  nil)

(defun sys-call-status (state)

  ":Doc-Section ACL2::ACL2-built-ins

  exit status from the preceding system call~/

  This function returns two values, ~c[(mv status state)].  The first is the
  status resulting from the most recent invocation of function ~c[sys-call];
  ~pl[sys-call].  The second is the ACL2 ~ilc[state] object, which is also the
  input to this function.~/

  The function ~ilc[sys-call] makes a system call to the host operating system
  using a function supplied ``under the hood'' by the underlying Lisp system.
  The status value is the value returned by that Lisp function, which may well
  be the numeric value returned by the host operating system for the underlying
  system call.  For more information, ~pl[sys-call].~/"

  (declare (xargs :stobjs state))
  #-acl2-loop-only
  (when (live-state-p state)
    (return-from sys-call-status
                 (mv *last-sys-call-status* state)))
  (mv-let (erp val state)
          (read-acl2-oracle state)
          (declare (ignore erp))
          (mv val state)))

#-acl2-loop-only
(defun read-file-by-lines (file &optional delete-after-reading)
  (let ((acc nil)
        (eof '(nil))
        missing-newline-p)
    (with-open-file
     (s file :direction :input)
     (loop (multiple-value-bind (line temp)
               (read-line s nil eof)
             (cond ((eq line eof)
                    (return acc))
                   (t
                    (setq missing-newline-p temp)
                    (setq acc
                          (if acc
                              (concatenate 'string acc (string #\Newline) line)
                            line)))))))
    (when delete-after-reading
      (delete-file file))
    (if missing-newline-p
        acc
      (concatenate 'string acc (string #\Newline)))))

#-acl2-loop-only
(defun system-call+ (string arguments)

; Warning: Keep this in sync with system-call.

  (let* (exit-code ; assigned below
         #+(or gcl clisp)
         (tmp-file (format nil
                           "~a/tmp~s"
                           (or (f-get-global 'tmp-dir *the-live-state*)
                               "/tmp")
                           (getpid$)))
         no-error
         (output-string
          (our-ignore-errors
           (prog1
               #+gcl ; does wildcard expansion
             (progn (setq exit-code
                          (si::system
                           (let ((result string))
                             (dolist
                               (x arguments)
                               (setq result (concatenate 'string result " " x)))
                             (concatenate 'string result " > " tmp-file))))
                    (read-file-by-lines tmp-file t))
             #+lispworks ; does wildcard expansion (see comment below)
             (with-output-to-string
               (s)
               (setq exit-code
                     (system::call-system-showing-output

; It was tempting to use (cons string arguments).  This would cause the given
; command, string, to be applied to the given arguments, without involving the
; shell.  But then a command such as "ls" would not work; one would have to
; provide a string such as "/bin/ls".  So instead of using a list here, we use
; a string, which according to the LispWorks manual will invoke the shell,
; which will find commands (presumably including built-ins and also using the
; user's path).

                      (let ((result string))
                        (dolist
                          (x arguments)
                          (setq result (concatenate 'string result " " x)))
                        result)
                      :output-stream s
                      :prefix ""
                      :show-cmd nil
                      :kill-process-on-abort t))
               #+windows ; process is returned above, not exit code
               (setq exit-code nil))
             #+allegro ; does wildcard expansion
             (multiple-value-bind
                 (stdout-lines stderr-lines exit-status)
                 (excl.osi::command-output
                  (let ((result string))
                    (dolist
                      (x arguments)
                      (setq result (concatenate 'string result " " x)))
                    result))
               (declare (ignore stderr-lines))
               (setq exit-code exit-status)
               (let ((acc nil))
                 (loop for line in stdout-lines
                       do
                       (setq acc
                             (if acc
                                 (concatenate 'string
                                              acc
                                              (string #\Newline)
                                              line)
                               line)))
                 acc))
             #+cmu
             (with-output-to-string
               (s)
               (setq exit-code
                     (let (temp)
                       (if (ignore-errors
                             (progn
                               (setq temp
                                     (ext:process-exit-code
                                      (common-lisp-user::run-program
                                       string arguments
                                       :output s)))
                               1))
                           temp
                         1))))
             #+sbcl
             (with-output-to-string
               (s)
               (setq exit-code
                     (let (temp)
                       (if (ignore-errors
                             (progn
                               (setq temp
                                     (sb-ext:process-exit-code
                                      (sb-ext:run-program string arguments
                                                          :output s
                                                          :search t)))
                               1))
                           temp
                         1))))
             #+clisp
             (progn (setq exit-code
                          (or (ext:run-program string
                                               :arguments arguments
                                               :output tmp-file)
                              0))
                    (read-file-by-lines tmp-file t))
             #+ccl
             (with-output-to-string
               (s)
               (setq exit-code
                     (let* ((proc
                             (ccl::run-program string arguments
                                               :output s
                                               :wait t))
                            (status (multiple-value-list
                                     (ccl::external-process-status proc))))
                       (if (not (and (consp status)
                                     (eq (car status) :EXITED)
                                     (consp (cdr status))
                                     (integerp (cadr status))))
                           1 ; just some non-zero exit code here
                         (cadr status)))))
             #-(or gcl lispworks allegro cmu sbcl clisp ccl)
             (declare (ignore string arguments))
             #-(or gcl lispworks allegro cmu sbcl clisp ccl)
             (error "SYSTEM-CALL is not yet defined in this Lisp.")
             (setq no-error t)))))
    (values (cond ((integerp exit-code)
                   exit-code)
                  ((null exit-code)
                   (if no-error 0 1))
                  (t (format t
                             "WARNING: System-call produced non-integer, ~
                              non-nil exit code:~%~a~%"
                             exit-code)
                     0))
            (if (stringp output-string)
                output-string
              ""))))

(encapsulate
 ()

; Before Version_2.9.3, len-update-nth had the form of the local lemma below.
; It turns out that an easy way to prove the improved version below,
; contributed by Jared Davis, is to prove the old version first as a lemma:

 (local
  (defthm len-update-nth-lemma
    (implies (< (nfix n) (len x))
             (equal (len (update-nth n val x))
                    (len x)))))

 (defthm len-update-nth
   (equal (len (update-nth n val x))
          (max (1+ (nfix n))
               (len x)))))

(defthm update-acl2-oracle-preserves-state-p1
  (implies (and (state-p1 state)
                (true-listp x))
           (state-p1 (update-acl2-oracle x state)))
  :hints (("Goal" :in-theory (enable state-p1))))

(in-theory (disable update-acl2-oracle))

(defun sys-call+ (command-string args state)

  ":Doc-Section ACL2::ACL2-built-ins

  make a system call to the host OS, returning status and output~/
  ~bv[]
  Example Form:
  ; The following returns (mv nil s state), where s is the standard output
  ; from the command: ls -l ./
  (sys-call+ \"ls\" '(\"-l\" \"./\") state)

  General Form:
  (sys-call+ cmd args state)
  ~ev[]
  where ~c[cmd] is a command to the host operating system and ~c[args] is a
  list of strings.  Also ~pl[sys-call]; but there are two differences between
  ~ilc[sys-call] and ~c[sys-call+].  First, the latter takes an extra argument,
  ~c[state].  Second, while ~c[sys-call] returns ~c[nil], ~c[sys-call+] returns
  three values: a so-called error triple (~pl[error-triples]),
  ~c[(mv erp val state)].  While execution returns values as described just
  below, further below we explain the logical return values.  In the following,
  please keep in mind that the exact behavior depends on the platform; the
  description is only a guide.  For example, on some platforms ~c[erp] might
  always be ~c[nil], even if in the error case, and ~c[val] might or might not
  include error output.  (For details, look at the ACL2 source code for
  function ~c[system-call+], whose output is converted by replacing an ~c[erp]
  of ~c[nil] by 0.)
  ~bq[]

  ~c[Erp] is either ~c[nil] or a non-zero integer.  Normally, ~c[nil] indicates
  that the command ran without error, and otherwise ~c[erp] is the exit
  status.

  ~c[Val] is a string, typically the output generated by the call of ~c[cmd].

  ~c[State] is an ACL2 ~il[state].~eq[]

  While the description above pertains to the values returned by executing
  ~c[sys-call+], the logical values are as follows.  For a discussion of the
  ~c[acl2-oracle] field of an ACL2 state, ~pl[state].
  ~bq[]

  ~c[Erp] is the first element of the ~c[acl2-oracle] of the input state if
  that element is a nonzero integer, and otherwise is ~c[nil].

  ~c[Val] is the second element of the ~c[acl2-oracle] of the input state if it
  is a string, else the empty string, ~c[\"\"].

  ~c[State] is the result of popping the ~c[acl2-oracle] field twice from the
  input state.~eq[]

  Note that unlike ~ilc[sys-call], a call of ~ilc[sys-call+] has no effect on
  subsequent calls of ~ilc[sys-call-status].

  As is the case for ~c[sys-call], a trust tag is required to call
  ~c[sys-call+].  For discussion of this and more, ~pl[sys-call].~/~/"

  (declare (xargs :stobjs state))
  #+acl2-loop-only
  (declare (ignore command-string args))
  #+acl2-loop-only
  (mv-let (erp1 erp state)
          (read-acl2-oracle state)
          (declare (ignore erp1))
          (mv-let (erp2 val state)
                  (read-acl2-oracle state)
                  (declare (ignore erp2))
                  (mv (and (integerp erp)
                           (not (eql 0 erp))
                           erp)
                      (if (stringp val) val "")
                      state)))
  #-acl2-loop-only
  (multiple-value-bind
      (status rslt)
      (system-call+ command-string args)
    (mv (if (eql status 0)
            nil
          status)
        rslt
        state)))

; End of system calls

; Time:  idate, run-time, and timers.

; Time is a very nonapplicative thing.  What is it doing in an
; applicative programming language and verification system?  Formally,
; read time and cpu time are simply components of state which are
; lists of numbers about which we say nothing, not even that they are
; ascending.  In actual practice, the numbers that we provide
; correspond to the universal time and the cpu time at the moment that
; read-idate and read-run-time are called.

; We provide a mechanism for the user to report real time and to keep
; track of and report cpu time, but we do not let the user do anything
; with times except print them, so as to keep computations entirely
; deterministic for read-book.  We prohibit the user from accessing
; the internal timing subroutines and state variables by putting them
; on untouchables.  (If we ever implement a file system, then of
; course the nondeterminism of read-book will be shattered because a
; user could check what sort of io was being generated.)

; The user can print the current date in a format we call the idate by
; calling (print-current-idate channel state).

; To keep track of the cpu time used in a way we find congenial, we
; implement a facility called timers.  A ``timer'' is a symbolp with
; an associated value in the timer-alistp called the 'timer-alist,
; stored in the global table of state.  Typically the value of a timer
; is a list of rationals, treated as a stack.  One may have many such
; timers.  As of this writing, the ACL2 system itself has three:
; 'prove-time, 'print-time, and 'other-time, and we use a singleton stack
; 'total-time, as a temporary to sum the times on the other stacks.

; To clean the slate, i.e. to get ready to start a new set of timings,
; one could invoke (set-timer 'prove-time '(0) state), (set-timer
; 'print-time '(0) state), etc., and finally (main-timer state).  The
; set-timer function set the values of the timers each to a stack
; containing a single 0.  The call of main-timer can be thought of as
; starting the clock running.  What it actually does is store the
; current cpu-time-used figure in a secret place to be used later.
; Now, after some computing one could invoke (increment-timer
; 'prove-time state), which would attribute all of the cpu time used
; since cleaning the slate to the top-most element on the 'prove-time
; timer.  That is, increment-timer takes the time used since the
; ``clock was started'' and adds it to the number on the top of the
; given timer stack.  Increment-timer also restarts the clock.  One
; could later execute (increment-timer 'print-time state), which would
; attribute all of the cpu time used since the previous call of
; increment-timer to 'print-time.  And so forth.  At an appropriate
; time, one could then call (print-timer 'print-time channel state) and
; (print-timer 'prove-time time), which would print the top-most
; values of the timers.  Finally, one could either pop the timer
; stacks, exposing accumulated time in that category for some superior
; computation, or pop the stacks but add the popped time into the
; newly exposed accumulated time (charging the superior with the time
; used by the inferior), or simply reset the stacks as by set-timer.

; Time is maintained as a rational.  We print time in seconds, accurate
; to two decimal places.  We just print the number, without leading or
; trailing spaces or even the word ``seconds''.

(local
 (defthm rational-listp-cdr
   (implies (rational-listp x)
            (rational-listp (cdr x)))))

(defthm read-run-time-preserves-state-p1
  (implies (state-p1 state)
           (state-p1 (nth 1 (read-run-time state))))
  :rule-classes ((:forward-chaining
                  :trigger-terms
                  ((nth 1 (read-run-time state)))))
  :hints (("Goal" :in-theory (enable nth))))

(defthm read-acl2-oracle-preserves-state-p1
  (implies (state-p1 state)
           (state-p1 (nth 2 (read-acl2-oracle state))))
  :rule-classes ((:forward-chaining
                  :trigger-terms
                  ((nth 2 (read-acl2-oracle state)))))
  :hints (("Goal" :in-theory (enable nth))))

(in-theory (disable read-acl2-oracle))

(local
 (defthm rational-listp-implies-rationalp-car
   (implies (and (rational-listp x)
                 x)
            (rationalp (car x)))))

(defthm nth-0-read-run-time-type-prescription
  (implies (state-p1 state)
           (rationalp (nth 0 (read-run-time state))))
  :hints (("Goal" :in-theory (enable nth)))
  :rule-classes ((:type-prescription
                  :typed-term (nth 0 (read-run-time state)))))

(in-theory (disable read-run-time))

; Here we prefer not to develop a base of rules about mv-nth.  So, we prove
; that it is the same as nth, and get on with the proofs.

(local
 (defthm mv-nth-is-nth
   (equal (mv-nth n x)
          (nth n x))
   :hints (("Goal" :in-theory (enable nth)))))

(defun main-timer (state)
  (declare (xargs :guard (state-p state)))
  (mv-let (current-time state)
    (read-run-time state)
    (let ((old-value (cond ((and (f-boundp-global 'main-timer state)
                                 (rationalp (f-get-global 'main-timer state)))
                            (f-get-global 'main-timer state))
                           (t 0))))
      (let ((state (f-put-global 'main-timer current-time state)))
        (mv (- current-time old-value) state)))))

; Put-assoc

(defun put-assoc-eq-exec (name val alist)
  (declare (xargs :guard (if (symbolp name)
                             (alistp alist)
                           (symbol-alistp alist))))

; The function trans-eval exploits the fact that the order of the keys
; is unchanged.

  (cond ((endp alist) (list (cons name val)))
        ((eq name (caar alist)) (cons (cons name val) (cdr alist)))
        (t (cons (car alist) (put-assoc-eq-exec name val (cdr alist))))))

(defun put-assoc-eql-exec (name val alist)
  (declare (xargs :guard (if (eqlablep name)
                             (alistp alist)
                           (eqlable-alistp alist))))

; The function trans-eval exploits the fact that the order of the keys
; is unchanged.

  (cond ((endp alist) (list (cons name val)))
        ((eql name (caar alist)) (cons (cons name val) (cdr alist)))
        (t (cons (car alist) (put-assoc-eql-exec name val (cdr alist))))))

(defun put-assoc-equal (name val alist)
  (declare (xargs :guard (alistp alist)))
  (cond ((endp alist) (list (cons name val)))
        ((equal name (caar alist)) (cons (cons name val) (cdr alist)))
        (t (cons (car alist) (put-assoc-equal name val (cdr alist))))))

(defmacro put-assoc-eq (name val alist)
  `(put-assoc ,name ,val ,alist :test 'eq))

; Added for backward compatibility (add-to-set-eql was present through
; Version_4.2):
(defmacro put-assoc-eql (name val alist)
  `(put-assoc ,name ,val ,alist :test 'eql))

(defthm put-assoc-eq-exec-is-put-assoc-equal
  (equal (put-assoc-eq-exec name val alist)
         (put-assoc-equal name val alist)))

(defthm put-assoc-eql-exec-is-put-assoc-equal
  (equal (put-assoc-eql-exec name val alist)
         (put-assoc-equal name val alist)))

(defmacro put-assoc (name val alist &key (test ''eql))

  ":Doc-Section ACL2::ACL2-built-ins

  modify an association list by associating a value with a key~/
  ~bv[]
  General Forms:
  (put-assoc name val alist)
  (put-assoc name val alist :test 'eql)   ; same as above (eql as equality test)
  (put-assoc name val alist :test 'eq)    ; same, but eq is equality test
  (put-assoc name val alist :test 'equal) ; same, but equal is equality test
  ~ev[]

  ~c[(Put-assoc name val alist)] returns an alist that is the same as the list
  ~c[alist], except that the first pair in ~c[alist] with a ~ilc[car] of
  ~c[name] is replaced by ~c[(cons name val)], if there is one.  If there is no
  such pair, then ~c[(cons name val)] is added at the end.  Note that the order
  of the keys occurring in ~c[alist] is unchanged (though a new key may be
  added).~/

  The ~il[guard] for a call of ~c[put-assoc] depends on the test.  In all
  cases, the last argument must satisfy ~ilc[alistp].  If the test is
  ~ilc[eql], then either the first argument must be suitable for ~ilc[eql]
  (~pl[eqlablep]) or the last argument must satisfy ~ilc[eqlable-alistp].  If
  the test is ~ilc[eq], then either the first argument must be a symbol or the
  last argument must satisfy ~ilc[symbol-alistp].

  ~l[equality-variants] for a discussion of the relation between ~c[put-assoc]
  and its variants:
  ~bq[]
  ~c[(put-assoc-eq name val alist)] is equivalent to
  ~c[(put-assoc name val alist :test 'eq)];

  ~c[(put-assoc-equal name val alist)] is equivalent to
  ~c[(put-assoc name val alist :test 'equal)].
  ~eq[]
  In particular, reasoning about any of these primitives reduces to reasoning
  about the function ~c[put-assoc-equal].~/"

  (declare (xargs :guard (or (equal test ''eq)
                             (equal test ''eql)
                             (equal test ''equal))))
  (cond
   ((equal test ''eq)
    `(let-mbe ((name ,name) (val ,val) (alist ,alist))
              :logic (put-assoc-equal name val alist)
              :exec  (put-assoc-eq-exec name val alist)))
   ((equal test ''eql)
    `(let-mbe ((name ,name) (val ,val) (alist ,alist))
              :logic (put-assoc-equal name val alist)
              :exec  (put-assoc-eql-exec name val alist)))
   (t ; (equal test 'equal)
    `(put-assoc-equal ,name ,val ,alist))))

(local
 (defthm timer-alist-bound-in-state-p1
   (implies (state-p1 s)
            (boundp-global1 'timer-alist s))
   :hints (("Goal" :in-theory (enable state-p1)))))

(local (in-theory (disable boundp-global1)))

(local
 (defthm timer-alist-bound-in-state-p
   (implies (state-p s)
            (boundp-global1 'timer-alist s))))

(defun set-timer (name val state)
  (declare (xargs :guard (and (symbolp name)
                              (rational-listp val)
                              (state-p state))))
  (f-put-global
   'timer-alist
   (put-assoc-eq name val (f-get-global 'timer-alist state))
   state))

(defun get-timer (name state)
  (declare (xargs :guard (and (symbolp name)
                              (state-p state))))
  (cdr (assoc-eq name (f-get-global 'timer-alist state))))

(local
 (defthm timer-alistp-implies-rational-listp-assoc-eq
   (implies (and (symbolp name)
                 (timer-alistp alist))
            (rational-listp (cdr (assoc-eq name alist))))))

(defun push-timer (name val state)
  (declare (xargs :guard (and (symbolp name)
                              (rationalp val)
                              (state-p state))))
  (set-timer name (cons val (get-timer name state)) state))

; The following four rules were not necessary until we added complex numbers.
; However, the first one is now crucial for acceptance of pop-timer.

(defthm rationalp-+
  (implies (and (rationalp x)
                (rationalp y))
           (rationalp (+ x y))))

; ;??? The rewrite rule above is troubling.  I have spent some time thinking
; about how to eliminate it.  Here is an essay on the subject.
;
; Rationalp-+, above, is needed in the guard proof for pop-timer, below.  Why?
;
; Why do we need to make this a :rewrite rule?  Why can't type-set establish
; (rationalp (+ x y)) whenever this rule would have applied?  The reason,
; obviously, is that the hypotheses can't be established by type-set and must be
; established by rewrite.  Since type-set doesn't call rewrite, we have to
; program enough of type-set in the rewriter to get the rewriter to act like
; type-set.  That is what this lemma does (and that is why it is offensive to
; us).
;
; Why can't type-set establish the (rationalp x) and (rationalp y) hypotheses
; above?  Here is the :rewrite rule we need:
;
; (defthm rational-listp-implies-rationalp-car
;  (implies (and (rational-listp x)
;                x)
;           (rationalp (car x))))
;
; Note that this lemma is "type-like" in the conclusion but not (very) type-like
; in the hypotheses.  I mean, (rational-listp x) is not a "type recognizer"
; (except in a good type system, and we haven't got one of those!).  The presence
; of this lemma in axioms.lisp should have alerted us to the possible need
; later for a lemma duplicating type-like reasoning in the rewriter.
;
; Here is a simple example of a theorem we can prove using rationalp-+ that we
; cannot prove (directly) without it.  I introduce an undefined function so that
; I can state the theorem in a way that does not allow a car-cdr-elim.
;
;  (defstub foo (x) t)
;
;  (thm (implies (and (rational-listp (foo x)) (foo x))
;                (rationalp (+ 1 (car (foo x)))))
; ;    :hints (("Goal" :in-theory (disable rationalp-+)))
;      )
;
; If rationalp-+ is enabled, this proof succeeds, because rewrite does our type
; reasoning for us (via rationalp-+) and uses rational-listp-implies-
; rationalp-car to get the hypothesis that (car (foo x)) is rational.  If
; rationalp-+ is disabled, the proof fails because type-set doesn't know that
; (car (foo x)) is rational.
;
; In the actual application (in pop-timer below) no rational-listp hypothesis
; is present.  Here is the actual goal
;
; (IMPLIES
;      (AND (CONSP (CDDR (ASSOC-EQ NAME
;                                  (CDR (ASSOC 'TIMER-ALIST (NTH 2 STATE))))))
;           (CONSP (CDR (ASSOC-EQ NAME
;                                 (CDR (ASSOC 'TIMER-ALIST (NTH 2 STATE))))))
;           (STATE-P1 STATE)
;           (SYMBOLP NAME)
;           FLG)
;      (RATIONALP (+ (CADR (ASSOC-EQ NAME
;                                    (CDR (ASSOC 'TIMER-ALIST (NTH 2 STATE)))))
;                    (CADDR (ASSOC-EQ NAME
;                                     (CDR (ASSOC 'TIMER-ALIST
;                                                 (NTH 2 STATE))))))))
;
; If we insist on deleting rationalp-+ as a :rewrite rule we are obliged to
; add certain other rules as either :type-prescriptions or :forward-chaining
; rules.  Going the :type-prescription route we could add
;
; (defthm rational-listp-implies-rationalp-car
;   (implies (and (rational-listp x) x)
;            (rationalp (car x)))
;   :rule-classes :type-prescription)
;
; to get the first inkling of how to establish that the two arguments above
; are rational.  But we must be able to establish the hypotheses of that rule
; within type-set, so we need
;
; (defthm timer-alistp-implies-rational-listp-assoc-eq
;    (implies (and (symbolp name)
;                  (timer-alistp alist))
;             (rational-listp (cdr (assoc-eq name alist))))
;   :rule-classes :type-prescription)
;
; (defthm rational-listp-cdr
;    (implies (rational-listp x)
;             (rational-listp (cdr x)))
;    :rule-classes :type-prescription)
;
; All three of these rules are currently :rewrite rules, so this would just shift
; rules from the rewriter to type-set.  I don't know whether this is a good idea.
; But the methodology is fairly clear, namely: make sure that all concepts used
; in :type-prescription rules are specified with :type-prescription (and/or
; :forward-chaining) rules, not :rewrite rules.

(defthm rationalp-*
  (implies (and (rationalp x)
                (rationalp y))
           (rationalp (* x y))))

(defthm rationalp-unary--
  (implies (rationalp x)
           (rationalp (- x))))

(defthm rationalp-unary-/
  (implies (rationalp x)
           (rationalp (/ x))))

; Here we add realp versions of the four rules above, as suggested by Jun
; Sawada.  As he points out, these rules can be necessary in order to get
; proofs about real/rationalp that succeed in ACL2 also to succeed in ACL2(r).

#+:non-standard-analysis
(defthm realp-+
  (implies (and (realp x)
                (realp y))
           (realp (+ x y))))

#+:non-standard-analysis
(defthm realp-*
  (implies (and (realp x)
                (realp y))
           (realp (* x y))))

#+:non-standard-analysis
(defthm realp-unary--
  (implies (realp x)
           (realp (- x))))

#+:non-standard-analysis
(defthm realp-unary-/
  (implies (realp x)
           (realp (/ x))))

; We seem to need the following in V1.8 because we have eliminated bctra.

(defthm rationalp-implies-acl2-numberp
  (implies (rationalp x) (acl2-numberp x)))

(defun pop-timer (name flg state)

; If flg is nil we discard the popped value.  If flg is t we
; add the popped value into the exposed value.

  (declare (xargs :guard (and (symbolp name)
                              (state-p state)
                              (consp (get-timer name state))
                              (or (null flg)
                                  (consp (cdr (get-timer name state)))))))

  (let ((timer (get-timer name state)))
    (set-timer name
               (if flg
                   (cons (+ (car timer) (cadr timer)) (cddr timer))
                   (cdr timer))
               state)))

(defun add-timers (name1 name2 state)
  (declare (xargs :guard (and (symbolp name1)
                              (symbolp name2)
                              (state-p state)
                              (consp (get-timer name1 state))
                              (consp (get-timer name2 state)))))
  (let ((timer1 (get-timer name1 state))
        (timer2 (get-timer name2 state)))
    (set-timer name1
               (cons (+ (car timer1) (car timer2)) (cdr timer1))
               state)))

; Here are lemmas for opening up nth on explicitly given conses.

(defthm nth-0-cons
  (equal (nth 0 (cons a l))
         a)
  :hints (("Goal" :in-theory (enable nth))))

(local
 (defthm plus-minus-1-1
   (implies (acl2-numberp x)
            (equal (+ -1 1 x) x))))

(defthm nth-add1
  (implies (and (integerp n)
                (>= n 0))
           (equal (nth (+ 1 n) (cons a l))
                  (nth n l)))
  :hints (("Goal" :expand (nth (+ 1 n) (cons a l)))))

(defthm main-timer-type-prescription
  (implies (state-p1 state)
           (and (consp (main-timer state))
                (true-listp (main-timer state))))
  :rule-classes :type-prescription)

(defthm ordered-symbol-alistp-add-pair-forward
  (implies (and (symbolp key)
                (ordered-symbol-alistp l))
           (ordered-symbol-alistp (add-pair key value l)))
  :rule-classes
  ((:forward-chaining
    :trigger-terms
    ((add-pair key value l)))))

(defthm assoc-add-pair
  (implies (and (symbolp sym2)
                (ordered-symbol-alistp alist))
           (equal (assoc sym1 (add-pair sym2 val alist))
                  (if (equal sym1 sym2)
                      (cons sym1 val)
                    (assoc sym1 alist)))))

(defthm add-pair-preserves-all-boundp
  (implies (and (eqlable-alistp alist1)
                (ordered-symbol-alistp alist2)
                (all-boundp alist1 alist2)
                (symbolp sym))
           (all-boundp alist1 (add-pair sym val alist2))))

(defthm state-p1-update-main-timer
  (implies (state-p1 state)
           (state-p1 (update-nth 2
                                 (add-pair 'main-timer val (nth 2 state))
                                 state)))
  :hints (("Goal" :in-theory (set-difference-theories
                              (enable state-p1 global-table)
                              '(true-listp
                                ordered-symbol-alistp
                                assoc
                                sgetprop
                                integer-listp
                                rational-listp
                                true-list-listp
                                open-channels-p
                                all-boundp
                                plist-worldp
                                timer-alistp
                                known-package-alistp
                                32-bit-integer-listp
                                file-clock-p
                                readable-files-p
                                written-files-p
                                read-files-p
                                writeable-files-p))))
  :rule-classes ((:forward-chaining
                  :trigger-terms
                  ((update-nth 2
                               (add-pair 'main-timer val (nth 2 state))
                               state)))))

(defun increment-timer (name state)

; A note about the integration of #+acl2-par code:

; Why not use defun@par to define increment-timer@par, using
; serial-first-form-parallel-second-form?  If we do that, then we have to wait
; until after defun@par is defined, near the end of this file.  But at that
; point, guard verification fails.  However, guard verification succeeds here,
; not only during the normal boot-strap when proofs are skipped, but also when
; we do proofs (as with "make proofs").  After a few minutes of investigation,
; we have decided to leave well enough alone.

  (declare (xargs :guard (and (symbolp name)
                              (state-p state)
                              (consp (get-timer name state)))))
  (let ((timer (get-timer name state)))
    (mv-let (epsilon state)
            (main-timer state)
            (set-timer name (cons (+ (car timer) epsilon)
                                  (cdr timer))
                       state))))

(skip-proofs
(defun print-rational-as-decimal (x channel state)
  (declare (xargs :guard (and (rationalp x)
                              (state-p state)
                              (equal (print-base) 10)
                              (open-output-channel-p channel :character state))))
  (let ((x00 (round (* 100 (abs x)) 1)))
    (pprogn
     (cond ((< x 0) (princ$ "-" channel state))
           (t state))
     (cond ((> x00 99)
            (princ$ (floor (/ x00 100) 1) channel state))
           (t (princ$ "0" channel state)))
     (princ$ "." channel state)
     (let ((r (rem x00 100)))
       (cond ((< r 10)
              (pprogn (princ$ "0" channel state)
                      (princ$ r channel state)))
             (t (princ$ r channel state)))))))
)

(skip-proofs
(defun print-timer (name channel state)
  (declare (xargs :guard (and (symbolp name)
                              (state-p state)
                              (open-output-channel-p channel :character state)
                      (consp (get-timer name state)))))
  (print-rational-as-decimal (car (get-timer name state)) channel state))
)

(defun known-package-alist (state)

; We avoid using global-val below because this function is called during
; retract-world1 under set-w under enter-boot-strap-mode, before
; primordial-world-globals is called.

  (declare (xargs :guard (state-p state)))
  (getprop 'known-package-alist
           'global-value
           nil
           'current-acl2-world
           (w state)))

;  Prin1

(skip-proofs
(defun prin1$ (x channel state)

;  prin1$ differs from prin1 in several ways.  The second arg is state, not
;  a stream.  prin1$ returns the modified state, not x.

  (declare (xargs :guard (and (or (acl2-numberp x)
                                  (characterp x)
                                  (stringp x)
                                  (symbolp x))
                              (state-p state)
                              (open-output-channel-p channel :character state))))
  #-acl2-loop-only
  (cond ((live-state-p state)
         (cond ((and *wormholep*
                     (not (eq channel *standard-co*)))
                (wormhole-er 'prin1$ (list x channel))))
         (let ((stream (get-output-stream-from-channel channel)))
           (declare (special acl2_global_acl2::current-package))
           (with-print-controls

; We use :defaults here, binding only *print-escape* (to put |..| on symbols
; where necessary), to ensure that raw Lisp agrees with the logical definition.
; Actually we need not bind *print-escape* explicitly here, since the default
; for print-escape, taken from *print-control-defaults* (from
; *initial-global-table*), is t.  But we bind it anyhow in case we ever change
; its value in *initial-global-table*.

            :defaults
            ((*print-escape* t)
             (*print-base* (f-get-global 'print-base state))
             (*print-radix* (f-get-global 'print-radix state))
             (*print-case* (f-get-global 'print-case state)))
            (cond ((acl2-numberp x)
                   (princ #+allegro
; See the comment about a similar case in princ$.
                          (cond
                           ((and (acl2-numberp x)
                                 (> *print-base* 10))
                            (coerce (explode-atom+ x
                                                   *print-base*
                                                   *print-radix*)
                                    'string))
                           (t x))
                          #-allegro
                          x
                          stream))
                  ((characterp x)
                   (princ "#\\" stream)
                   (princ
                    (case x

; Keep the following in sync with the function acl2-read-character-string.

                      (#\Newline "Newline")
                      (#\Space   "Space")
                      (#\Page    "Page")
                      (#\Tab     "Tab")
                      (#\Rubout  "Rubout")
                      (otherwise x))
                    stream))
                  ((stringp x)
                   (princ #\" stream)
                   (let ((n (length (the string x)))) (declare (type fixnum n))
                        (block check
                               (do ((i 0 (1+ i)))
                                   ((= i n))
                                   (declare (type fixnum i))
                                   (let ((ch (char-code
                                              (aref (the string x) i))))
                                     (declare (type fixnum ch))
                                     (cond ((or (= ch *char-code-backslash*)
                                                (= ch
                                                   *char-code-double-gritch*))
                                            (prin1-with-slashes
                                             x #\" channel state)
                                            (return-from check nil)))))
                               (princ x stream)))
                   (princ #\" stream))
                  ((symbolp x)
                   (cond ((keywordp x) (princ #\: stream))
                         ((or (equal (symbol-package-name x)
                                     (f-get-global 'current-package state))
                              (member-eq
                               x
                               (package-entry-imports
                                (find-package-entry
                                 (f-get-global 'current-package state)
                                 (known-package-alist state)))))
                          state)
                         (t (let ((p (symbol-package-name x)))
                              (cond ((needs-slashes p state)
                                     (princ "|" stream)
                                     (prin1-with-slashes p #\| channel state)
                                     (princ "|" stream))
                                    ((eq *print-case* :downcase)
                                     (princ (string-downcase p) stream))
                                    (t (princ p stream)))
                              (princ "::" stream))))
                   (cond ((needs-slashes (symbol-name x) state)
                          (princ #\| stream)
                          (prin1-with-slashes (symbol-name x) #\| channel state)
                          (princ #\| stream))
                         (t (princ x stream))))
                  (t (error "Prin1$ called on an illegal object ~a~%~%." x)))
            (return-from prin1$ state)))))
  (cond ((acl2-numberp x) (princ$ x channel state))
        ((characterp x)
         (pprogn
          (princ$ "#\\" channel state)
          (princ$ (case x
                    (#\Newline "Newline")
                    (#\Space   "Space")
                    (#\Page    "Page")
                    (#\Tab     "Tab")
                    (#\Rubout  "Rubout")
                    (otherwise x))
                  channel state)))
        ((stringp x)
         (let ((l (coerce x 'list)))
           (pprogn (princ$ #\" channel state)
                   (cond ((or (member #\\ l) (member #\" l))
                          (prin1-with-slashes x #\" channel state))
                         (t (princ$ x channel state)))
                   (princ$ #\" channel state))))
        (t
         (pprogn
          (cond ((keywordp x) (princ$ #\: channel state))
                ((or (equal (symbol-package-name x)
                            (f-get-global 'current-package state))
                     (member-eq
                      x
                      (package-entry-imports
                       (find-package-entry
                        (f-get-global 'current-package state)
                        (known-package-alist state)))))
                 state)
                (t (let ((p (symbol-package-name x)))
                     (pprogn
                      (cond ((needs-slashes p state)
                             (pprogn (princ$ #\| channel state)
                                     (prin1-with-slashes p #\| channel state)
                                     (princ$ #\| channel state)))
                            ((eq (print-case) :downcase)
                             (princ$ (string-downcase p) channel state))
                            (t (princ$ p channel state)))
                      (princ$ "::" channel state)))))
          (cond ((needs-slashes (symbol-name x) state)
                 (pprogn
                  (princ$ #\| channel state)
                  (prin1-with-slashes (symbol-name x) #\| channel state)
                  (princ$ #\| channel state)))
                (t (princ$ x channel state)))))))
)


;                             UNTOUCHABLES

; The ``untouchables'' mechanism of ACL2, we believe, gives ACL2 a
; modest form of write-protection which can be used to preserve
; integrity in the presence of arbitrary ACL2 user acts.  If a symbol
; s is a member of the global-val of 'untouchable-fns or
; 'untouchable-vars in a world, then translate will cause an error if
; one attempts to define a function or macro (or to directly execute
; code) that would either (for 'untouchable-vars) set or make unbound
; a global variable with name s or (for 'untouchable-fns) call a
; function or macro named s.  The general idea is to have a ``sacred''
; variable, e.g.  current-acl2-world, or function, e.g., set-w, which
; the user cannot directly use it has been placed on untouchables.
; Instead, to alter that variable or use that function, the user is
; required to invoke other functions that were defined before the
; symbol was made untouchable.  Of course, the implementor must take
; great care to make sure that all methods of access to the resource
; are identified and that all but the authorized ones are on
; untouchables.  We do not attempt to enforce any sort of read
; protection for state globals; untouchables is entirely oriented
; towards write protection.  Read protection could not be perfectly
; enforced in any case since by calling translate one could at least
; find out what was on untouchables.

(local (in-theory (enable boundp-global1)))

(defun current-package (state)
  (declare (xargs :guard (state-p state)))

  ":Doc-Section Miscellaneous

  the package used for reading and printing~/

  ~c[Current-package] is an ~ilc[ld] special (~pl[ld]).  The accessor is
  ~c[(current-package state)] and the updater is
  ~c[(set-current-package val state)], or more conventionally,
  ~c[(in-package val)].  The value of ~c[current-package] is actually
  the string that names the package.  (Common Lisp's ``package''
  objects do not exist in ACL2.)  The current package must be known to
  ACL2, i.e., it must be one of the initial packages or a package
  defined with ~ilc[defpkg] by the user.~/

  When printing symbols, the package prefix is displayed if it is not
  the ~c[current-package] and may be optionally displayed otherwise.
  Thus, if ~c[current-package] is ~c[\"ACL2\"] then the symbol ~c['ACL2::SYMB] may
  be printed as ~c[SYMB] or ~c[ACL2::SYMB], while ~c['MY-PKG::SYMB] must be
  printed as ~c[MY-PKG::SYMB].  But if ~c[current-package] is ~c[\"MY-PKG\"] then
  the former symbol must be printed as ~c[ACL2::SYMB] while the latter may
  be printed as ~c[SYMB].

  In Common Lisp, ~c[current-package] also affects how objects are read
  from character streams.  Roughly speaking, read and print are
  inverses if the ~c[current-package] is fixed, so reading from a stream
  produced by printing an object must produce an equal object.

  In ACL2, the situation is more complicated because we never read
  objects from character streams, we only read them from object
  ``streams'' (channels).  Logically speaking, the objects in such a
  channel are fixed regardless of the setting of ~c[current-package].
  However, our host file systems do not support the idea of Lisp
  object files and instead only support character files.  So when you
  open an object input channel to a given (character file) we must
  somehow convert it to a list of ACL2 objects.  This is done by a
  ~i[deus ex machina] (``a person or thing that appears or is introduced
  suddenly and unexpectedly and provides a contrived solution to an
  apparently insoluble difficulty,'' Webster's Ninth New Collegiate
  Dictionary).  Roughly speaking, the ~i[deus ex machina] determines what
  sequence of calls to ~c[read-object] will occur in the future and what
  the ~c[current-package] will be during each of those calls, and then
  produces a channel containing the sequence of objects produced by an
  analogous sequence of Common Lisp reads with ~c[*current-package*] bound
  appropriately for each.

  A simple rule suffices to make sane file ~il[io] possible:  before you
  read an object from an object channel to a file created by printing
  to a character channel, make sure the ~c[current-package] at read-time
  is the same as it was at print-time."

  (f-get-global 'current-package state))

(defthm state-p1-update-nth-2-world
  (implies (and (state-p1 state)
                (plist-worldp wrld)
                (known-package-alistp
                 (getprop 'known-package-alist 'global-value nil
                          'current-acl2-world
                          wrld))
                (symbol-alistp (getprop 'acl2-defaults-table
                                        'table-alist
                                        nil 'current-acl2-world
                                        wrld)))
           (state-p1 (update-nth 2
                                 (add-pair 'current-acl2-world
                                           wrld (nth 2 state))
                                 state)))
  :hints (("Goal" :in-theory
           (set-difference-theories
            (enable state-p1)
            '(global-val
              true-listp
              ordered-symbol-alistp
              assoc
              sgetprop
              integer-listp
              rational-listp
              true-list-listp
              open-channels-p
              all-boundp
              plist-worldp
              timer-alistp
              known-package-alistp
              32-bit-integer-listp
              file-clock-p
              readable-files-p
              written-files-p
              read-files-p
              writeable-files-p)))))

(defconst *initial-untouchable-fns*

; During development we sometimes want to execute (lp!), :redef+, and then (ld
; "patch.lisp"), where patch.lisp modifies some untouchable state globals or
; calls some untouchable functions or macros.  It is therefore handy on
; occasion to replace the current untouchables with nil.  This can be done by
; executing the following form:

;  (progn
;   (setf (cadr (assoc 'global-value (get 'untouchable-fns
;                                         *current-acl2-world-key*)))
;         nil)
;   (setf (cadr (assoc 'global-value (get 'untouchable-vars
;                                         *current-acl2-world-key*)))
;         nil))

  '(coerce-state-to-object
    coerce-object-to-state
    create-state
    user-stobj-alist
    user-stobj-alist-safe

    f-put-ld-specials

; We need to put ev (and the like) on untouchables because otherwise we can
; access untouchables!  To see this, execute (defun foo (x) x), then outside
; the ACL2 loop, execute:

; (setf (cadr (assoc 'global-value
;                    (get 'untouchables *current-acl2-world-key*)))
;       (cons 'foo
;             (cadr (assoc 'global-value
;                          (get 'untouchables *current-acl2-world-key*)))))

; Then (unfortunately) you can evaluate (ev '(foo x) '((x . 3)) state nil nil
; t) without error.

    ev-fncall ev ev-lst ev-fncall!
    ev-fncall-rec ev-rec ev-rec-lst ev-rec-acl2-unwind-protect
    ev-w ev-w-lst

    install-event

    set-w set-w! cloaked-set-w!

;   read-idate - used by write-acl2-html, so can't be untouchable?

    update-user-stobj-alist

    big-n
    decrement-big-n
    zp-big-n

    protected-eval ; must be in context of revert-world-on-error

    set-site-evisc-tuple
    set-evisc-tuple-lst
    set-evisc-tuple-fn1
    set-iprint-ar

    checkpoint-world

    let-beta-reduce

    f-put-global@par ; for #+acl2-par (modifies state under the hood)

    with-live-state ; see comment in that macro

    stobj-evisceration-alist ; returns bad object
    trace-evisceration-alist ; returns bad object

    oracle-apply-raw

; We briefly included maybe-install-acl2-defaults-table, but that defeated the
; ability to call :puff.  It now seems unnecessary to include
; maybe-install-acl2-defaults-table, since its body is something one can call
; directly.  (And there seems to be no problem with doing so; otherwise, we
; need to prevent that, not merely to make maybe-install-acl2-defaults-table
; untouchable!)

    ))

(defconst *initial-untouchable-vars*
  '(temp-touchable-vars
    temp-touchable-fns

    system-books-dir
    user-home-dir

    acl2-version
    certify-book-info

    connected-book-directory

; Although in-local-flg should probably be untouchable, currently that is
; problematic because the macro LOCAL expands into a form that touches
; in-local-flg.
;    in-local-flg

;   Since in-prove-flg need not be untouchable (currently it is only used by
;   break-on-error), we omit it from this list.  It is used by community book
;   misc/bash.lisp.

    axiomsp

    current-acl2-world
    undone-worlds-kill-ring
    timer-alist

    main-timer

    wormhole-name

    proof-tree
;   proof-tree-ctx  - used in community book books/cli-misc/expander.lisp

    fmt-soft-right-margin
    fmt-hard-right-margin

; We would like to make the following three untouchable, to avoid
; getting a raw Lisp error in this sort of situation:
;   (f-put-global 'inhibit-output-lst '(a . b) state)
;   (defun foo (x) x)
; But this will take some work so we wait....

;   inhibit-output-lst
;   inhibit-output-lst-stack
;   inhibited-summary-types

    in-verify-flg

    mswindows-drive  ;;; could be conditional on #+mswindows

    acl2-raw-mode-p

    defaxioms-okp-cert
    skip-proofs-okp-cert
    ttags-allowed
    skip-notify-on-defttag

    last-make-event-expansion
    make-event-debug-depth

    ppr-flat-right-margin

; The following should perhaps be untouchable, as they need to remain in sync.
; But they don't affect soundness, so if a user wants to mess with them, we
; don't really need to stop that.  Note that we bind gag-state in
; with-ctx-summarized, via save-event-state-globals, so if we want to make that
; variable untouchable then we need to eliminate the call of
; with-ctx-summarized from the definition of the macro theory-invariant.

;   gag-mode
;   gag-state
;   gag-state-saved

    checkpoint-summary-limit

; ld specials and such:

;   ld-skip-proofsp ;;; used in macro skip-proofs; treat bogus values as t
    ld-redefinition-action
    current-package
    standard-oi
    standard-co
    proofs-co
    ld-prompt
    ld-missing-input-ok
    ld-pre-eval-filter
    ld-pre-eval-print
    ld-post-eval-print
    ld-evisc-tuple
    ld-error-triples
    ld-error-action
    ld-query-control-alist
    ld-verbose
    writes-okp
    program-fns-with-raw-code
    logic-fns-with-raw-code
    macros-with-raw-code
    dmrp
    trace-level ; can change under the hood without logic explanation
    trace-specs
    retrace-p
    parallel-execution-enabled
    total-parallelism-work-limit ; for #+acl2p-par
    total-parallelism-work-limit-error ; for #+acl2p-par
    waterfall-parallelism ; for #+acl2p-par
    waterfall-printing ; for #+acl2p-par
    redundant-with-raw-code-okp

; print control variables

    print-base   ; must satisfy print-base-p
    print-case   ; :upcase or :downcase (could also support :capitalize)
;   print-circle ; generalized boolean
;   print-circle-files ; generalized boolean
;   print-escape ; generalized boolean
    print-length ; nil or non-negative integer
    print-level  ; nil or non-negative integer
    print-lines  ; nil or non-negative integer
;   print-pretty ; generalized boolean
;   print-radix  ; generalized boolean
;   print-readably ; generalized boolean
    print-right-margin ; nil or non-negative integer
    iprint-ar
    iprint-hard-bound
    iprint-soft-bound
;   ld-evisc-tuple ; already mentioned above
    term-evisc-tuple
    abbrev-evisc-tuple
    gag-mode-evisc-tuple
    serialize-character
    serialize-character-system

; others

    skip-proofs-by-system
    host-lisp
    compiler-enabled
    compiled-file-extension
    modifying-include-book-dir-alist
    raw-include-book-dir-alist
    deferred-ttag-notes
    deferred-ttag-notes-saved
    pc-assign
    illegal-to-certify-message
    acl2-sources-dir
    last-prover-steps ; being conservative here; perhaps could omit
    ))

; There are a variety of state global variables, 'ld-skip-proofsp among them,
; that are "bound" by LD in the sense that their values are protected by
; pushing them upon entrance to LD and popping them upon exit.  These globals
; are called the "LD specials".  For each LD special there are accessor and
; updater functions.  The updaters enforce our invariants on the values of the
; globals.  We now define the accessor for the LD special ld-skip-proofsp.  We
; delay the introduction of the updater until we have some error handling
; functions.

(defun ld-skip-proofsp (state)
  (declare (xargs :guard (state-p state)))

  ":Doc-Section Miscellaneous

  how carefully ACL2 processes your ~il[command]s~/
  ~bv[]
  Examples:
  ACL2 !>(set-ld-skip-proofsp t state)
   T
  ACL2 !s>(set-ld-skip-proofsp nil state)
   NIL
  ACL2 !>(set-ld-skip-proofsp 'include-book state)
   INCLUDE-BOOK
  ACL2 !s>
  ~ev[]~/

  A global variable in the ACL2 ~ilc[state], called ~c['ld-skip-proofsp],
  determines the thoroughness with which ACL2 processes your ~il[command]s.
  This variable may take on one of three values: ~c[t], ~c[nil] or
  ~c[']~ilc[include-book].  When ~c[ld-skip-proofsp] is non-~c[nil], the system assumes
  that which ought to be proved and is thus unsound.  The form
  ~c[(set-ld-skip-proofsp flg state)] is the general-purpose way of
  setting ~c[ld-skip-proofsp].  This global variable is an ``~ilc[ld] special,''
  which is to say, you may call ~ilc[ld] in such a way as to ``bind'' this
  variable for the dynamic extent of the ~ilc[ld].

  When ~c[ld-skip-proofsp] is non-~c[nil], the default ~il[prompt] displays the
  character ~c[s].  Thus, the ~il[prompt]
  ~bv[]
  ACL2 !s>
  ~ev[]
  means that the default ~il[defun-mode] is ~c[:]~ilc[logic] (otherwise the
  character ~c[p], for ~c[:]~ilc[program], would also be printed;
  ~pl[default-print-prompt]) but ``proofs are being skipped.''

  Observe that there are two legal non-~c[nil] values, ~c[t] and
  ~c[']~ilc[include-book].  When ~c[ld-skip-proofsp] is ~c[t], ACL2 skips all proof
  obligations but otherwise performs all other required analysis of
  input ~il[events].  When ~c[ld-skip-proofsp] is ~c[']~ilc[include-book], ACL2 skips not
  only proof obligations but all analysis except that required to
  compute the effect of successfully executed ~il[events].  To explain the
  distinction, let us consider one particular event, say a ~ilc[defun].
  Very roughly speaking, a ~ilc[defun] event normally involves a check of
  the syntactic well-formedness of the submitted definition, the
  generation and proof of the termination conditions, and the
  computation and storage of various rules such as a ~c[:]~ilc[definition] rule
  and some ~c[:]~ilc[type-prescription] rules.  By ``normally'' above we mean
  when ~c[ld-skip-proofsp] is ~c[nil].  How does a ~ilc[defun] behave when
  ~c[ld-skip-proofsp] is non-~c[nil]?

  If ~c[ld-skip-proofsp] is ~c[t], then ~ilc[defun] performs the syntactic
  well-formedness checks and computes and stores the various rules,
  but it does not actually carry out the termination proofs.  If
  ~c[ld-skip-proofsp] is ~c[']~ilc[include-book], ~ilc[defun] does not do the syntactic
  well-formedness check nor does it carry out the termination proof.
  Instead, it merely computes and stores the rules under the
  assumption that the checks and proofs would all succeed.  Observe
  that a setting of ~c[']~ilc[include-book] is ``stronger'' than a setting of ~c[t]
  in the sense that ~c[']~ilc[include-book] causes ~ilc[defun] to assume even more
  about the admissibility of the event than ~c[t] does.

  As one might infer from the choice of name, the ~ilc[include-book] event sets
  ~c[ld-skip-proofsp] to ~c[']~ilc[include-book] when processing the
  ~il[events] in a book being loaded.  Thus, ~ilc[include-book] does the
  miminal work necessary to carry out the effects of every event in the book.
  The syntactic checks and proof obligations were, presumably, successfully
  carried out when the book was certified.

  A non-~c[nil] value for ~c[ld-skip-proofsp] also affects the system's output
  messages.  Event summaries (the paragraphs that begin ``Summary''
  and display the event forms, rules used, etc.) are not printed when
  ~c[ld-skip-proofsp] is non-~c[nil].  Warnings and observations are printed
  when ~c[ld-skip-proofsp] is ~c[t] but are not printed when it is
  ~c[']~ilc[include-book].

  Intuitively, ~c[ld-skip-proofsp] ~c[t] means skip just the proofs and
  otherwise do all the work normally required for an event; while
  ~c[ld-skip-proofsp] ~c[']~ilc[include-book] is ``stronger'' and means do as little
  as possible to process ~il[events].  In accordance with this intuition,
  ~ilc[local] ~il[events] are processed when ~c[ld-skip-proofsp] is ~c[t] but are skipped
  when ~c[ld-skip-proofsp] is ~c[']~ilc[include-book].

  The ACL2 system itself uses only two settings, ~c[nil] and
  ~c[']~ilc[include-book], the latter being used only when executing the
  ~il[events] inside of a book being included.  The ~c[ld-skip-proofsp] setting
  of ~c[t] is provided as a convenience to the user.  For example, suppose one
  has a file of ~il[events].  By loading it with ~ilc[ld] with
  ~c[ld-skip-proofsp] set to ~c[t], the ~il[events] can all be checked for
  syntactic correctness and assumed without proof.  This is a convenient way to
  recover a state lost by a system crash or to experiment with a modification
  of an ~il[events] file.

  The foregoing discussion is actually based on a lie.
  ~c[ld-skip-proofsp] is allowed two other values, ~c['initialize-acl2] and
  ~c['include-book-with-locals].  The first causes behavior similar to ~c[t]
  but skips ~ilc[local] ~il[events] and avoids some error checks that would
  otherwise prevent ACL2 from properly booting.  The second is
  identical to ~c[']~ilc[include-book] but also executes ~ilc[local] ~il[events].  These
  additional values are not intended for use by the user, but no
  barriers to their use have been erected.

  We close by reminding the user that ACL2 is potentially unsound if
  ~c[ld-skip-proofsp] is ever set by the user.  We provide access to it
  simply to allow experimentation and rapid reconstruction of lost or
  modified logical ~il[world]s."

  (f-get-global 'ld-skip-proofsp state))

#-acl2-loop-only
(save-def
(defun-one-output bad-lisp-objectp (x)

; This routine does a root and branch exploration of x and guarantees that x is
; composed entirely of complex rationals, rationals, 8-bit characters that are
; "canonical" in the sense that they are the result of applying code-char to
; their character code, strings of such characters, symbols made from such
; strings (and "interned" in a package known to ACL2) and conses of the
; foregoing.

; We return nil or non-nil.  If nil, then x is a legal ACL2 object.  If we
; return non-nil, then x is a bad object and the answer is a message, msg, such
; that (fmt "~@0" (list (cons #\0 msg)) ...)  will explain why.

; All of our ACL2 code other than this routine assumes that we are manipulating
; non-bad objects, except for symbols in the invisible package, e.g. state and
; the invisible array mark.  We make these restrictions for portability's sake.
; If a Lisp expression is a theorem on a Symbolics machine we want it to be a
; theorem on a Sun.  Thus, we can't permit such constants as #\Circle-Plus.  We
; also assume (and check in chk-suitability-of-this-common-lisp) that all of
; the characters mentioned above are distinct.

  (cond ((consp x)
         (or (bad-lisp-objectp (car x))
             (bad-lisp-objectp (cdr x))))
        ((integerp x)

; CLTL2 says, p. 39, ``X3J13 voted in January 1989 <76> to specify that the
; types of fixnum and bignum do in fact form an exhaustive partition of the
; type integer; more precisely, they voted to specify that the type bignum is
; by definition equivalent to (and integer (not fixnum)).  I interpret this to
; mean that implementators (sic) could still experiment with such extensions as
; adding explicit representations of infinity, but such infinities would
; necessarily be of type bignum''

; The axioms of ACL2 would certainly not hold for experimental infinite
; bignums.  But we know of no way to test for an infinite integer.  So up
; through Version_3.6.1, we repeatedly took the square root to check that we
; get to a fixnum (which would include 0):

;        (do ((i 0 (1+ i))
;             (y (abs x) (isqrt y)))
;            (nil)
;            (cond ((typep y 'fixnum) (return nil))
;                  ((> i 200)
;                   (return (cons "We suspect that ~x0 is an infinite ~
;                                  integer, which we cannot handle in ACL2."
;                                 (list (cons #\0 x)))))))

; However, the CL HyperSpec glossary,
; http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_i.htm#integer,
; defines integers to be "mathematical integers":

;    integer  n. an object of type integer, which represents a mathematical
;    integer.

; The CL HyperSpec also makes that point in
; http://www.lispworks.com/documentation/HyperSpec/Body/t_intege.htm#integer:

;    System Class INTEGER
;    Class Precedence List:
;
;    integer, rational, real, number, t
;
;    Description:
;
;    An integer is a mathematical integer. There is no limit on the
;    magnitude of an integer.

; Therefore, we no longer check for bad integers.  But if we really need some
; such check, perhaps the following would be at least as robust as the check
; above and much more efficient:

; (typep (logcount x) 'fixnum)

; Note that  nonstandard integers integeres (like (H)) are not an issue
; because all Common Lisp integers are "real" integers, hence standard.

         nil)
        ((symbolp x)
         (cond
          ((eq x nil) nil) ; seems like useful special case for true lists
          ((bad-lisp-objectp (symbol-name x)))
          (t (let ((pkg (symbol-package x)))
               (cond
                ((null pkg)
                 (cons "Uninterned symbols such as the one CLTL displays as ~
                        ~s0 are not allowed in ACL2."
                       (list (cons #\0 (format nil "~s" x)))))
                ((not (eq x (intern (symbol-name x) pkg)))
                 (cons "The symbol ~x0 fails to satisfy the property that it ~
                        be eq to the result of interning its symbol-name in ~
                        its symbol package.  Such a symbol is illegal in ACL2."
                       (list (cons #\0 (format nil "~s" x)))))
                ((or (eq pkg *main-lisp-package*)
                     (get x *initial-lisp-symbol-mark*))
                 nil)
                ((let ((entry
                        (find-package-entry
                         (package-name pkg)
                         (known-package-alist *the-live-state*))))

; We maintain the following Invariant on Symbols in the Common Lisp Package: If
; a symbol arising in ACL2 evaluation or state resides in *main-lisp-package*,
; then either its symbol-package is *main-lisp-package* or else its
; *initial-lisp-symbol-mark* property is "COMMON-LISP".  This invariant
; supports the notion that in the ACL2 logic, there are no symbols imported
; into the "COMMON-LISP" package: that is, the symbol-package-name of a symbol
; residing in the "COMMON-LISP" package is necessarily "COMMON-LISP".  See the
; axiom common-lisp-package, and see the (raw Lisp) definition of
; symbol-package-name.

; With the above comment in mind, consider the possibility of allowing here the
; sub-case (eq x (intern (symbol-name x) *main-lisp-package*)).  Now, the
; implementation of symbol-package-name is based on package-name for symbols
; whose *initial-lisp-symbol-mark* is not set; so if we allow such a sub-case,
; then the computed symbol-package-name would be wrong on symbols such as
; SYSTEM::ALLOCATE (in GCL) or CLOS::CLASS-DIRECT-DEFAULT-INITARGS (in CLISP),
; which are imported into the "COMMON-LISP" package but do not belong to the
; list *common-lisp-symbols-from-main-lisp-package*.  One solution may seem to
; be to include code here, in this sub-case, that sets the
; *initial-lisp-symbol-mark* property on such a symbol; but that is not
; acceptable because include-book bypasses bad-lisp-objectp (see
; chk-bad-lisp-object).  Our remaining option is to change the implementation
; of symbol-package-name to comprehend symbols like the two above, say by
; looking up the name of the symbol-package in find-non-hidden-package-entry
; and then doing the above eq test when the package name is not found.  But
; this lookup could produce undesirable performance degradation for
; symbol-package-name.  So instead, we will consider symbols like the two above
; to be bad Lisp objects, with the assumption that it is rare to encounter such
; a symbol, i.e.: a symbol violating the above Invariant on Symbols in the
; Common Lisp Package.

                   (and
                    (or (null entry)
                        (package-entry-hidden-p entry))
                    (cons
                     "The symbol CLTL displays as ~s0 is not in any of the ~
                      packages known to ACL2.~@1"
                     (list
                      (cons #\0 (format nil "~s" x))
                      (cons #\1
                            (cond
                             ((or (null entry)
                                  (null (package-entry-book-path entry)))
                              "")
                             (t
                              (msg "  This package was defined under a ~
                                    locally included book.  Thus, some ~
                                    include-book was local in the following ~
                                    sequence of included books, from top-most ~
                                    book down to the book whose portcullis ~
                                    defines this package (with a defpkg ~
                                    event).~|~%  ~F0"
                                   (reverse
                                    (unrelativize-book-path
                                     (package-entry-book-path entry)
                                     (f-get-global 'system-books-dir
                                                   *the-live-state*))))))))))))
                (t nil))))))
        ((stringp x)
         (cond
          ((not (simple-string-p x))
           (cons "The strings of ACL2 must be simple strings, but ~x0 is not ~
                  simple."
                 (list (cons #\0 x))))
          (t
           (do ((i 0 (1+ i)))
               ((= i (length x)))
               (declare (type fixnum i))
               (let ((ch (char (the string x) i)))
                 (cond
                  ((legal-acl2-character-p ch) nil)
                  (t (let ((code (char-code ch)))
                       (cond ((not (< code 256))
                              (return
                               (cons "The strings of ACL2 may contain only ~
                                      characters whose char-code does not ~
                                      exceed 255.  The object CLTL displays ~
                                      as ~s0 has char-code ~x1 and hence is ~
                                      not one of those."
                                     (list (cons #\0 (coerce (list ch)
                                                             'string))
                                           (cons #\1 (char-code ch))))))
                             ((eql (the character ch)
                                   (the character (code-char code)))

; We allow the canonical character with code less than 256 in a string, even
; the character #\Null (for example) or any such character that may not be a
; legal-acl2-character-p, because in a string (unlike as a character object)
; the character will be printed in a way that can be read back in, not using a
; print name that may not be standard across all Lisps.

                              nil)
                             (t
                              (return
                               (cons "ACL2 strings may contain only ~
                                      characters without attributes.  The ~
                                      character with char-code ~x0 that CLTL ~
                                      displays as ~s1 is not the same as the ~
                                      character that is the value of ~x2."
                                     (list (cons #\0 code)
                                           (cons #\1 (coerce (list ch)
                                                             'string))
                                           (cons #\2 `(code-char
                                                       ,code)))))))))))))))
        ((characterp x)
         (cond ((legal-acl2-character-p x) nil)
               (t

; Keep this code in sync with legal-acl2-character-p.

                (cons "The only legal ACL2 characters are those recognized by ~
                       the function legal-acl2-character-p.  The character ~
                       with ~x0 = ~x1 that CLTL displays as ~s2 is not one of ~
                       those."
                      (list (cons #\0 'char-code)
                            (cons #\1 (char-code x))
                            (cons #\2 (coerce (list x) 'string)))))))
        ((typep x 'ratio)
         (or (bad-lisp-objectp (numerator x))
             (bad-lisp-objectp (denominator x))))
        ((typep x '(complex rational))
         (or (bad-lisp-objectp (realpart x))
             (bad-lisp-objectp (imagpart x))))
        (t (cons
            "ACL2 permits only objects constructed from rationals, complex ~
             rationals, legal ACL2 characters, simple strings of these ~
             characters, symbols constructed from such strings and interned in ~
             the ACL2 packages, and cons trees of such objects.  The object ~
             CLTL displays as ~s0 is thus illegal in ACL2."
            (list (cons #\0 (format nil "~s" x)))))))
)

#-acl2-loop-only
(defun-one-output chk-bad-lisp-object (x)

; We avoid the check when including a book, for efficiency.  In one experiment
; on a large book we found a 2.8% time savings by redefining this function
; simply to return nil.

  (when (not (or *inside-include-book-fn*

; We avoid the bad-lisp-objectp check during the Convert procedure of
; provisional certification, in part because it is not necessary but, more
; important, to avoid errors due to hidden defpkg events.  Without the check on
; cert-op below, we get such an error with the following example from Sol
; Swords.

;;; event.lisp
;   (in-package "FOO")
;   (defmacro acl2::my-event ()
;       '(make-event '(defun asdf () nil)))

;;; top.lisp
;   (in-package "ACL2")
;   (include-book "event")
;   (my-event)

;;; Do these commands:

; ; In one session:
; (defpkg "FOO" *acl2-exports*)
; (certify-book "event" ?)

; ; Then in another session:
; (certify-book "top" ? t :pcert :create)

; ; Then in yet another session:
; (set-debugger-enable :bt) ; optional
; (certify-book "top" ? t :pcert :convert)

                 (eq (cert-op *the-live-state*) :convert-pcert)))
    (let ((msg (bad-lisp-objectp x)))
      (cond (msg (interface-er "~@0" msg))
            (t nil)))))

(defmacro assign (x y)

  ":Doc-Section ACL2::ACL2-built-ins

  assign to a global variable in ~ilc[state]~/
  ~bv[]
  Examples:
  (assign x (expt 2 10))
  (assign a (aset1 'ascii-map-array (@ a) 66 'Upper-case-B))~/

  General Form:
  (assign symbol term)
  ~ev[]
  where ~c[symbol] is any symbol (with certain enforced exclusions to
  avoid overwriting ACL2 system ``globals'') and ~c[term] is any ACL2
  term that could be evaluated at the top-level.  ~c[Assign] evaluates
  the term, stores the result as the value of the given symbol in the
  ~c[global-table] of ~ilc[state], and returns the result.  (Note:  the
  actual implementation of the storage of this value is much more
  efficient than this discussion of the logic might suggest.)
  ~c[Assign] is a macro that effectively expands to the more
  complicated but understandable:
  ~bv[]
  (pprogn (f-put-global 'symbol term state)
          (mv nil (f-get-global 'symbol state) state)).
  ~ev[]

  The macro ~c[f-put-global] is closely related to ~ilc[assign]:
  ~c[(assign var val)] macroexpands to ~c[(f-put-global 'var val state)].

  The macro ~ilc[@] gives convenient access to the value of such globals.
  The ~c[:]~ilc[ubt] operation has no effect on the ~c[global-table] of ~ilc[state].
  Thus, you may use these globals to hang onto useful data structures
  even though you may undo back past where you computed and saved
  them.~/"

  (declare (type symbol x))
  `(pprogn (f-put-global ',x ,y state)
           (mv nil (f-get-global ',x state) state)))

(defmacro @ (x)
  ":Doc-Section ACL2::ACL2-built-ins

  get the value of a global variable in ~ilc[state]~/
  ~bv[]
  Examples:
  (+ (@ y) 1)
  (assign a (aset1 'ascii-map-array (@ a) 66 'Upper-case-B))~/

  General Form:
  (@ symbol)
  ~ev[]
  where ~c[symbol] is any symbol to which you have ~ilc[assign]ed a global
  value.  This macro expands into ~c[(f-get-global 'symbol state)], which
  retrieves the stored value of the symbol.

  The macro ~c[f-get-global] is closely related to ~ilc[@]: ~c[(@ var)]
  macroexpands to ~c[(f-get-global 'var state)].

  The macro ~ilc[assign] makes it convenient to set the value of a symbol.
  The ~c[:]~ilc[ubt] operation has no effect on the ~c[global-table] of ~ilc[state].
  Thus, you may use these globals to hang onto useful data structures
  even though you may undo back past where you computed and saved
  them.~/"

  (declare (type symbol x))
  `(f-get-global ',x state))

; We have found it useful, especially for proclaiming of FMT functions, to have
; a version `the2s' of the macro `the', for the multiple value case.  Note that
; the value returned in raw lisp by (mv x y ...) is x (unless feature
; acl2-mv-as-values is set), so for example, we can avoid boxing the fixnum x
; by suitable declarations and proclamations.

(defun make-var-lst1 (root sym n acc)
  (declare (xargs :guard (and (symbolp sym)
                              (character-listp root)
                              (integerp n)
                              (<= 0 n))
                  :mode :program))
  (cond
   ((zp n) acc)
   (t (make-var-lst1 root sym (1- n)
                     (cons (intern-in-package-of-symbol
                            (coerce (append root
                                            (explode-nonnegative-integer
                                             (1- n) 10 nil))
                                    'string)
                            sym)
                           acc)))))

(encapsulate
 ()

 (local
  (defthm character-listp-explode-nonnegative-integer
    (implies (character-listp ans)
             (character-listp (explode-nonnegative-integer n 10 ans)))))

 (verify-termination-boot-strap make-var-lst1))

(defun make-var-lst (sym n)
  (declare (xargs :guard (and (symbolp sym)
                              (integerp n)
                              (<= 0 n))))
  (make-var-lst1 (coerce (symbol-name sym) 'list) sym n nil))

; Union$

(defun union-eq-exec (l1 l2)
  (declare (xargs :guard (and (true-listp l1)
                              (true-listp l2)
                              (or (symbol-listp l1)
                                  (symbol-listp l2)))))
  (cond ((endp l1) l2)
        ((member-eq (car l1) l2)
         (union-eq-exec (cdr l1) l2))
        (t (cons (car l1) (union-eq-exec (cdr l1) l2)))))

(defun union-eql-exec (l1 l2)
  (declare (xargs :guard (and (true-listp l1)
                              (true-listp l2)
                              (or (eqlable-listp l1)
                                  (eqlable-listp l2)))))
  (cond ((endp l1) l2)
        ((member (car l1) l2)
         (union-eql-exec (cdr l1) l2))
        (t (cons (car l1) (union-eql-exec (cdr l1) l2)))))

(defun union-equal (l1 l2)
  (declare (xargs :guard (and (true-listp l1) (true-listp l2))))
  (cond ((endp l1) l2)
        ((member-equal (car l1) l2) (union-equal (cdr l1) l2))
        (t (cons (car l1) (union-equal (cdr l1) l2)))))

(defmacro union-eq (&rest lst)
  `(union$ ,@lst :test 'eq))

(defthm union-eq-exec-is-union-equal
  (equal (union-eq-exec l1 l2)
         (union-equal l1 l2)))

(defthm union-eql-exec-is-union-equal
  (equal (union-eql-exec l1 l2)
         (union-equal l1 l2)))

(defun parse-args-and-test (x tests default ctx form name)

; We use this function in union$ and intersection$ to remove optional keyword
; argument :TEST test from the given argument list, x.  The result is (mv args
; test), where either x ends in :TEST test and args is the list of values
; preceding :TEST, or else args is x and test is default.

; Tests is the list of legal tests, typically '('eq 'eql 'equal).  Default is
; the test to use by default, typically ''eql.  Ctx, form, and name are used
; for error reporting.

  (declare (xargs :guard (and (true-listp x)
                              (true-listp tests)
                              (symbolp name))))
  (let* ((len (length x))
         (len-2 (- len 2))
         (kwd/val
          (cond ((<= 2 len)
                 (let ((kwd (nth len-2 x)))
                   (cond ((keywordp kwd)
                          (cond ((eq kwd :TEST)
                                 (nthcdr len-2 x))
                                (t (hard-error
                                    ctx
                                    "If a keyword is supplied in the ~
                                     next-to-last argument of ~x0, that ~
                                     keyword must be :TEST.  The keyword ~x1 ~
                                     is thus illegal in the call ~x2."
                                    (list (cons #\0 name)
                                          (cons #\1 kwd)
                                          (cons #\2 form))))))
                         (t nil))))
                (t nil))))
    (mv (cond (kwd/val
               (let ((test (car (last x))))
                 (cond ((not (member-equal test tests))
                        (hard-error
                         ctx
                         "The :TEST argument for ~x0 must be one of ~&1.  The ~
                          form ~x2 is thus illegal.  See :DOC ~s3."
                         (list (cons #\0 name)
                               (cons #\1 tests)
                               (cons #\2 form)
                               (cons #\3 (symbol-name name)))))
                       (t test))))
              (t default))
        (cond (kwd/val (butlast x 2))
              (t x)))))

(defmacro union$ (&whole form &rest x)

  ":Doc-Section ACL2::ACL2-built-ins

  elements of one list that are not elements of another~/
  ~bv[]
  General Forms:
  (union$ l1 l2 ... lk)
  (union$ l1 l2 ... lk :test 'eql) ; same as above
  (union$ l1 l2 ... lk :test 'eq)    ; same, but eq is equality test
  (union$ l1 l2 ... lk :test 'equal) ; same, but equal is equality test
  ~ev[]

  ~c[(Union$ x y)] equals a list that contains both the members of ~c[x] and
  the members of ~c[y].  More precisely, the resulting list is the same as one
  would get by first deleting the members of ~c[y] from ~c[x], and then
  concatenating the result to the front of ~c[y].  The optional keyword,
  ~c[:TEST], has no effect logically, but provides the test (default ~ilc[eql])
  used for comparing members of the two lists.

  ~c[Union$] need not take exactly two arguments: ~c[(union$)] is ~c[nil],
  ~c[(union$ x)] is ~c[x], ~c[(union$ x y z ... :test test)] is
  ~c[(union$ x (union$ y z ... :test test) :test test)], and if ~c[:TEST] is
  not supplied, then ~c[(union$ x y z ...)] is ~c[(union$ x (union$ y z ...))].
  For the discussion below we restrict ourselves, then, to the cases
  ~c[(union$ x y)] and ~c[(union$ x y :test test)].~/

  The ~il[guard] for a call of ~c[union$] (in the two cases just above) depends
  on the test.  In all cases, both arguments must satisfy ~ilc[true-listp].  If
  the test is ~ilc[eql], then one of the arguments must satisfy
  ~ilc[eqlable-listp].  If the test is ~ilc[eq], then one of the arguments must
  satisfy ~ilc[symbol-listp].

  ~l[equality-variants] for a discussion of the relation between
  ~c[union$] and its variants:
  ~bq[]
  ~c[(union-eq x lst)] is equivalent to ~c[(union$ x lst :test 'eq)];

  ~c[(union-equal x lst)] is equivalent to ~c[(union$ x lst :test 'equal)].
  ~eq[]
  In particular, reasoning about any of these primitives reduces to reasoning
  about the function ~c[union-equal].

  Note that ~c[union-eq] can take any number of arguments, in analogy to
  ~c[union$]; indeed, ~c[(union-eq ...)] expands to ~c[(union$ ... :test 'eq)].
  However, ~c[union-equal] is a function, not a macro, and takes exactly two
  arguments.

  ~c[Union$] is similar to the Common Lisp primitive ~c[union].  However,
  Common Lisp does not specify the order of elements in the result of a call of
  ~c[union].~/"

  (mv-let
   (test args)
   (parse-args-and-test x '('eq 'eql 'equal) ''eql 'union$ form 'union$)
   (cond
    ((null args) nil)
    ((null (cdr args))
     (car args))
    (t (let* ((vars (make-var-lst 'x (length args)))
              (bindings (pairlis$ vars (pairlis$ args nil))))
         (cond ((equal test ''eq)
                `(let-mbe ,bindings
                          :logic ,(xxxjoin 'union-equal vars)
                          :exec  ,(xxxjoin 'union-eq-exec vars)))
               ((equal test ''eql)
                `(let-mbe ,bindings
                          :logic ,(xxxjoin 'union-equal vars)
                          :exec  ,(xxxjoin 'union-eql-exec vars)))
               (t ; (equal test 'equal)
                (xxxjoin 'union-equal args))))))))

(defun subst-for-nth-arg (new n args)
  (declare (xargs :mode :program))

; This substitutes the term new for the nth argument in the argument
; list args (0 based).

  (cond ((int= n 0) (cons new (cdr args)))
        (t (cons (car args) (subst-for-nth-arg new (1- n) (cdr args))))))

#+acl2-loop-only
(defmacro the-mv (args type body &optional state-pos)

; A typical use of this macro is

; (the-mv 3 (signed-byte 30) <body> 2)

; which expands to

; (MV-LET (X0 X1 STATE)
;         <body>
;         (MV (THE (SIGNED-BYTE 30) X0) X1 STATE))

; A more flexible use is

; (the-mv (v stobj1 state w) (signed-byte 30) <body>)

; which expands to

; (MV-LET (V STOBJ1 STATE W)
;         <body>
;         (MV (THE (SIGNED-BYTE 30) V) STOBJ1 STATE W))

; This macro may be used when body returns n>1 things via mv, where n=args if
; args is an integer and otherwise args is a true list of variables and n is
; the length of args.  The macro effectively declares that the first (0th)
; value returned is of the indicated type.  Finally, if n is an integer and the
; STATE is present in the return vector, you must specify where (0-based).

; The optional state-pos argument is the zero-based position of 'state in the
; argument list, if args is a number.  Otherwise state-pos is irrelevant.

  (declare (xargs :guard (and (or (and (integerp args)
                                       (< 1 args))
                                  (and (symbol-listp args)
                                       (cdr args)))
                              (or (null state-pos)
                                  (and (integerp state-pos)
                                       (<= 0 state-pos)
                                       (< state-pos args))))))
  (let ((mv-vars (if (integerp args)
                     (if state-pos
                         (subst-for-nth-arg 'state
                                            state-pos
                                            (make-var-lst 'x args))
                       (make-var-lst 'x args))
                   args)))
    (list 'mv-let
          mv-vars
          body
          (cons 'mv
                (cons (list 'the type (car mv-vars))
                      (cdr mv-vars))))))

#-acl2-loop-only
(defmacro the-mv (vars type body &optional state-pos)
  (declare (ignore #-acl2-mv-as-values vars
                   state-pos))
  #+acl2-mv-as-values (list 'the
                            `(values ,type ,@(make-list (if (integerp vars)
                                                            (1- vars)
                                                          (length (cdr vars)))
                                                        :initial-element t))
                            body)
  #-acl2-mv-as-values (list 'the type body))

(defmacro the2s (x y)
  (list 'the-mv 2 x y 1))

(deflabel bibliography
  :doc
  ":Doc-Section Miscellaneous

  reports about ACL2~/

  For a list of notes and reports about ACL2, see
  ~url[http://www.cs.utexas.edu/users/moore/publications/acl2-papers.html].~/~/")

; Here we implement acl2-defaults-table, which is used for handling the default
; defun-mode and other defaults.

; WARNING: If you add a new key to acl-defaults-table, and hence a new
; set- function for smashing the acl2-defaults-table at that key, then
; be sure to add that set- function to the list in
; chk-embedded-event-form!  E.g., when we added the
; :irrelevant-formals-ok key we also defined set-irrelevant-formals-ok
; and then added it to the list in chk-embedded-event-form.  Also add
; similarly to (deflabel acl2-defaults-table ...) and to
; primitive-event-macros.

(defun non-free-var-runes (runes free-var-runes-once free-var-runes-all acc)
  (declare (xargs :guard (and (true-listp runes)
                              (true-listp free-var-runes-once)
                              (true-listp free-var-runes-all))))
  (if (endp runes)
      acc
    (non-free-var-runes (cdr runes)
                        free-var-runes-once free-var-runes-all
                        (if (or (member-equal (car runes)
                                              free-var-runes-once)
                                (member-equal (car runes)
                                              free-var-runes-all))
                            acc
                          (cons (car runes) acc)))))

(defun free-var-runes (flg wrld)
  (declare (xargs :guard (plist-worldp wrld)))
  (cond
   ((eq flg :once)
    (global-val 'free-var-runes-once wrld))
   (t ; (eq flg :all)
    (global-val 'free-var-runes-all wrld))))

(defthm natp-position-ac ; for admission of absolute-pathname-string-p
  (implies (and (integerp acc)
                (<= 0 acc))
           (or (equal (position-ac item lst acc) nil)
               (and (integerp (position-ac item lst acc))
                    (<= 0 (position-ac item lst acc)))))
  :rule-classes :type-prescription)

(defun absolute-pathname-string-p (str directoryp os)

; Str is a Unix-style pathname.  However, on Windows, Unix-style absolute
; pathnames may start with a prefix such as "c:"; see mswindows-drive.

; Directoryp is non-nil when we require str to represent a directory in ACL2
; with Unix-style syntax, returning nil otherwise.

; Function expand-tilde-to-user-home-dir should already have been applied
; before testing str with this function.

  (declare (xargs :guard (stringp str)))
  (let ((len (length str)))
    (and (< 0 len)
         (cond ((and (eq os :mswindows) ; hence os is not nil
                     (let ((pos-colon (position #\: str))
                           (pos-sep (position *directory-separator* str)))
                       (and pos-colon
                            (eql pos-sep (1+ pos-colon))))
                     t))
               ((eql (char str 0) *directory-separator*)
                t)
               (t ; possible hard error for ~ or ~/...
                (and (eql (char str 0) #\~)

; Note that a leading character of `~' need not get special treatment by
; Windows.  See also expand-tilde-to-user-home-dir.

                     (not (eq os :mswindows))
                     (prog2$ (and (or (eql 1 len)
                                      (eql (char str 1)
                                           *directory-separator*))
                                  (hard-error 'absolute-pathname-string-p
                                              "Implementation error: Forgot ~
                                               to apply ~
                                               expand-tilde-to-user-home-dir ~
                                               before calling ~
                                               absolute-pathname-string-p. ~
                                               Please contact the ACL2 ~
                                               implementors."
                                              nil))
                             t))))
         (if directoryp
             (eql (char str (1- len)) *directory-separator*)
           t))))

(defun include-book-dir-alistp (x os)
  (declare (xargs :guard t))
  (cond ((atom x) (null x))
        (t (and (consp (car x))
                (keywordp (caar x))
                (stringp (cdar x))
                (absolute-pathname-string-p (cdar x) t os)
                (include-book-dir-alistp (cdr x) os)))))

(defun illegal-ruler-extenders-values (x wrld)
  (declare (xargs :guard (and (symbol-listp x)
                              (plist-worldp wrld))))
  (cond ((endp x) nil)
        ((or (eq (car x) :lambdas)
             (function-symbolp (car x) wrld))
         (illegal-ruler-extenders-values (cdr x) wrld))
        (t (cons (car x)
                 (illegal-ruler-extenders-values (cdr x) wrld)))))

; Intersection$

(defun intersection-eq-exec (l1 l2)
  (declare (xargs :guard
                  (and (true-listp l1)
                       (true-listp l2)
                       (or (symbol-listp l1)
                           (symbol-listp l2)))))
  (cond ((endp l1) nil)
        ((member-eq (car l1) l2)
         (cons (car l1)
               (intersection-eq-exec (cdr l1) l2)))
        (t (intersection-eq-exec (cdr l1) l2))))

(defun intersection-eql-exec (l1 l2)
  (declare (xargs :guard (and (true-listp l1)
                              (true-listp l2)
                              (or (eqlable-listp l1)
                                  (eqlable-listp l2)))))
  (cond ((endp l1) nil)
        ((member (car l1) l2)
         (cons (car l1)
               (intersection-eql-exec (cdr l1) l2)))
        (t (intersection-eql-exec (cdr l1) l2))))

(defun intersection-equal (l1 l2)
  (declare (xargs :guard
                  (and (true-listp l1)
                       (true-listp l2))))
  (cond ((endp l1) nil)
        ((member-equal (car l1) l2)
         (cons (car l1)
               (intersection-equal (cdr l1) l2)))
        (t (intersection-equal (cdr l1) l2))))

(defmacro intersection-eq (&rest lst)
  `(intersection$ ,@lst :test 'eq))

(defthm intersection-eq-exec-is-intersection-equal
  (equal (intersection-eq-exec l1 l2)
         (intersection-equal l1 l2)))

(defthm intersection-eql-exec-is-intersection-equal
  (equal (intersection-eql-exec l1 l2)
         (intersection-equal l1 l2)))

(defmacro intersection$ (&whole form &rest x)

  ":Doc-Section ACL2::ACL2-built-ins

  elements of one list that are not elements of another~/
  ~bv[]
  General Forms:
  (intersection$ l1 l2 ... lk)
  (intersection$ l1 l2 ... lk :test 'eql) ; same as above
  (intersection$ l1 l2 ... lk :test 'eq)    ; same, but eq is equality test
  (intersection$ l1 l2 ... lk :test 'equal) ; same, but equal is equality test
  ~ev[]

  ~c[(Intersection$ x y)] equals a list that contains the ~c[member]s of ~c[x]
  that are also ~c[member]s of ~c[y].  More precisely, the resulting list is
  the result of deleting from ~c[x] those members that that are not members of
  ~c[y].  The optional keyword, ~c[:TEST], has no effect logically, but
  provides the test (default ~ilc[eql]) used for comparing members of the two
  lists.

  ~c[Intersection$] need not take exactly two arguments, though it must take at
  least one argument: ~c[(intersection$ x)] is ~c[x],
 ~c[(intersection$ x y z ... :test test)] is
  ~c[(intersection$ x (intersection$ y z ... :test test) :test test)], and if
  ~c[:TEST] is not supplied, then ~c[(intersection$ x y z ...)]  is
  ~c[(intersection$ x (intersection$ y z ...))].  For the discussion below we
  restrict ourselves, then, to the cases ~c[(intersection$ x y)] and
  ~c[(intersection$ x y :test test)].~/

  The ~il[guard] for a call of ~c[intersection$] (in the two cases just above)
  depends on the test.  In all cases, both arguments must satisfy
  ~ilc[true-listp].  If the test is ~ilc[eql], then one of the arguments must
  satisfy ~ilc[eqlable-listp].  If the test is ~ilc[eq], then one of the
  arguments must satisfy ~ilc[symbol-listp].

  ~l[equality-variants] for a discussion of the relation between
  ~c[intersection$] and its variants:
  ~bq[]
  ~c[(intersection-eq x lst)] is equivalent to
  ~c[(intersection$ x lst :test 'eq)];

  ~c[(intersection-equal x lst)] is equivalent to
  ~c[(intersection$ x lst :test 'equal)].
  ~eq[]
  In particular, reasoning about any of these primitives reduces to reasoning
  about the function ~c[intersection-equal].

  Note that ~c[intersection-eq] can take any positive number of arguments, in
  analogy to ~c[intersection$]; indeed, ~c[(intersection-eq ...)] expands to
  ~c[(intersection$ ... :test 'eq)].  However, ~c[intersection-equal] is a
  function, not a macro, and takes exactly two arguments.

  ~c[Intersection$] is similar to the Common Lisp primitive ~c[intersection].
  However, Common Lisp does not specify the order of elements in the result of
  a call of ~c[intersection].~/"

  (mv-let
   (test args)
   (parse-args-and-test x '('eq 'eql 'equal) ''eql 'intersection$ form
                        'intersection$)
   (cond
    ((null args)
     (er hard 'intersection$
         "Intersection$ requires at least one list argument.  The call ~x0 is ~
          thus illegal."
         form))
    ((null (cdr args))
     (car args))
    (t (let* ((vars (make-var-lst 'x (length args)))
              (bindings (pairlis$ vars (pairlis$ args nil))))
         (cond ((equal test ''eq)
                `(let-mbe ,bindings
                          :logic ,(xxxjoin 'intersection-equal vars)
                          :exec  ,(xxxjoin 'intersection-eq-exec vars)))
               ((equal test ''eql)
                `(let-mbe ,bindings
                          :logic ,(xxxjoin 'intersection-equal vars)
                          :exec  ,(xxxjoin 'intersection-eql-exec vars)))
               (t ; (equal test 'equal)
                `(xxxjoin 'intersection-equal ,args))))))))

(defun table-alist (name wrld)

; Return the named table as an alist.

  (declare (xargs :guard (and (symbolp name)
                              (plist-worldp wrld))))
  (getprop name 'table-alist nil 'current-acl2-world wrld))

(defun ruler-extenders-msg-aux (vals return-last-table)

; We return the intersection of vals with the symbols in the cdr of
; return-last-table.

  (declare (xargs :guard (and (symbol-listp vals)
                              (symbol-alistp return-last-table))))
  (cond ((endp return-last-table) nil)
        (t (let* ((first-cdr (cdar return-last-table))
                  (sym (if (consp first-cdr) (car first-cdr) first-cdr)))
             (cond ((member-eq sym vals)
                    (cons sym
                          (ruler-extenders-msg-aux vals
                                                   (cdr return-last-table))))
                   (t (ruler-extenders-msg-aux vals
                                               (cdr return-last-table))))))))

(defun ruler-extenders-msg (x wrld)

; This message, if not nil, is passed to chk-ruler-extenders.

  (declare (xargs :guard (and (plist-worldp wrld)
                              (symbol-alistp (fgetprop 'return-last-table
                                                       'table-alist
                                                       nil wrld)))))
  (cond ((member-eq x '(:ALL :BASIC :LAMBDAS))
         nil)
        ((and (consp x)
              (eq (car x) 'quote))
         (msg "~x0 has a superfluous QUOTE, which you may wish to remove"
              x))
        ((not (symbol-listp x))
         (msg "~x0 is not a true list of symbols" x))
        (t (let* ((vals (illegal-ruler-extenders-values x wrld))
                  (suspects (ruler-extenders-msg-aux
                             vals
                             (table-alist 'return-last-table wrld))))
             (cond (vals
                    (msg "~&0 ~#0~[is not a~/are not~] legal ruler-extenders ~
                          value~#0~[~/s~].~@1"
                         vals
                         (cond (suspects
                                (msg "  Note in particular that ~&0 ~#0~[is a ~
                                      macro~/are macros~] that may expand to ~
                                      calls of ~x1, which you may want to ~
                                      specify instead."
                                     suspects 'return-last))
                               (t ""))))
                   (t nil))))))

(defmacro chk-ruler-extenders (x soft ctx wrld)
  (let ((err-str "The proposed ruler-extenders is illegal because ~@0."))
    `(let ((ctx ,ctx)
           (err-str ,err-str)
           (msg (ruler-extenders-msg ,x ,wrld)))
       (cond (msg ,(cond ((eq soft 'soft) `(er soft ctx err-str msg))
                         (t `(illegal ctx err-str (list (cons #\0 msg))))))
             (t ,(cond ((eq soft 'soft) '(value t))
                       (t t)))))))

(defmacro fixnum-bound () ; most-positive-fixnum in Allegro CL and many others
  (1- (expt 2 29)))

(defconst *default-step-limit*

; The defevaluator event near the top of community book
; books/meta/meta-plus-equal.lisp, submitted at the top level without any
; preceding events, takes over 40,000 steps.  Set the following to 40000 in
; order to make that event quickly exceed the default limit.

   (fixnum-bound))

(table acl2-defaults-table nil nil

; Warning: If you add a new key to this table, there will probably be a
; change you should make to a list in chk-embedded-event-form.  (Search there
; for add-include-book-dir, and consider keeping that list alphabetical, just
; for convenience.)

; Developer suggestion: The following form provides an example of how to add a
; new key to the table guard, in this case,

; (setf (cadr (assoc-eq 'table-guard
;                       (get 'acl2-defaults-table *current-acl2-world-key*)))
;       `(if (eq key ':new-key)
;            (if (eq val 't) 't (symbol-listp val))
;          ,(cadr (assoc-eq 'table-guard
;                           (get 'acl2-defaults-table
;                                *current-acl2-world-key*)))))

       :guard
       (cond
        ((eq key :defun-mode)
         (member-eq val '(:logic :program)))
        ((eq key :verify-guards-eagerness)
         (member val '(0 1 2)))
        ((eq key :enforce-redundancy)
         (member-eq val '(t nil :warn)))
        ((eq key :ignore-doc-string-error)
         (member-eq val '(t nil :warn)))
        ((eq key :compile-fns)
         (member-eq val '(t nil)))
        ((eq key :measure-function)
         (and (symbolp val)
              (function-symbolp val world)

; The length expression below is just (arity val world) but we don't have arity
; yet.

              (= (length (getprop val 'formals t 'current-acl2-world world))
                 1)))
        ((eq key :well-founded-relation)
         (and (symbolp val)
              (assoc-eq val (global-val 'well-founded-relation-alist world))))
        ((eq key :bogus-defun-hints-ok)
         (member-eq val '(t nil :warn)))
        ((eq key :bogus-mutual-recursion-ok)
         (member-eq val '(t nil :warn)))
        ((eq key :irrelevant-formals-ok)
         (member-eq val '(t nil :warn)))
        ((eq key :ignore-ok)
         (member-eq val '(t nil :warn)))
        ((eq key :bdd-constructors)

; We could insist that the symbols are function symbols by using
; (all-function-symbolps val world),
; but perhaps one wants to set the bdd-constructors even before defining the
; functions.

         (symbol-listp val))
        ((eq key :ttag)
         (or (null val)
             (and (keywordp val)
                  (not (equal (symbol-name val) "NIL")))))
        ((eq key :state-ok)
         (member-eq val '(t nil)))

; Rockwell Addition: See the doc string associated with
; set-let*-abstractionp.

        ((eq key :let*-abstractionp)
         (member-eq val '(t nil)))

; Rockwell Addition: See the doc string associated with
; set-nu-rewriter-mode.

        ((eq key :nu-rewriter-mode)
         (member-eq val '(nil t :literals)))

        ((eq key :backchain-limit)
         (and (true-listp val)
              (equal (length val) 2)
              (or (null (car val))
                  (natp (car val)))
              (or (null (cadr val))
                  (natp (cadr val)))))
        ((eq key :step-limit)
         (and (natp val)
              (<= val *default-step-limit*)))
        ((eq key :default-backchain-limit)
         (and (true-listp val)
              (equal (length val) 2)
              (or (null (car val))
                  (natp (car val)))
              (or (null (cadr val))
                  (natp (cadr val)))))
        ((eq key :rewrite-stack-limit)
         (unsigned-byte-p 29 val))
        ((eq key :case-split-limitations)

; In set-case-split-limitations we permit val to be nil and default that
; to (nil nil).

         (and (true-listp val)
              (equal (length val) 2)
              (or (null (car val))
                  (natp (car val)))
              (or (null (cadr val))
                  (natp (cadr val)))))
        ((eq key :match-free-default)
         (member-eq val '(:once :all nil)))
        ((eq key :match-free-override)
         (or (eq val :clear)
             (null (non-free-var-runes val
                                       (free-var-runes :once world)
                                       (free-var-runes :all world)
                                       nil))))
        ((eq key :match-free-override-nume)
         (integerp val))
        ((eq key :non-linearp)
         (booleanp val))
        ((eq key :tau-auto-modep)
         (booleanp val))
        ((eq key :include-book-dir-alist)
         (and (include-book-dir-alistp val (os world))
              (null (assoc-eq :SYSTEM val))))
        ((eq key :ruler-extenders)
         (or (eq val :all)
             (chk-ruler-extenders val hard 'acl2-defaults-table world)))
        #+hons
        ((eq key :memoize-ideal-okp)
         (or (eq val :warn)
             (booleanp val)))
        (t nil)))

(deflabel acl2-defaults-table

  :doc
  ":Doc-Section Other

  a ~il[table] specifying certain defaults, e.g., the default ~il[defun-mode]~/
  ~bv[]
  Example Forms:
  (table acl2-defaults-table :defun-mode) ; current default defun-mode
  (table acl2-defaults-table :defun-mode :program)
             ; set default defun-mode to :program
  ~ev[]~/

  ~l[table] for a discussion of tables in general.  The legal
  keys for this ~il[table] are shown below.  They may be accessed and
  changed via the general mechanisms provided by ~il[table]s.  However,
  there are often more convenient ways to access and/or change the
  defaults.  (See also the note below.)
  ~bv[]
  :defun-mode
  ~ev[]
  the default ~il[defun-mode], which must be ~c[:]~ilc[program] or ~c[:]~ilc[logic].
  ~l[defun-mode] for a general discussion of ~il[defun-mode]s.  The
  ~c[:]~ilc[defun-mode] key may be conveniently set by keyword commands
  naming the new ~il[defun-mode], ~c[:]~ilc[program] and ~c[:]~ilc[logic].
  ~l[program] and ~pl[logic].
  ~bv[]
  :enforce-redundancy
  ~ev[]
  if ~c[t], cause ACL2 to insist that most events are redundant
  (~pl[redundant-events]); if ~c[:warn], cause a warning instead of an error
  for such non-redundant events; else, ~c[nil].  ~l[set-enforce-redundancy].
  ~bv[]
  :ignore-doc-string-error
  ~ev[]
  if ~c[t], cause ACL2 to ignore ill-formed ~il[documentation] strings rather
  than causing an error; if ~c[:warn], cause a warning instead of an error
  in such cases; else, ~c[nil] (the default).
  ~l[set-ignore-doc-string-error].
  ~bv[]
  :verify-guards-eagerness
  ~ev[]
  an integer between 0 and 2 indicating how eager the system is to
  verify the ~il[guard]s of a ~il[defun] event.  ~l[set-verify-guards-eagerness].
  ~bv[]
  :compile-fns
  ~ev[]
  When this key's value is ~c[t], functions are compiled when they are
  ~ilc[defun]'d; otherwise, the value is ~c[nil].  (Except, this key's value is
  ignored when explicit compilation is suppressed; ~pl[compilation].)  To set
  the flag, ~pl[set-compile-fns].
  ~bv[]
  :measure-function
  ~ev[]
  the default measure function used by ~ilc[defun] when no ~c[:measure] is
  supplied in ~ilc[xargs].  The default measure function must be a function
  symbol of one argument. Let ~c[mfn] be the default measure function and
  suppose no ~c[:measure] is supplied with some recursive function
  definition.  Then ~ilc[defun] finds the first formal, ~c[var], that is tested
  along every branch and changed in each recursive call.  The system
  then ``guesses'' that ~c[(mfn var)] is the ~c[:measure] for that ~ilc[defun].
  ~bv[]
  :well-founded-relation
  ~ev[]
  the default well-founded relation used by ~ilc[defun] when no
  ~c[:]~ilc[well-founded-relation] is supplied in ~ilc[xargs].  The default
  well-founded relation must be a function symbol, ~c[rel], of two
  arguments about which a ~c[:]~ilc[well-founded-relation] rule has been
  proved.  ~l[well-founded-relation].
  ~bv[]
  :bogus-defun-hints-ok
  ~ev[]
  When this key's value is ~c[t], ACL2 allows ~c[:hints] for nonrecursive
  function definitions.  Otherwise, the value is the ~c[nil] (the default) or
  ~c[:warn] (which makes the check but merely warns when the check fails).
  ~l[set-bogus-defun-hints-ok].
  ~bv[]
  :bogus-mutual-recursion-ok
  ~ev[]
  When this key's value is ~c[t], ACL2 skips the check that every function in a
  ~ilc[mutual-recursion] (or ~ilc[defuns]) ``clique'' calls at least one other
  function in that ``clique.''  Otherwise, the value is ~c[nil] (the default)
  or ~c[:warn] (which makes the check but merely warns when the check fails).
  ~l[set-bogus-mutual-recursion-ok].
  ~bv[]
  :irrelevant-formals-ok
  ~ev[]
  When this key's value is ~c[t], the check for irrelevant formals is
  bypassed; otherwise, the value is the keyword ~c[nil] (the default)
  or ~c[:warn] (which makes the check but merely warns when the check
  fails).  ~l[irrelevant-formals] and ~pl[set-irrelevant-formals-ok].
  ~bv[]
  :ignore-ok
  ~ev[]
  When this key's value is ~c[t], the check for ignored variables is
  bypassed; otherwise, the value is the keyword ~c[nil] (the default)
  or ~c[:warn] (which makes the check but merely warns when the check
  fails).  ~l[set-ignore-ok].
  ~bv[]
  :bdd-constructors
  ~ev[]
  This key's value is a list of function symbols used to define the
  notion of ``BDD normal form.''  ~l[bdd-algorithm] and
  ~pl[hints].
  ~bv[]
  :ttag
  ~ev[]
  This key's value, when non-~c[nil], allows certain operations that
  extend the trusted code base beyond what is provided by ACL2.  ~l[defttag].
  ~l[defttag].
  ~bv[]
  :state-ok
  ~ev[]
  This key's value is either ~c[t] or ~c[nil] and indicates whether the user
  is aware of the syntactic restrictions on the variable symbol ~c[STATE].
  ~l[set-state-ok].
  ~bv[]
  :backchain-limit
  ~ev[]
  This key's value is a list of two ``numbers.''  Either ``number'' may
  optionally be ~c[nil], which is treated like positive infinity.  The
  numbers control backchaining through hypotheses during type-set reasoning and
  rewriting.  ~l[backchain-limit].
  ~bv[]
  :default-backchain-limit
  ~ev[]
  This key's value is a list of two ``numbers.''  Either ``number'' may
  optionally be ~c[nil], which is treated like positive infinity.  The
  numbers are used respectively to set the backchain limit of a rule if one has
  not been specified. ~l[backchain-limit].
  ~bv[]
  :step-limit
  ~ev[]
  This key's value is either ~c[nil] or a natural number not exceeding the
  value of ~c[*default-step-limit*].  If the value is ~c[nil] or the value of
  ~c[*default-step-limit*], there is no limit on the number of ``steps'' that
  ACL2 counts during a proof: currently, the number of top-level rewriting
  calls.  Otherwise, the value is the maximum number of such calls allowed
  during evaluation of any event.  ~l[set-prover-step-limit].
  ~bv[]
  :rewrite-stack-limit
  ~ev[]
  This key's value is a nonnegative integer less than ~c[(expt 2 28)].  It is
  used to limit the depth of calls of ACL2 rewriter functions.
  ~l[rewrite-stack-limit].
  ~bv[]
  :let*-abstractionp
  ~ev[]
  This key affects how the system displays subgoals.  The value is either
  ~c[t] or ~c[nil].  When t, let* expressions are introduced before printing to
  eliminate common subexpressions.  The actual goal being worked on is
  unchanged.
  ~bv[]
  :nu-rewriter-mode
  ~ev[]
  This key's value is ~c[nil], ~c[t], or ~c[:literals].  When the value is
  non-~c[nil], the rewriter gives special treatment to expressions and
  functions defined in terms of ~ilc[nth] and ~ilc[update-nth].  See
  ~ilc[set-nu-rewriter-mode].
  ~bv[]
  :case-split-limitations
  ~ev[]
  This key's value is a list of two ``numbers.''  Either ``number'' may
  optionally be ~c[nil], which is treated like positive infinity.  The
  numbers control how the system handles case splits in the simplifier.
  ~l[set-case-split-limitations].
  ~bv[]
  :include-book-dir-alist
  ~ev[]
  This key's value is used by ~ilc[include-book]'s ~c[:DIR] argument to
  associate a directory with a keyword.  An exception is the keyword
  ~c[:SYSTEM] for the ~c[books/] directory; ~pl[include-book],
  in particular the section on ``Books Directory.''
  ~bv[]
  :match-free-default
  ~ev[]
  This key's value is either ~c[:all], ~c[:once], or ~c[nil].
  ~l[set-match-free-default].
  ~bv[]
  :match-free-override
  ~ev[]
  This key's value is a list of runes.  ~l[add-match-free-override].
  ~bv[]
  :match-free-override-nume
  ~ev[]
  This key's value is an integer used in the implementation of
  ~il[add-match-free-override], so that only existing runes are affected by
  that event.
  ~bv[]
  :non-linearp
  ~ev[]
  This key's value is either ~c[t] or ~c[nil] and indicates whether the user
  wishes ACL2 to extend the linear arithmetic decision procedure to include
  non-linear reasoning.  ~l[non-linear-arithmetic].
  ~bv[]
  :tau-auto-modep
  ~ev[]
  This key's value is either ~c[t] or ~c[nil] and indicates whether the user
  wishes ACL2 to look for opportunities to create ~c[:]~ilc[tau-system] rules from
  all suitable ~c[defun]s and from all suitable ~c[defthm]s (with non-~c[nil]
  ~c[:]~ilc[rule-classes]).  ~l[set-tau-auto-mode].
  ~bv[]
  :ruler-extenders
  ~ev[]
  This key's value may be a list of symbols, indicating those function symbols
  that are not to block the collection of rulers; ~pl[defun].  Otherwise the
  value is ~c[:all] to indicate all function symbols, i.e., so that no function
  symbol blocks the collection of rulers.  If a list is specified (rather than
  ~c[:all]), then it may contain the keyword ~c[:lambdas], which has the
  special role of specifying all ~c[lambda] applications.  No other keyword is
  permitted in the list.  ~l[ruler-extenders].
  ~bv[]
  :memoize-ideal-okp
  ~ev[]
  This key is only legal in an experimental ~ilc[hons] version
  (~pl[hons-and-memoization]).  Its value must be either ~c[t], ~c[nil], or
  ~c[:warn].  If the value is ~c[nil] or not present, then it is illegal by
  default to ~il[memoize] a ~c[:]~ilc[logic] mode function that has not been
  ~il[guard]-verified (~pl[verify-guards]), sometimes called an ``ideal-mode''
  function.  This illegality is the default because such calls of such
  functions in the ACL2 loop are generally evaluated in the logic (using
  so-called ``executable counterpart'' definitions), rather than directly by
  executing calls of the corresponding (memoized) raw Lisp function.  However,
  such a raw Lisp call can be made when the function is called by a
  ~c[:]~ilc[program] mode function, so we allow you to override the default
  behavior by associating the value ~c[t] or ~c[:warn] with the key
  ~c[:memoize-ideal-okp], where with ~c[:warn] you get a suitable warning.
  Note that you can also allow memoization of ideal-mode functions by supplying
  argument ~c[:ideal-okp] to your memoization event (~pl[memoize]), in which
  case the value of ~c[:memoize-ideal-okp] in the ~c[acl2-defaults-table] is
  irrelevant.

  Note: Unlike all other ~il[table]s, ~c[acl2-defaults-table] can affect the
  soundness of the system.  The ~il[table] mechanism therefore enforces on
  it a restriction not imposed on other ~il[table]s: when ~ilc[table] is used to
  update the ~c[acl2-defaults-table], the key and value must be
  variable-free forms.  Thus, while
  ~bv[]
  (table acl2-defaults-table :defun-mode :program),

  (table acl2-defaults-table :defun-mode ':program), and

  (table acl2-defaults-table :defun-mode (compute-mode *my-data*))
  ~ev[]
  are all examples of legal ~il[events] (assuming ~c[compute-mode] is a
  function of one non-~ilc[state] argument that produces a ~il[defun-mode] as
  its single value),
  ~bv[]
  (table acl2-defaults-table :defun-mode (compute-mode (w state)))
  ~ev[]
  is not legal because the value form is ~ilc[state]-sensitive.

  Consider for example the following three ~il[events] which one might make
  into the text of a book.
  ~bv[]
  (in-package \"ACL2\")

  (table acl2-defaults-table
    :defun-mode
    (if (ld-skip-proofsp state) :logic :program))

  (defun crash-and-burn (x) (car x))
  ~ev[]
  The second event is illegal because its value form is
  ~ilc[state]-sensitive.  If it were not illegal, then it would set the
  ~c[:]~ilc[defun-mode] to ~c[:]~ilc[program] when the book was being certified but
  would set the ~il[defun-mode] to ~c[:]~ilc[logic] when the book was being loaded
  by ~ilc[include-book].  That is because during certification,
  ~ilc[ld-skip-proofsp] is ~c[nil] (proof obligations are generated and
  proved), but during book inclusion ~ilc[ld-skip-proofsp] is non-~c[nil]
  (those obligations are assumed to have been satisfied.)  Thus, the
  above book, when loaded, would create a function in ~c[:]~ilc[logic] mode that
  does not actually meet the conditions for such status.

  For similar reasons, ~ilc[table] ~il[events] affecting ~c[acl2-defaults-table] are
  illegal within the scope of ~ilc[local] forms.  That is, the text
  ~bv[]
  (in-package \"ACL2\")

  (local (table acl2-defaults-table :defun-mode :program))

  (defun crash-and-burn (x) (car x))
  ~ev[]
  is illegal because ~c[acl2-defaults-table] is changed locally.  If
  this text were acceptable as a book, then when the book was
  certified, ~c[crash-and-burn] would be processed in ~c[:]~ilc[program] mode,
  but when the certified book was included later, ~c[crash-and-burn]
  would have ~c[:]~ilc[logic] mode because the ~ilc[local] event would be skipped.

  The text
  ~bv[]
  (in-package \"ACL2\")

  (program) ;which is (table acl2-defaults-table :defun-mode :program)

  (defun crash-and-burn (x) (car x))
  ~ev[]
  is acceptable and defines ~c[crash-and-burn] in ~c[:]~ilc[program] mode, both
  during certification and subsequent inclusion.

  We conclude with an important observation about the relation between
  ~c[acl2-defaults-table] and ~ilc[include-book], ~ilc[certify-book], and
  ~ilc[encapsulate].  Including or certifying a book never has an effect on the
  ~c[acl2-defaults-table], nor does executing an ~ilc[encapsulate] event; we
  always restore the value of this ~il[table] as a final act.  (Also
  ~pl[include-book], ~pl[encapsulate], and ~pl[certify-book].)  That is, no
  matter how a book fiddles with the ~c[acl2-defaults-table], its value
  immediately after including that book is the same as immediately before
  including that book.  If you want to set the ~c[acl2-defaults-table] in a way
  that persists, you need to do so using ~il[command]s that are not inside
  ~il[books].  It may be useful to set your favorite defaults in your
  ~ilc[acl2-customization] file; ~pl[acl2-customization].")

#+acl2-loop-only
(defmacro set-enforce-redundancy (x)

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

  require most events to be redundant~/
  ~bv[]
  General Forms:
  (set-enforce-redundancy nil)   ; do not require redundancy (default)
  (set-enforce-redundancy t)     ; most events (see below) must be redundant
  (set-enforce-redundancy :warn) ; warn for most non-redundant events
  ~ev[]
  Note: This is an event!  It does not print the usual event summary
  but nevertheless changes the ACL2 logical ~il[world] and is so recorded.~/
  ~bv[]
  General Form:
  (set-enforce-redundancy flag)
  ~ev[]
  where ~c[flag] is ~c[nil], ~c[t], or ~c[:warn], as indicated above.
  This macro is essentially equivalent to
  ~bv[]
  (table acl2-defaults-table :enforce-redundancy flag)
  ~ev[]
  and hence is ~ilc[local] to any ~il[books] and ~ilc[encapsulate] ~il[events]
  in which it occurs; ~pl[acl2-defaults-table].  However, unlike the above
  simple call of the ~ilc[table] event function (~pl[table]), no output results
  from a ~c[set-enforce-redundancy] event.

  ~c[Set-enforce-redundancy] may be thought of as an event that merely sets a
  flag as indicated above, which determines whether most ~il[events], including
  ~ilc[defun] and ~ilc[defthm] events, are allowed to be redundant;
  ~pl[redundant-events].  The exceptions are ~ilc[deflabel], ~ilc[defpkg],
  ~ilc[encapsulate], ~ilc[include-book], ~ilc[push-untouchable],
  ~ilc[remove-untouchable], ~ilc[set-body], and ~ilc[table] ~il[events].  Any
  other type of non-redundant event will cause an error if ~c[flag] is ~c[t]
  and a warning if ~c[flag] is ~c[nil], ~em[except] in the course of carrying
  out an ~ilc[include-book] form.

  Note that because ~ilc[table] ~il[events] that set the
  ~ilc[acl2-defaults-table] are implicitly ~ilc[local],
  ~c[set-enforce-redundancy] events are ignored when including books.  However,
  the presence of the event ~c[(set-enforce-redundancy t)] in a book guarantees
  that its subsequent definitions and theorems are redundant.  This can be a
  useful property to maintain in library development, as we now describe.

  An example of the use of this form can be found in the community ~il[books]
  under directory ~c[books/rtl/rel4/].  The intention in that directory has
  been to put all the gory details in subdirectories ~c[support/] and
  ~c[arithmetic/], so that the books in subdirectory ~c[lib/] contain only the
  ``exported'' definitions and theorems.  This approach is useful for human
  readability.  Moreover, suppose we want to prove new theorems in ~c[lib/].
  Typically we wish to prove the new theorems using the existing books in
  ~c[lib/]; however, our methodology demands that the proofs go into books in
  ~c[support/].  If every theorem in ~c[lib/] is redundant, then we can
  ~em[develop] the proofs in ~c[lib/] but then when we are done, ~em[move] each
  book with such proofs into ~c[support/] as follows.  In any such book, we
  first replace ~ilc[include-book] forms referring to books in ~c[lib/] by
  ~ilc[include-book] forms referring to corresponding books in ~c[support/]
  and/or ~c[arithmetic/].  Then, we add suitable ~ilc[in-theory] events to get
  us back into the original ~c[lib/] proof environment.

  The default behavior of the system is as though the ~c[:enforce-redundancy]
  value is ~c[nil].  The current behavior can be ascertained by evaluating the
  following form.
  ~bv[]
  (cdr (assoc-eq :enforce-redundancy (table-alist 'acl2-defaults-table wrld)))
  ~ev[]"

  `(state-global-let*
    ((inhibit-output-lst (list* 'event 'summary (@ inhibit-output-lst))))
    (progn (table acl2-defaults-table :enforce-redundancy ,x)
           (table acl2-defaults-table :enforce-redundancy))))

#-acl2-loop-only
(defmacro set-enforce-redundancy (x)
  (declare (ignore x))
  nil)

#+acl2-loop-only
(defmacro set-ignore-doc-string-error (x)

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

  allow ill-formed ~il[documentation] strings~/
  ~bv[]
  General Forms:
  (set-ignore-doc-string-error nil)   ; :doc strings must be well-formed
  (set-ignore-doc-string-error t)     ; ill-formed :doc strings are ignored
  (set-ignore-doc-string-error :warn) ; ill-formed :doc strings are ignored
                                      ;   except for causing a warning
  ~ev[]
  Note: This is an event!  It does not print the usual event summary
  but nevertheless changes the ACL2 logical ~il[world] and is so recorded.~/
  ~bv[]
  General Form:
  (set-ignore-doc-string-error flag)
  ~ev[]
  where ~c[flag] is ~c[nil], ~c[t], or ~c[:warn], as indicated above.
  This macro is essentially equivalent to
  ~bv[]
  (table acl2-defaults-table :ignore-doc-string-error flag)
  ~ev[]
  and hence is ~ilc[local] to any ~il[books] and ~ilc[encapsulate] ~il[events]
  in which it occurs; ~pl[acl2-defaults-table].  However, unlike the above
  simple call of the ~ilc[table] event function (~pl[table]), no output results
  from a ~c[set-ignore-doc-string-error] event.

  Note that since ~ilc[defdoc] ~il[events] have the sole purpose of installing
  ~il[documentation] strings, these require well-formed documentation strings
  even after executing a call of ~c[ignore-doc-string-error].

  The default behavior of the system is as though the
  ~c[:ignore-doc-string-error] value is ~c[nil].  The current behavior can be
  ascertained by evaluating the following form.
  ~bv[]
  (ignore-doc-string-error (w state))
  ~ev[]"

  `(state-global-let*
    ((inhibit-output-lst (list* 'event 'summary (@ inhibit-output-lst))))
    (progn (table acl2-defaults-table :ignore-doc-string-error ,x)
           (table acl2-defaults-table :ignore-doc-string-error))))

#-acl2-loop-only
(defmacro set-ignore-doc-string-error (x)
  (declare (ignore x))
  nil)

(defmacro default-verify-guards-eagerness-from-table (alist)
  `(or (cdr (assoc-eq :verify-guards-eagerness ,alist))
       1))

(defun default-verify-guards-eagerness (wrld)
  (declare (xargs :guard (and (plist-worldp wrld)
                              (alistp (table-alist 'acl2-defaults-table
                                                   wrld)))))
  (default-verify-guards-eagerness-from-table
    (table-alist 'acl2-defaults-table wrld)))

#+acl2-loop-only
(defmacro set-verify-guards-eagerness (x)

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

  the eagerness with which ~il[guard] verification is tried.~/
  ~bv[]
  Example Forms:                        try guard verification?
  (set-verify-guards-eagerness 0) ; no, unless :verify-guards t
  (set-verify-guards-eagerness 1) ; yes if a guard or type is supplied
  (set-verify-guards-eagerness 2) ; yes, unless :verify-guards nil
  ~ev[]
  Note: This is an event!  It does not print the usual event summary
  but nevertheless changes the ACL2 logical ~il[world] and is so recorded.~/
  ~bv[]
  General Form:
  (set-verify-guards-eagerness n)
  ~ev[]
  where ~c[n] is a variable-free term that evaluates to ~c[0], ~c[1], or
  ~c[2].  This macro is essentially equivalent to
  ~bv[]
  (table acl2-defaults-table :verify-guards-eagerness n)
  ~ev[]
  and hence is ~ilc[local] to any ~il[books] and ~ilc[encapsulate] ~il[events]
  in which it occurs; ~pl[acl2-defaults-table].  However, unlike the above
  simple call of the ~ilc[table] event function (~pl[table]), no output results
  from a ~c[set-verify-guards-eagerness] event.

  ~c[Set-verify-guards-eagerness] may be thought of as an event that merely
  sets a flag to ~c[0], ~c[1], or ~c[2].  The flag is used by certain
  ~ilc[defun] ~il[events] to determine whether ~il[guard] verification is
  tried.  The flag is irrelevant to those ~ilc[defun] ~il[events] in
  ~c[:]~ilc[program] mode and to those ~ilc[defun] ~il[events] in which an
  explicit ~c[:]~ilc[verify-guards] setting is provided among the ~ilc[xargs].
  In the former case, ~il[guard] verification is not done because it can only
  be done when logical functions are being defined.  In the latter case, the
  explicit ~c[:]~ilc[verify-guards] setting determines whether ~il[guard]
  verification is tried.  So consider a ~c[:]~ilc[logic] mode ~ilc[defun] in
  which no ~c[:]~ilc[verify-guards] setting is provided.  Is ~il[guard]
  verification tried?  The answer depends on the eagerness setting as follows.
  If the eagerness is ~c[0], ~il[guard] verification is not tried.  If the
  eagerness is ~c[1], it is tried if and only if a guard is explicitly
  specified in the ~ilc[defun], in the following sense: there is an ~c[xargs]
  keyword ~c[:guard] or ~c[:stobjs] or a ~ilc[type] declaration.  If the
  eagerness is ~c[2], ~il[guard] verification is tried.

  The default behavior of the system is as though the
  ~c[:verify-guards-eagerness] is ~c[1].  The current behavior can be
  ascertained by evaluating the form
  ~c[(default-verify-guards-eagerness (w state))]."

  `(state-global-let*
    ((inhibit-output-lst (list* 'event 'summary (@ inhibit-output-lst))))
    (progn (table acl2-defaults-table :verify-guards-eagerness ,x)
           (table acl2-defaults-table :verify-guards-eagerness))))

#-acl2-loop-only
(defmacro set-verify-guards-eagerness (x)
  (declare (ignore x))
  nil)

(defun default-compile-fns (wrld)
  (declare (xargs :guard (and (plist-worldp wrld)
                              (alistp (table-alist 'acl2-defaults-table wrld)))))
  (cdr (assoc-eq :compile-fns (table-alist 'acl2-defaults-table wrld))))

#+acl2-loop-only
(defmacro set-compile-fns (x)

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

  have each function compiled as you go along.~/
  ~bv[]
  Example Forms:
  (set-compile-fns t)    ; new functions compiled after DEFUN
  (set-compile-fns nil)  ; new functions not compiled after DEFUN
  ~ev[]
  Note: This is an event!  It does not print the usual event summary
  but nevertheless changes the ACL2 logical ~il[world] and is so recorded.

  Also ~pl[comp], because it may be more efficient in some Common
  Lisps to compile many functions at once rather than to compile each
  one as you go along.~/
  ~bv[]
  General Form:
  (set-compile-fns term)
  ~ev[]
  where ~c[term] is a variable-free term that evaluates to ~c[t] or ~c[nil].
  This macro is equivalent to
  ~bv[]
  (table acl2-defaults-table :compile-fns term)
  ~ev[]
  and hence is ~ilc[local] to any ~il[books] and ~ilc[encapsulate] ~il[events]
  in which it occurs; ~pl[acl2-defaults-table].  However, unlike the above
  simple call of the ~ilc[table] event function (~pl[table]), no output results
  from a ~c[set-compile-fns] event.

  ~c[Set-compile-fns] may be thought of as an event that merely sets a
  flag to ~c[t] or ~c[nil].  The flag's effect is felt when functions
  are defined, as with ~ilc[defun].  If the flag is ~c[t], functions are
  automatically compiled after they are defined, as are their
  executable counterparts (~pl[executable-counterpart]).
  Otherwise, functions are not automatically compiled.  Exception: The flag has
  no effect when explicit compilation is suppressed; ~pl[compilation].

  Because ~c[set-compile-fns] is an event, the old value of the flag is
  restored when a ~c[set-compile-fns] event is undone.

  Even when ~c[:set-compile-fns t] has been executed, functions are not
  individually compiled when processing an ~ilc[include-book] event.  If
  you wish to include a book of compiled functions, we suggest that
  you first certify it with the ~il[compilation] flag set
  (~pl[certify-book]) or else compile the book by supplying the appropriate
  ~c[load-compiled-file] argument to ~ilc[include-book].  More generally,
  ~il[compilation] via ~c[set-compile-fns] is suppressed when the ~il[state]
  global variable ~ilc[ld-skip-proofsp] has value ~c[']~ilc[include-book].~/

  :cited-by Programming"

  `(state-global-let*
    ((inhibit-output-lst (list* 'event 'summary (@ inhibit-output-lst))))
     (progn (table acl2-defaults-table :compile-fns ,x)
            (table acl2-defaults-table :compile-fns))))

#-acl2-loop-only
(defmacro set-compile-fns (x)
  (declare (ignore x))
  nil)

(defun set-compiler-enabled (val state)

; We disallow the modification of 'compiler-enabled while inside include-book
; or certify-book, simply because it's too strange to contemplate; we think of
; 'compiler-enabled as a global property affecting defaults for certify-book
; and include-book.

  (declare (xargs :guard (and (member-eq val '(t nil :books))
                              (boundp-global 'certify-book-info state))
                  :stobjs state))
  #-acl2-loop-only
  (when *inside-include-book-fn*
    (let ((str
           "It is illegal to call set-compiler-enabled inside include-book."))
      (illegal 'set-compiler-enabled str nil)
      (error str) ; in surprising case that illegal doesn't cause an error
      ))
  (cond ((f-get-global 'certify-book-info state)
         (prog2$ (hard-error 'set-compiler-enabled
                             "It is illegal to call set-compiler-enabled ~
                              inside certify-book."
                             nil)
                 state))
        (t (f-put-global 'compiler-enabled val state))))

(defun default-measure-function (wrld)
  (declare (xargs :guard (and (plist-worldp wrld)
                              (alistp (table-alist 'acl2-defaults-table wrld)))))
  (or (cdr (assoc-eq :measure-function (table-alist 'acl2-defaults-table wrld)))
      'acl2-count))

#+acl2-loop-only
(defmacro set-measure-function (name)

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

  set the default measure function symbol~/
  ~bv[]
  Examples:
  (set-measure-function nqthm::count)
  ~ev[]
  Note: This is an event!  It does not print the usual event summary
  but nevertheless changes the ACL2 logical ~il[world] and is so
  recorded.~/
  ~bv[]
  General Form:
  (set-measure-function name)
  ~ev[]
  where ~c[name] is a function symbol of one argument.  This macro is
  equivalent to ~c[(table acl2-defaults-table :measure-function 'name)],
  and hence is ~ilc[local] to any ~il[books] and ~ilc[encapsulate] ~il[events]
  in which it occurs; ~pl[acl2-defaults-table].  Although this is thus an event
  (~pl[table]), nevertheless no output results from a ~c[set-measure-function]
  event.

  This event sets the default measure function to ~c[name].  Subsequently,
  if a recursively defined function is submitted to ~ilc[defun] with no
  explicitly given ~c[:measure] argument, ~ilc[defun] ``guesses'' the measure
  ~c[(name var)], where ~c[name] is the then current default measure function
  and ~c[var] is the first formal found to be tested along every branch
  and changed in every recursive call.

  Note that if ~c[(table acl2-defaults-table :measure-function 'name)] has its
  default value of ~c[nil], then the default measure function is
  ~ilc[acl2-count].~/"

  `(state-global-let*
    ((inhibit-output-lst (list* 'event 'summary (@ inhibit-output-lst))))
     (progn (table acl2-defaults-table :measure-function ',name)
            (table acl2-defaults-table :measure-function))))

#-acl2-loop-only
(defmacro set-measure-function (name)
  (declare (ignore name))
  nil)

(defun default-well-founded-relation (wrld)
  (declare (xargs :guard (and (plist-worldp wrld)
                              (alistp (table-alist 'acl2-defaults-table wrld)))))
  (or (cdr (assoc-eq :well-founded-relation (table-alist 'acl2-defaults-table wrld)))
      'o<))

#+acl2-loop-only
(defmacro set-well-founded-relation (rel)

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

  set the default well-founded relation~/
  ~bv[]
  Examples:
  (set-well-founded-relation lex2)
  ~ev[]
  provided ~c[lex2] has been proved to be a well-founded relation
  (~pl[well-founded-relation]).  Note: This is an event!  It does
  not print the usual event summary but nevertheless changes the ACL2
  logical ~il[world] and is so recorded.~/
  ~bv[]
  General Form:
  (set-well-founded-relation rel)
  ~ev[]
  where ~c[rel] has been proved to be a well-founded relation on objects
  satisfying some predicate, ~c[mp]; ~pl[well-founded-relation].  This macro is
  equivalent to ~c[(table acl2-defaults-table :well-founded-relation 'rel)],
  and hence is ~ilc[local] to any ~il[books] and ~ilc[encapsulate] ~il[events]
  in which it occurs; ~pl[acl2-defaults-table].

  This event sets the default well-founded relation to be that imposed
  on ~c[mp]-measures by the relation ~c[rel].  Subsequently, if a recursively
  defined function is submitted to ~ilc[defun] with no explicitly given
  ~c[:]~ilc[well-founded-relation] argument, ~ilc[defun] uses the default relation,
  ~c[rel], and the associated domain predicate ~c[mp] used in its
  well-foundedness theorem.  That is, the termination conditions
  generated will require proving that the measure used by the ~ilc[defun] is
  an ~c[mp]-measure and that in every recursive call the measure of the
  arguments decreases according to ~c[rel].~/"

  `(state-global-let*
    ((inhibit-output-lst (list* 'event 'summary (@ inhibit-output-lst))))
     (progn (table acl2-defaults-table :well-founded-relation ',rel)
            (table acl2-defaults-table :well-founded-relation))))

#-acl2-loop-only
(defmacro set-well-founded-relation (rel)
  (declare (ignore rel))
  nil)

; Another default is the defun-mode.

(defmacro default-defun-mode-from-table (alist)
  `(let ((val (cdr (assoc-eq :defun-mode ,alist))))
     (if (member-eq val '(:logic :program)) ; from table guard
         val

; We set the default-defun-mode to :program when val is NIL, which is
; the case for boot-strapping.

       :program)))

(defun default-defun-mode (wrld)

  ":Doc-Section Miscellaneous

  the default ~il[defun-mode] of ~ilc[defun]'d functions~/

  When a ~ilc[defun] is processed and no ~c[:mode] ~c[xarg] is supplied, the
  function ~c[default-defun-mode] is used.  To find the default ~il[defun-mode]
  of the current ACL2 ~il[world], type ~c[(default-defun-mode (w state))].
  ~l[defun-mode] for a discussion of ~il[defun-mode]s.  To change the
  default ~il[defun-mode] of the ACL2 ~il[world], type one of the keywords
  ~c[:]~ilc[program] or ~c[:]~ilc[logic].~/

  The default ACL2 ~il[prompt] displays the current default ~il[defun-mode] by
  showing the character ~c[p] for ~c[:]~ilc[program] mode, and omitting it for
  ~c[:]~ilc[logic] mode; ~pl[default-print-prompt].  The default ~il[defun-mode]
  may be changed using the keyword ~il[command]s ~c[:]~ilc[program] and ~c[:]~ilc[logic],
  which are equivalent to the ~il[command]s ~c[(program)] and ~c[(logic)].
  Each of these names is documented separately:  ~pl[program] and
  ~pl[logic].  The default ~il[defun-mode] is stored in the ~il[table]
  ~ilc[acl2-defaults-table] and hence may also be changed by a ~ilc[table]
  ~il[command].  ~l[table] and also ~pl[acl2-defaults-table].
  Both mode-changing ~il[command]s are ~il[events].

  While ~il[events] that change the default ~il[defun-mode] are permitted within
  an ~ilc[encapsulate] or the text of a book, their effects are ~ilc[local] in
  scope to the duration of the encapsulation or inclusion.  For
  example, if the default ~il[defun-mode] is ~c[:]~ilc[logic] and a book is
  included that contains the event ~c[(program)], then subsequent
  ~il[events] within the book are processed with the default ~il[defun-mode]
  ~c[:]~ilc[program]; but when the ~ilc[include-book] event completes, the
  default ~il[defun-mode] will still be ~c[:]~ilc[logic].  ~il[Command]s that change
  the default ~il[defun-mode] are not permitted inside ~ilc[local] forms.~/"

  (declare (xargs :guard (and (plist-worldp wrld)
                              (alistp (table-alist 'acl2-defaults-table
                                                   wrld)))))
  (default-defun-mode-from-table (table-alist 'acl2-defaults-table wrld)))

; The following is used in the definition of when-logic, in order to provide
; something limited to put on the chk-new-name-lst of the primordial world.

(defun default-defun-mode-from-state (state)
  (declare (xargs :guard (state-p state)))
  (default-defun-mode (w state)))

#+acl2-loop-only
(defmacro logic nil

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

  to set the default ~il[defun-mode] to ~c[:logic]~/
  ~bv[]
  Example:
  ACL2 p!>:logic
  ACL2 !>
  ~ev[]
  Typing the keyword ~c[:logic] sets the default ~il[defun-mode] to ~c[:logic].

  Functions defined in ~c[:logic] mode are logically defined.
  ~l[defun-mode].

  Note: This is an event!  It does not print the usual event summary
  but nevertheless changes the ACL2 logical ~il[world] and is so
  recorded.~/

  ~l[defun-mode] for a discussion of the ~il[defun-mode]s available
  and what their effects on the logic are.
  ~l[default-defun-mode] for a discussion of how the default
  ~il[defun-mode] is used.  This event is equivalent to
  ~c[(table acl2-defaults-table :defun-mode :logic)],
  and hence is ~ilc[local] to any ~il[books] and ~ilc[encapsulate] ~il[events]
  in which it occurs. ~l[acl2-defaults-table].

  Recall that the top-level form ~c[:logic] is equivalent to ~c[(logic)];
  ~pl[keyword-commands].  Thus, to change the default ~il[defun-mode]
  to ~c[:logic] in a book, use ~c[(logic)], which is an embedded event
  form, rather than ~c[:logic], which is not a legal form for ~il[books].
  ~l[embedded-event-form]."

  '(state-global-let*
    ((inhibit-output-lst (list* 'summary (@ inhibit-output-lst))))
    (er-progn (table acl2-defaults-table :defun-mode :logic)
              (value :invisible))))

#-acl2-loop-only
(defmacro logic () nil)

#+acl2-loop-only
(defmacro program nil

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

  to set the default ~il[defun-mode] to ~c[:]~ilc[program]~/
  ~bv[]
  Example:
  ACL2 !>:program
  ACL2 p!>
  ~ev[]
  Typing the keyword ~c[:program] sets the default ~il[defun-mode] to ~c[:program].

  Functions defined in ~c[:program] mode are logically undefined but can
  be executed on constants outside of deductive contexts.
  ~l[defun-mode].

  Calls of the following macros are ignored (skipped) when in ~c[:program]
  mode.
  ~bv[]
  local
  verify-guards
  verify-termination
  defaxiom
  defthm
  deftheory
  in-theory
  in-arithmetic-theory
  regenerate-tau-database
  theory-invariant
  defchoose
  ~ev[]

  Note: This is an event!  It does not print the usual event summary
  but nevertheless changes the ACL2 logical ~il[world] and is so
  recorded.~/

  ~l[defun-mode] for a discussion of the ~il[defun-mode]s available
  and what their effects on the logic are.
  ~l[default-defun-mode] for a discussion of how the default
  ~il[defun-mode] is used.  This event is equivalent to
  ~c[(table acl2-defaults-table :defun-mode :program)],
  and hence is ~ilc[local] to any ~il[books] and ~ilc[encapsulate] ~il[events]
  in which it occurs. ~l[acl2-defaults-table].

  Recall that the top-level form ~c[:program] is equivalent to ~c[(program)];
  ~pl[keyword-commands].  Thus, to change the default ~il[defun-mode]
  to ~c[:program] in a book, use ~c[(program)], which is an embedded event
  form, rather than ~c[:program], which is not a legal form for ~il[books].
  ~l[embedded-event-form]."

  '(state-global-let*
    ((inhibit-output-lst (list* 'summary (@ inhibit-output-lst))))
    (er-progn (table acl2-defaults-table :defun-mode :program)
              (value :invisible))))

#-acl2-loop-only
(defmacro program () nil)

(defun invisible-fns-table (wrld)

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

  functions that are invisible to the ~il[loop-stopper] algorithm~/
  ~bv[]
  Examples:
  ACL2 !>(invisible-fns-table (w state))
  ((binary-+ unary--)
   (binary-* unary-/)
   (unary-- unary--)
   (unary-/ unary-/))
  ~ev[]
  Among other things, the setting above has the effect of making ~ilc[unary--]
  ``invisible'' for the purposes of applying permutative ~c[:]~ilc[rewrite]
  rules to ~ilc[binary-+] trees.  Also ~pl[add-invisible-fns] and
  ~pl[remove-invisible-fns], which manage macro aliases
  (~pl[macro-aliases-table]), as well as ~pl[set-invisible-fns-table].

  ~l[table] for a general discussion of tables.~/

  The ``invisible functions ~il[table]'' is an alist with elements of the following
  form, where ~c[fn] is a function symbol and the ~c[ufni] are unary function
  symbols in the current ACL2 ~il[world], and ~c[k] is at least 1.
  ~bv[]
  (fn ufn1 ufn2 ... ufnk)
  ~ev[]

  This ~il[table] thus associates with certain function symbols, e.g., ~c[fn]
  above, a set of unary functions, e.g., the ~c[ufni] above.  The ~c[ufni]
  associated with ~c[fn] in the invisible functions table are said to be
  ``invisible with respect to ~c[fn].''  If ~c[fn] is not the ~ilc[car] of any
  pair in the ~c[alist], then no function is invisible for it.  Thus for
  example, setting the invisible functions alist to ~c[nil] completely
  eliminates the consideration of invisibility.

  The notion of invisibility is involved in the use of the
  ~c[:]~ilc[loop-stopper] field of ~c[:]~ilc[rewrite] rules to prevent the indefinite
  application of permutative rewrite rules.  Roughly speaking, if
  rewrite rules are being used to permute ~c[arg] and (ufni arg) inside of
  a nest of ~c[fn] calls, and ~c[ufni] is invisible with respect to ~c[fn], then
  ~c[arg] and ~c[(ufni arg)] are considered to have the same ``weight'' and
  will be permuted so as to end up as adjacent tips in the ~c[fn] nest.
  ~l[loop-stopper].~/"

  (declare (xargs :guard (plist-worldp wrld)))
  (table-alist 'invisible-fns-table wrld))

(defmacro set-invisible-fns-table (alist)

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

  set the invisible functions table~/
  ~bv[]
  Examples:
  (set-invisible-fns-table ((binary-+ unary--)
                            (binary-* unary-/)
                            (unary-- unary--)
                            (unary-/ unary-/)))
  (set-invisible-fns-table t) ; restore original invisible-fns-table
  ~ev[]
  Among other things, the setting above has the effect of making
  ~ilc[unary--] ``invisible'' for the purposes of applying permutative
  ~c[:]~ilc[rewrite] rules to ~ilc[binary-+] trees.  Thus, ~c[arg] and ~c[(unary-- arg)] will
  be given the same weight and will be permuted so as to be adjacent.
  The form ~c[(invisible-fns-table (w state))] returns the current value
  of the invisible functions table.

  Also ~pl[add-invisible-fns] and ~pl[remove-invisible-fns] for events that add
  to and remove from the invisible functions table, while accounting for macro
  aliases (~pl[macro-aliases-table]).~/
  ~bv[]
  General Form:
  (set-invisible-fns-table alist)
  ~ev[]
  where ~c[alist] is either ~c[t] or a true list of pairs, each element of
  which is of the form ~c[(fn ufn1 ... ufnk)], where ~c[fn] is a function
  symbol and each ~c[ufni] is a unary function symbol.  When alist is ~c[t],
  the initial value of this table is used in its place.  Modulo the
  replacement of ~c[alist] by the default setting when ~c[alist] is ~c[t], this
  macro is equivalent to
  ~bv[]
  (table invisible-fns-table nil 'alist :clear)
  ~ev[]
  which is also an event (~pl[table]).

  Note that ~c[set-invisible-fns-table] does not evaluate its argument.
  However, you can call ~ilc[table] directly for that purpose.  For example,
  ~bv[]
  (set-invisible-fns-table ((binary-+ unary--)
                            (binary-* unary-/)
                            (unary-- unary--)
                            (unary-/ unary-/)))
  ~ev[]
  ie equivalent to the following; ~pl[table].
  ~bv[]
  (table invisible-fns-table nil
         (quote ((binary-+ unary--)
                 (binary-* unary-/)
                 (unary-- unary--)
                 (unary-/ unary-/)))
         :clear)
  ~ev[]

  ~l[invisible-fns-table] for a description of the invisible functions table.~/"

  `(table invisible-fns-table
          nil
          ',(cond ((eq alist t)

; We provide the alist = t setting mainly so the user can always
; obtain the initial setting.  But we also use it ourselves in a call
; of (set-invisible-fns-table t) below that initialize the table.

                   '((binary-+ unary--)
                     (binary-* unary-/)
                     (unary-- unary--)
                     (unary-/ unary-/)))
                  (t alist))
          :clear))

(defun unary-function-symbol-listp (lst wrld)
  (declare (xargs :guard (plist-worldp wrld)))
  (cond ((atom lst) (null lst))
        (t (and (symbolp (car lst))

; The length expression below is roughly arity, which could have been used
; instead except that it is not defined yet in axioms.lisp.  Note that since
; (length nil) = 1, this works even when we have do not have a
; function-symbolp.  Actually we avoid length in order to ease the
; guard verification process at this point.

; (= (length formals) 1)...
                (let ((formals (getprop (car lst) 'formals nil
                                        'current-acl2-world wrld)))
                  (and (consp formals)
                       (null (cdr formals))))
                (unary-function-symbol-listp (cdr lst) wrld)))))

(defun invisible-fns-entryp (key val wrld)
  (declare (xargs :guard (plist-worldp wrld)))
  (and (symbolp key)
       (function-symbolp key wrld)
       (unary-function-symbol-listp val wrld)))

(table invisible-fns-table nil nil
       :guard
       (invisible-fns-entryp key val world))

(set-invisible-fns-table t)

(defmacro add-invisible-fns (top-fn &rest unary-fns)

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

  make some unary functions invisible to the ~il[loop-stopper] algorithm~/
  ~bv[]
  Examples:
  (add-invisible-fns binary-+ unary-- foo)
  (add-invisible-fns + unary-- foo)
  ~ev[]
  Each of the ~il[events] above makes unary functions ~ilc[unary--] and ~c[foo]
  ``invisible'' for the purposes of applying permutative ~c[:]~ilc[rewrite]
  rules to ~ilc[binary-+] trees.  Thus, ~c[arg] and ~c[(unary-- arg)] will be
  given the same weight and will be permuted so as to be adjacent.~/
  ~bv[]
  General Form:
  (add-invisible-fns top-fn unary-fn1 ... unary-fnk)
  ~ev[]
  where ~c[top-fn] is a function symbol and the ~c[unary-fni] are unary
  function symbols, or more generally, these are all macro aliases for function
  symbols (~pl[macro-aliases-table]).

  For more information ~pl[invisible-fns-table].  Also
  ~pl[set-invisible-fns-table], which explains how to set the entire table in a
  single event, and ~pl[remove-invisible-fns].~/"

  `(table invisible-fns-table nil
          (let* ((tbl (table-alist 'invisible-fns-table world))
                 (macro-aliases (macro-aliases world))
                 (top-fn (deref-macro-name ',top-fn macro-aliases))
                 (old-entry (assoc-eq top-fn tbl))
                 (unary-fns (deref-macro-name-lst ',unary-fns macro-aliases)))
            (if (not (subsetp-eq unary-fns (cdr old-entry)))
                (put-assoc-eq top-fn
                              (union-eq unary-fns (cdr old-entry))
                              tbl)
              (prog2$ (cw "~%NOTE:  Add-invisible-fns did not change the ~
                           invisible-fns-table.  Consider using :u or :ubt to ~
                           undo this event.~%")
                      tbl)))
          :clear))

(defmacro remove-invisible-fns (top-fn &rest unary-fns)

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

  make some unary functions no longer invisible~/
  ~bv[]
  Examples:
  (remove-invisible-fns (binary-+ unary-- foo)
  (remove-invisible-fns (+ unary-- foo)
  ~ev[]
  The setting above has makes unary functions ~ilc[unary--] and ~c[foo] no
  longer ``invisible'' for the purposes of applying permutative ~c[:]~ilc[rewrite]
  rules to ~ilc[binary-+] trees.~/
  ~bv[]
  General Form:
  (remove-invisible-fns top-fn unary-fn1 ... unary-fnk)
  ~ev[]
  where ~c[top-fn] is a function symbol and the ~c[unary-fni] are unary
  function symbols, or more generally, these are all macro aliases for function
  symbols (~pl[macro-aliases-table]).

  ~l[add-invisible-fns] and also ~pl[invisible-fns-table] and
  ~pl[set-invisible-fns-table].~/"

  `(table invisible-fns-table nil
          (let* ((tbl (table-alist 'invisible-fns-table world))
                 (macro-aliases (macro-aliases world))
                 (top-fn (deref-macro-name ',top-fn macro-aliases))
                 (old-entry (assoc-eq top-fn tbl))
                 (unary-fns (deref-macro-name-lst ',unary-fns macro-aliases)))
            (if (intersectp-eq unary-fns (cdr old-entry))
                (let ((diff (set-difference-eq (cdr old-entry) unary-fns)))
                  (if diff
                      (put-assoc-eq top-fn diff tbl)
                    (delete-assoc-eq top-fn tbl)))
              (prog2$ (cw "~%NOTE:  Remove-invisible-fns did not change the ~
                           invisible-fns-table.  Consider using :u or :ubt to ~
                           undo this event.~%")
                      tbl)))
          :clear))

; The following two definitions are included to help users transition from
; Version_2.6 to Version_2.7 (where [set-]invisible-fns-alist was replaced by
; [set-]invisible-fns-table).

(defmacro set-invisible-fns-alist (alist)
  (declare (ignore alist))
  '(er hard 'set-invisible-fns-alist
       "Set-invisible-fns-alist has been replaced by set-invisible-fns-table. ~
        See :DOC invisible-fns-table.  Also see :DOC add-invisible-fns and see ~
        :DOC remove-invisible-fns."))

(defmacro invisible-fns-alist (wrld)
  (declare (ignore wrld))
  '(er hard 'invisible-fns-alist
       "Invisible-fns-alist has been replaced by invisible-fns-table.  Please ~
        see :DOC invisible-fns-table."))

#+acl2-loop-only
(defmacro set-bogus-defun-hints-ok (x)

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

  allow unnecessary ``mutual recursion'' ~/
  ~bv[]
  General Forms:
  (set-bogus-defun-hints-ok t)
  (set-bogus-defun-hints-ok nil)
  (set-bogus-defun-hints-ok :warn)
  ~ev[]
  By default, ACL2 causes an error when the keyword ~c[:]~ilc[hints] is
  supplied in an ~ilc[xargs] ~il[declare] form for a definition (~pl[defun]).
  This behavior can be defeated with ~c[(set-bogus-defun-hints-ok t)], or if
  you still want to see a warning in such cases,
  ~c[(set-bogus-defun-hints-ok :warn)].~/~/"

  `(state-global-let*
    ((inhibit-output-lst (list* 'event 'summary (@ inhibit-output-lst))))
     (progn (table acl2-defaults-table :bogus-defun-hints-ok ,x)
            (table acl2-defaults-table :bogus-defun-hints-ok))))

#-acl2-loop-only
(defmacro set-bogus-defun-hints-ok (x)
  (declare (ignore x))
  nil)

#+acl2-loop-only
(defmacro set-bogus-mutual-recursion-ok (x)

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

  allow unnecessary ``mutual recursion'' ~/
  ~bv[]
  Examples:
  (set-bogus-mutual-recursion-ok t)
  (set-bogus-mutual-recursion-ok nil)
  (set-bogus-mutual-recursion-ok :warn)
  ~ev[]
  By default, ACL2 checks that when a ``clique'' of more than one
  function is defined simultaneously (using ~ilc[mutual-recursion] or
  ~ilc[defuns]), then every body calls at least one of the functions in
  the ``clique.''  Below, we refer to definitional events that fail
  this check as ``bogus'' mutual recursions.  The check is important
  because ACL2 does not store induction schemes for functions defined
  with other functions in a ~ilc[mutual-recursion] or ~ilc[defuns]
  event.  Thus, ACL2 may have difficulty proving theorems by induction
  that involve such functions.  Moreover, the check can call attention
  to bugs, since users generally intend that their mutual recursions
  are not bogus.

  Nevertheless, there are times when it is advantageous to allow bogus
  mutual recursions, for example when they are generated mechanically,
  even at the expense of losing stored induction schemes.  The first
  example above allows bogus mutual recursion.  The second example
  disallows bogus mutual recursion; this is the default.  The third
  example allows bogus mutual recursion, but prints an appropriate
  warning.

  Note: This is an event!  It does not print the usual event summary
  but nevertheless changes the ACL2 logical ~il[world] and is so
  recorded.  Moreover, its effect is to set the ~ilc[acl2-defaults-table], and
  hence its effect is ~ilc[local] to the book or ~ilc[encapsulate] form
  containing it; ~pl[acl2-defaults-table].~/
  ~bv[]
  General Form:
  (set-bogus-mutual-recursion-ok flg)
  ~ev[]
  where ~c[flg] is either ~c[t], ~c[nil], or ~c[:warn].~/

  :cited-by Programming"

  `(state-global-let*
    ((inhibit-output-lst (list* 'event 'summary (@ inhibit-output-lst))))
     (progn (table acl2-defaults-table :bogus-mutual-recursion-ok ,x)
            (table acl2-defaults-table :bogus-mutual-recursion-ok))))

#-acl2-loop-only
(defmacro set-bogus-mutual-recursion-ok (x)
  (declare (ignore x))
  nil)

(defdoc ruler-extenders
  ":Doc-Section switches-parameters-and-modes

  control for ACL2's termination and induction analyses~/

  ~st[Introduction]

  Consider the following recursive definition, which returns a list of threes
  of length one more than the length of ~c[x].
  ~bv[]
    (defun f (x)
      (cons 3
            (if (consp x)
                (f (cdr x))
              nil)))
  ~ev[]
  One might expect ACL2's termination analysis to admit this function, since we
  know that ~c[(cdr x)] is ``smaller'' than ~c[x] if ~c[(consp x)] is true.
  (By default, ACL2's notion of ``smaller'' is ordinary natural-number ~c[<],
  and the argument ~c[x] is measured by applying function ~c[acl2-count] to
  ~c[x].)  However, that termination analysis does not consider ~ilc[IF] tests,
  like ~c[(consp x)] above, when they occur under calls of functions other than
  ~c[IF], such as ~c[CONS] in the case above.

  One way to overcome this problem is to ``lift'' the ~c[IF] test to the top
  level, as follows.
  ~bv[]
    (defun f (x)
      (if (consp x)
          (cons 3 (f (cdr x)))
        (cons 3 nil)))
  ~ev[]
  But another way to overcome the problem is to tell ACL2 to extend its
  termination (and induction) analysis through calls of ~c[cons], as follows.
  ~bv[]
    (defun f (x)
      (declare (xargs :ruler-extenders (cons)))
      (cons 3
            (if (consp x)
                (f (cdr x))
              nil)))
  ~ev[]
  You may even wish to provide value ~c[:all] instead of an explicit list of
  ruler-extenders, so that no function call blocks the termination analysis:
  ~bv[]
    (defun f (x)
      (declare (xargs :ruler-extenders :all))
      (cons 3
            (if (consp x)
                (f (cdr x))
              nil)))
  ~ev[]
  Alternatively, you can omit the ~c[XARGS] ~c[:RULER-EXTENDERS] form, instead
  modifying the global default set of ruler-extenders:
  ~bv[]
    (set-ruler-extenders :all)

    ; or, for example:
    (set-ruler-extenders '(cons return-last))
  ~ev[]
  You can call the function ~ilc[default-ruler-extenders] as follows to see the
  current global default set of ruler-extenders:
  ~bv[]
  (default-ruler-extenders (w state))
  ~ev[]

  We conclude this introduction by considering the handling of ~c[LET]
  expressions by termination analysis.  Consider the following example.
  ~bv[]
    (defun fact (n)
      (the (integer 1 *)
           (if (posp n)
               (* n (fact (1- n)))
             1)))
  ~ev[]
  ACL2 treats the call of ~ilc[THE] in the body of this definition as follows.
  ~bv[]
    (let ((var (if (posp n)
                   (* n (fact (1- n)))
                 1)))
      (if (and (integerp var) (<= 1 var))
          var
        <some_error>))
  ~ev[]
  A ~ilc[LET] expression, in turn, is treated as a ~ilc[LAMBDA] application:
  ~bv[]
    ((lambda (var)
       (if (if (integerp var)
               (not (< var 1))
             nil)
           var
         <some_error>))
     (if (posp n)
         (* n (fact (1- n)))
       1))
  ~ev[]
  Notice that the ~ilc[posp] test, which governs the recursive call of
  ~c[fact], is inside an argument of a function application, namely the
  application of the ~c[LAMBDA] expression.  So by default, ACL2 will not
  consider this ~ilc[posp] test in its termination analysis.  The keyword
  ~c[:LAMBDAS] in the list of ruler-extenders denotes all calls of lambda
  expressions, much as the inclusion of ~c[CONS] in the ruler-extenders denotes
  all calls of ~c[CONS].  The following definition is thus accepted by ACL2.
  ~bv[]
    (defun fact (n)
      (declare (xargs :ruler-extenders (:lambdas)))
      (the (integer 1 *)
           (if (posp n)
               (* n (fact (1- n)))
             1)))
  ~ev[]
  As a convenience, ACL2 allows the symbol ~c[:lambdas] in place of
  ~c[(:lambdas)], and in fact the former will also include the default
  ruler-extenders: ~ilc[RETURN-LAST] (which comes from macroexpansion of calls
  of ~ilc[PROG2$], ~ilc[EC-CALL], and others) and ~ilc[MV-LIST].

  IMPORTANT REMARKS.  (1) Notice that the argument to ~c[set-ruler-extenders]
  is evaluated, but the argument to ~c[:RULER-EXTENDERS] in ~c[XARGS] is not
  evaluated.  (2) Do not put macro names in your list of ruler-extenders.  For
  example, if you intend that ~c[+] should not block the termination analysis,
  in analogy to ~c[cons] in the example above, then the list of ruler-extenders
  should include ~c[binary-+], not ~c[+].  Of course, if you use ~c[:all] then
  this is not an issue, but see the next remark.  (3) Also please note that by
  taking advantage of the ruler-extenders, you may be complicating the
  induction scheme stored for the function, whose computation takes similar
  advantage of the additional ~c[IF] structure that you are specifying.

  Below we describe the notion of ruler-extenders in detail, as well as how to
  set its default using ~c[set-ruler-extenders].

  ~st[Details]

  We begin by discussing how to set the ruler-extenders by using the macro
  ~c[set-ruler-extenders]; below we will discuss the use of keyword
  ~c[:ruler-extenders] in ~ilc[XARGS] ~ilc[declare] forms.

  ~bv[]
  Examples:
  (set-ruler-extenders :basic) ; return to default
  (set-ruler-extenders *basic-ruler-extenders*) ; same as immediately above
  (set-ruler-extenders :all) ; every governing IF test rules a recursive call
  (set-ruler-extenders :lambdas) ; LET does not block termination analysis
  (set-ruler-extenders (cons :lambdas *basic-ruler-extenders*))
                                 ; same as immediately above
  (set-ruler-extenders '(f g)) ; termination analysis goes past calls of f, g

  General Form:
  (set-ruler-extenders val)
  ~ev[]
  where ~c[val] evaluates to one of ~c[:basic], ~c[:all], ~c[:lambdas], or a
  true list of symbols containing no keyword other than, optionally,
  ~c[:lambdas].~/

  When a recursive definition is submitted to ACL2 (in ~c[:]~ilc[logic] mode),
  the recursion must be proved to terminate; ~pl[defun].  More precisely, ACL2
  explores the ~ilc[IF] structure of the body of the definition to accumulate
  the tests that ``rule'' any given recursive call.  The following example
  reviews how this works.  Suppose that ~c[f] has already been defined.
  ~bv[]
    (defun g (x y)
      (declare (xargs :measure (+ (acl2-count x) (acl2-count y))))
      (if (consp x)
          (g (cdr x) y)
        (if (consp y)
            (f (g x (cdr y)))
          (f (list x y)))))
  ~ev[]
  ACL2 makes the following response to this proposed definition.  Notice that
  the ~c[:measure] proposed above must be proved to be an ACL2 ordinal ~-[]
  that is, to satisfy ~c[O-P] ~-[] and that the arguments to each recursive
  call must be smaller (in the sense of that measure and ~c[O<], which here
  reduces to the ordinary ~c[<] relation) than the formals under the assumption
  of the ruling ~c[IF] tests.  The first ~c[IMPLIES] term below thus
  corresponds to the recursive call ~c[(g (cdr x) y)], while the second
  corresponds to the recursive call ~c[(g x (cdr y))].
  ~bv[]
    For the admission of G we will use the relation O< (which is known
    to be well-founded on the domain recognized by O-P) and the measure
    (+ (ACL2-COUNT X) (ACL2-COUNT Y)).  The non-trivial part of the measure
    conjecture is

    Goal
    (AND (O-P (+ (ACL2-COUNT X) (ACL2-COUNT Y)))
         (IMPLIES (CONSP X)
                  (O< (+ (ACL2-COUNT (CDR X)) (ACL2-COUNT Y))
                      (+ (ACL2-COUNT X) (ACL2-COUNT Y))))
         (IMPLIES (AND (NOT (CONSP X)) (CONSP Y))
                  (O< (+ (ACL2-COUNT X) (ACL2-COUNT (CDR Y)))
                      (+ (ACL2-COUNT X) (ACL2-COUNT Y))))).
  ~ev[]
  Now consider the following alternate version of the above definition.
  ~bv[]
    (defun g (x y)
      (declare (xargs :measure (+ (acl2-count x) (acl2-count y))))
      (if (consp x)
          (g (cdr x) y)
        (f (if (consp y)
               (g x (cdr y))
             (list x y)))))
  ~ev[]
  The first test, ~c[(consp x)], still rules the first recursive call,
  ~c[(g (cdr x) y)].  And the negation of that test, namely
  ~c[(not (consp x))], still rules the second recursive call ~c[(g x (cdr y))].
  But the call of ~c[f] blocks the top-down exploration of the ~c[IF] structure
  of the body of ~c[g], so ~c[(consp y)] does not rule that second recursive
  call, which (again) is ~c[(g x (cdr y))].  As a result, ACL2 fails to admit
  the above definition.

  ~c[Set-ruler-extenders] is provided to overcome the sort of blocking
  described above.  Suppose for example that the following event is submitted:
  ~bv[]
    (set-ruler-extenders '(f))
  ~ev[]
  Then the alternate definition of ~c[g] above is admissible, because the call
  of ~c[f] no longer blocks the top-down exploration of the ~c[IF] structure of
  the body of ~c[g]: that is, ~c[(consp y)] becomes a ruler of the recursive
  call ~c[(g x (cdr y))].  In this case, we say that ~c[f] is a
  ``ruler-extender''.  The same result obtains if we first submit
  ~bv[]
    (set-ruler-extenders :all)
  ~ev[]
  as this removes all function calls as blockers of the top-down analysis.  In
  other words, with ~c[:all] it is the case that for every recursive call,
  every test argument of a superior call of ~c[IF] contributes a ruler of that
  recursive call.

  ACL2 handles ~ilc[LET] (and ~ilc[LET*]) expressions by translating them to
  ~c[LAMBDA] expressions (~pl[term]).  The next examples illustrates
  termination analysis involving such expressions.  First consider the
  following (admittedly inefficient) definition.
  ~bv[]
    (defun fact (n)
      (let ((k (if (natp n) n 0)))
        (if (equal k 0)
            1
          (* k (fact (+ -1 k))))))
  ~ev[]
  ACL2 translates the body of this definition to a ~c[LAMBDA] application,
  essentially:
  ~bv[]
    ((lambda (k)
       (if (equal k 0)
           1
         (* k (fact (+ -1 k)))))
     (if (natp n) n 0))
  ~ev[]
  As with the application of any function other than ~c[IF], the top-down
  termination analysis does not dive into arguments: the ~c[LAMBDA] blocks the
  continuation of the analysis into its argument.  But here, the argument of
  the ~c[LAMBDA] is ~c[(if (natp n) n 0)], which has no recursive calls to
  consider anyhow.  What is more interesting: ACL2 does continue its
  termination analysis into the body of the ~c[LAMBDA], in an environment
  binding the ~c[LAMBDA] formals to its actuals.  In this case, the termination
  analysis thus continues into the term
  ~bv[]
    (if (equal k 0)
        1
      (* k (fact (+ -1 k))))
  ~ev[]
  in the environment that binds ~c[k] to the term ~c[(if (natp n) n 0)].  Thus,
  the proof obligation is successfully discharged, as reported by ACL2:
  ~bv[]
    For the admission of FACT we will use the relation O< (which is known
    to be well-founded on the domain recognized by O-P) and the measure
    (ACL2-COUNT N).  The non-trivial part of the measure conjecture is

    Goal
    (IMPLIES (NOT (EQUAL (IF (NATP N) N 0) 0))
             (O< (ACL2-COUNT (+ -1 (IF (NATP N) N 0)))
                 (ACL2-COUNT N))).
    .....
    Q.E.D.

    That completes the proof of the measure theorem for FACT.
  ~ev[]

  But now consider the following definition, in which the recursion takes place
  inside the argument of the ~c[LAMBDA] rather than inside the ~c[LAMBDA]
  body.
  ~bv[]
    (defun app (x y)
      (let ((result (if (endp x)
                        y
                      (cons (car x)
                            (app (cdr x) y)))))
        (if (our-test result)
            result
          0)))
  ~ev[]
  Writing the body in ~c[LAMBDA] notation:
  ~bv[]
    ((lambda (result)
       (if (our-test result)
           result
         0))
     (if (endp x)
         y
       (cons (car x)
             (app (cdr x) y))))
  ~ev[]
  By default, the ~c[LAMBDA] call blocks the top-down termination analysis from
  proceeding into the term ~c[(if (endp x) ...)].  To solve this, one can
  submit the event:
  ~bv[]
    (set-ruler-extenders :lambdas)
  ~ev[]
  The above definition of ~c[app] is then admitted by ACL2, because the
  termination analysis is no longer blocked by the ~c[LAMBDA] call.

  The example just above illustrates that the heuristically-chosen measure is
  suitably sensitive to the ruler-extenders.  Specifically: that measure is the
  application of ~c[acl2-count] to the first formal parameter of the function
  that is tested along every branch of the relevant ~c[IF] structure (as
  determined by the rulers) and occurs as a proper subterm at the same argument
  position in every recursive call.  The heuristics for choosing the
  controller-alist for a ~ilc[definition] rule are similarly sensitive to the
  ruler-extenders (~pl[definition]).

  The remarks above for ~ilc[defun] ~il[events] are equally applicable when a
  definition sits inside a ~ilc[mutual-recursion] event, except of course that
  in this case, a ``recursive call'' is a call of any function being defined by
  that ~ilc[mutual-recursion] event.

  Rules of class ~c[:]~ilc[definition] are sensitive to ~c[set-ruler-extenders]
  in analogy to the case of ~c[defun] ~il[events].

  This macro generates a call
  ~c[(table acl2-defaults-table :ruler-extenders val)]
  and hence is ~ilc[local] to any ~il[books] and ~ilc[encapsulate] ~il[events]
  in which it occurs. ~l[acl2-defaults-table].  The current list of
  ruler-extenders may be obtained as
  ~bv[]
    (cdr (assoc-eq :ruler-extenders
         (table-alist 'acl2-defaults-table (w state))))
  ~ev[]
  or more conveniently, as:
  ~bv[]
    (default-ruler-extenders (w state))
  ~ev[]

  Note that evaluation of ~c[(set-ruler-extenders lst)], where ~c[lst]
  evaluates to a list, does not necessarily include the default ruler-extenders
  ~-[] i.e., those included for the argument, ~c[:basic] ~-[] which are the
  elements of the list constant ~c[*basic-ruler-extenders*], namely
  ~ilc[return-last] and ~ilc[mv-list].  You may, of course, include these
  explicitly in your list argument.

  We conclude our discussion by noting that the set of ruler-extenders can
  affect the induction scheme that is stored with a recursive definition.  The
  community book ~c[books/misc/misc2/ruler-extenders-tests.lisp] explains how
  induction schemes are derived in this case.  Consider the following example.
  ~bv[]
    (defun tree-of-nils-p (x)
      (if (consp x)
          (and (tree-of-nils-p (car x))
               (tree-of-nils-p (cdr x)))
        (null x)))
  ~ev[]
  The above definition generates the following induction scheme.  Note that
  ~c[(and u v)] expands to ~c[(if u v nil)], which explains why the term
  ~c[(tree-of-nils-p (car x))] rules the recursive call
  ~c[(tree-of-nils-p (cdr x))], resulting in the hypothesis
  ~c[(tree-of-nils-p (car x))] in the final conjunct below.
  ~bv[]
    (AND (IMPLIES (NOT (CONSP X)) (:P X))
         (IMPLIES (AND (CONSP X)
                       (NOT (TREE-OF-NILS-P (CAR X)))
                       (:P (CAR X)))
                  (:P X))
         (IMPLIES (AND (CONSP X)
                       (TREE-OF-NILS-P (CAR X))
                       (:P (CAR X))
                       (:P (CDR X)))
                  (:P X)))
  ~ev[]
  Now consider the following variant of the above definition, in which a call
  of the function ~c[identity] blocks the termination analysis.
  ~bv[]
    (defun tree-of-nils-p (x)
      (if (consp x)
          (identity (and (tree-of-nils-p (car x))
                         (tree-of-nils-p (cdr x))))
        (null x)))
  ~ev[]
  This time the induction scheme is as follows, since only the top-level ~c[IF]
  test contributes rulers to the termination analysis.
  ~bv[]
    (AND (IMPLIES (NOT (CONSP X)) (:P X))
         (IMPLIES (AND (CONSP X)
                       (:P (CAR X))
                       (:P (CDR X)))
                  (:P X)))
  ~ev[]
  But now suppose we first designate ~c[identity] as a ruler-extender.
  ~bv[]
  (set-ruler-extenders '(identity))
  ~ev[]
  Then the induction scheme generated for the both of the above variants of
  ~c[tree-of-nils-p] is the one shown for the first variant, which is
  reasonable because both definitions now produce essentially the same
  termination analysis.~/")

#+acl2-loop-only
(defmacro set-ruler-extenders (x)

; It seems a bit sad to evaluate x twice, but that seems kind of unavoidable if
; we are to use a table event to set the acl2-defaults-table, since WORLD is
; not available for the expression of that event.

  `(state-global-let*
    ((inhibit-output-lst (list* 'event 'summary (@ inhibit-output-lst))))
    (er-progn
     (chk-ruler-extenders ,x soft 'set-ruler-extenders (w state))
     (progn
       (table acl2-defaults-table :ruler-extenders
              (let ((x0 ,x))
                (case x0

; If keywords other than :ALL, :BASIC, and :LAMBDAS are supported, then also
; change get-ruler-extenders1.

                  (:all :all)
                  (:lambdas (cons :lambdas *basic-ruler-extenders*))
                  (:basic *basic-ruler-extenders*)
                  (otherwise x0))))
       (table acl2-defaults-table :ruler-extenders)))))

#-acl2-loop-only
(defmacro set-ruler-extenders (x)
  (declare (ignore x))
  nil)

#+acl2-loop-only
(defmacro set-irrelevant-formals-ok (x)

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

  allow irrelevant formals in definitions~/
  ~bv[]
  Examples:
  (set-irrelevant-formals-ok t)
  (set-irrelevant-formals-ok nil)
  (set-irrelevant-formals-ok :warn)
  ~ev[]
  The first example above allows irrelevant formals in definitions;
  ~pl[irrelevant-formals].  The second example disallows
  irrelevant formals; this is the default.  The third example allows
  irrelevant formals, but prints an appropriate warning.

  Note: This is an event!  It does not print the usual event summary
  but nevertheless changes the ACL2 logical ~il[world] and is so
  recorded.  Moreover, its effect is to set the ~ilc[acl2-defaults-table], and
  hence its effect is ~ilc[local] to the book or ~ilc[encapsulate] form
  containing it; ~pl[acl2-defaults-table].~/
  ~bv[]
  General Form:
  (set-irrelevant-formals-ok flg)
  ~ev[]
  where ~c[flg] is either ~c[t], ~c[nil], or ~c[:warn].~/

  :cited-by Programming"

  `(state-global-let*
    ((inhibit-output-lst (list* 'event 'summary (@ inhibit-output-lst))))
     (progn (table acl2-defaults-table :irrelevant-formals-ok ,x)
            (table acl2-defaults-table :irrelevant-formals-ok))))

#-acl2-loop-only
(defmacro set-irrelevant-formals-ok (x)
  (declare (ignore x))
  nil)

#+acl2-loop-only
(defmacro set-ignore-ok (x)

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

  allow unused formals and locals without an ~c[ignore] or ~c[ignorable] declaration~/
  ~bv[]
  Examples:
  (set-ignore-ok t)
  (set-ignore-ok nil)
  (set-ignore-ok :warn)
  ~ev[]
  The first example above allows unused formals and locals, i.e., variables
  that would normally have to be ~il[declare]d ~c[ignore]d or ~c[ignorable].
  The second example disallows unused formals and locals; this is the default.
  The third example allows them, but prints an appropriate warning.

  Note: This is an event!  It does not print the usual event summary
  but nevertheless changes the ACL2 logical ~il[world] and is so
  recorded.  Moreover, its effect is to set the ~ilc[acl2-defaults-table], and
  hence its effect is ~ilc[local] to the book or ~ilc[encapsulate] form
  containing it; ~pl[acl2-defaults-table].~/
  ~bv[]
  General Form:
  (set-ignore-ok flg)
  ~ev[]
  where ~c[flg] is either ~c[t], ~c[nil], or ~c[:warn].

  One might find this event useful when one is generating function
  definitions by an automated procedure, when that procedure does not
  take care to make sure that all formals are actually used in the
  definitions that it generates.

  Note:  Defun will continue to report irrelevant formals even if
  ~c[:set-ignore-ok] has been set to ~c[t], unless you also use
  ~ilc[set-irrelevant-formals-ok] to instruct it otherwise.~/

  :cited-by Programming"

  `(state-global-let*
    ((inhibit-output-lst (list* 'event 'summary (@ inhibit-output-lst))))
     (progn (table acl2-defaults-table :ignore-ok ,x)
            (table acl2-defaults-table :ignore-ok))))

#-acl2-loop-only
(defmacro set-ignore-ok (x)
  (declare (ignore x))
  nil)

#-acl2-loop-only
(defmacro set-inhibit-warnings! (&rest x)
  (declare (ignore x))
  nil)

(table inhibit-warnings-table nil nil
       :guard
       (stringp key))

#+acl2-loop-only
(defmacro set-inhibit-warnings! (&rest lst)

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

  control warnings non-~ilc[local]ly~/

  Please ~pl[set-inhibit-warnings], which is the same as
  ~c[set-inhibit-warnings!]  except that the latter is not ~ilc[local] to the
  ~ilc[encapsulate] or the book in which it occurs.  Probably
  ~il[set-inhibit-warnings] is to be preferred unless you have a good reason
  for wanting to export the effect of this event outside the enclosing
  ~ilc[encapsulate] or book.~/~/"

  (declare (xargs :guard (string-listp lst)))
  `(state-global-let*
    ((inhibit-output-lst (list* 'event 'summary (@ inhibit-output-lst))))
    (progn (table inhibit-warnings-table nil ',(pairlis$ lst nil) :clear)
           (value-triple ',lst))))

(defmacro set-inhibit-warnings (&rest lst)

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

  control warnings~/
  ~bv[]
  Examples:
  (set-inhibit-warnings \"theory\" \"use\")
  ~ev[]
  Note: This is an event!  It does not print the usual event summary
  but nevertheless changes the ACL2 logical ~il[world] and is so
  recorded.  It is ~ilc[local] to the book or ~ilc[encapsulate] form in which it
  occurs; ~pl[set-inhibit-warnings!] for a corresponding non-~ilc[local]
  event.  Indeed, ~c[(set-inhibit-warnings ...)] is equivalent to
  ~c[(local (set-inhibit-warnings! ...))].~/
  ~bv[]
  General Form:
  (set-inhibit-warnings string1 string2 ...)
  ~ev[]
  where each string is considered without regard to case.  This macro is
  equivalent to ~c[(local (table inhibit-warnings-table nil 'lst :clear))],
  where ~c[lst] is the list of strings supplied.  This macro is an
  event (~pl[table]), but no output results from a ~c[set-inhibit-warnings]
  event.

  ACL2 prints warnings that may, from time to time, seem excessive to
  experienced users.  Each warning is ``labeled'' with a string identifying the
  type of warning.  Consider for example
  ~bv[]
  ACL2 Warning [Use] in ( THM ...):  It is unusual to :USE ....
  ~ev[]
  Here, the label is \"Use\".  The argument list for ~c[set-inhibit-warnings]
  is a list of such labels, each of which is a string.  Any warning is
  suppressed if its label is a member of this list, where case is ignored, .
  Thus, for example, the warning above will not be printed after a call of
  ~c[set-inhibit-warnings] that contains the string, ~c[\"Use\"] (or any string
  that is ~ilc[string-equal] to ~c[\"Use\"], such as ~c[\"use\"] or
  ~c[\"USE\"]).  In summary: the effect of this event is to suppress any
  warning whose label is a member of the given argument list, where case is
  ignored.

  The list of currently inhibited warnings is the list of keys in the
  ~il[table] named ~c[inhibit-warnings-table].  (The values in the table are
  irrelevant.)  One way to get that value is to get the result from evaluating
  the following form: ~c[(table-alist 'inhibit-warnings-table (w state))].  Of
  course, if warnings are inhibited overall ~-[] ~pl[set-inhibit-output-lst]
  ~-[] then this value is entirely irrelevant."

  `(local (set-inhibit-warnings! ,@lst)))

(defmacro set-inhibit-output-lst (lst)

; In spite of the documentation for this macro, 'warning and 'warning! are
; handled completely independently by the ACL2 warning mechanism, which looks
; for 'warning or 'warning! in the value of state global 'inhibit-output-lst.
; Set-inhibit-output-lst adds 'warning to this state global whenever it adds
; 'warning.  If the user sets inhibit-output-lst directly using f-put-global or
; assign, then including 'warning! will not automatically include 'warning.

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

  control output~/
  ~bv[]
  Examples:
  (set-inhibit-output-lst '(warning))
  (set-inhibit-output-lst '(proof-tree prove proof-checker))
  (set-inhibit-output-lst *valid-output-names*) ; inhibit all prover output
  :set-inhibit-output-lst (proof-tree prove)~/

  General Form:
  (set-inhibit-output-lst lst)
  ~ev[]
  where ~c[lst] is a form (which may mention ~ilc[state]) that evaluates
  to a list of names, each of which is the name of one of the
  following ``kinds'' of output produced by ACL2.
  ~bv[]
    error          error messages
    warning        warnings other than those related to soundness
    warning!       warnings (of all degrees of importance)
    observation    observations
    prove          commentary produced by the theorem prover
    proof-checker  commentary produced by the proof-checker
    event          non-proof commentary produced by events such as defun
                   and encapsulate
    expansion      commentary produced by make-event expansion
    summary        the summary at the successful conclusion of an event
    proof-tree     proof-tree output
  ~ev[]
  It is possible to inhibit each kind of output by putting the
  corresponding name into ~c[lst].  For example, if ~c['warning] is
  included in (the value of) ~c[lst], then no warnings are printed
  except those related to soundness, e.g., the inclusion of an
  uncertified book.  Note that ~il[proof-tree] output is affected by
  ~c[set-inhibit-output-lst]; ~pl[proof-tree].

  ~l[with-output] for a variant of this utility that can be used in
  ~il[books].  Also ~pl[set-inhibit-warnings] for how to inhibit individual
  warning types and ~pl[set-inhibited-summary-types] for how to inhibit
  individual parts of the summary.

  Printing of events on behalf of ~ilc[certify-book] and ~ilc[encapsulate] is
  inhibited when both ~c['event] and ~c['prove] belong to ~c[lst].  Otherwise,
  printing of events is controlled by the ~ilc[ld] special
  ~ilc[ld-pre-eval-print].

  ~em[Note for advanced users.]  By including ~c[warning!] in ~c[lst], you are
  automatically including ~c[warning] as well: all warnings will be inhibited.
  This is not the case if you modify value of state global variable
  ~c['inhibit-output-lst] directly (with ~ilc[assign] or ~c[f-put-global]);
  then, if you include ~c[warning!] but not ~c[warning], then warnings not
  related to soundness will still be printed (which is probably not what was
  intended)."

  `(let ((ctx 'set-inhibit-output-lst))
     (er-let* ((lst (chk-inhibit-output-lst ,lst ctx state)))
              (pprogn (f-put-global 'inhibit-output-lst lst state)
                      (value lst)))))

(defmacro set-inhibited-summary-types (lst)

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

  control which parts of the summary are printed~/
  ~bv[]
  Example:
  (set-inhibited-summary-types '(rules time))
  ~ev[]
  Note: This is not an event.  Rather, it changes the ~il[state], in analogy to
  ~ilc[set-inhibit-output-lst].~/
  ~bv[]
  General Form:
  (set-inhibited-summary-types form)
  ~ev[]
  where form evaluates to a true-list of symbols, each of which is among the
  values of the constant ~c[*summary-types*], i.e.: ~c[header], ~c[form],
  ~c[rules], ~c[hint-events] ~c[warnings], ~c[time], ~c[steps], ~c[value], and
  ~c[splitter-rules].  Each specified type inhibits printing of the
  corresponding portion of the summaries printed at the conclusions of
  ~il[events], where ~c[header] refers to an initial newline followed by the
  line containing just the word ~c[Summary].

  Note the distinction between ~c[rules] and ~c[hint-events].  ~c[Rules]
  provides a record of automatic rule usage by the prover, while
  ~c[hint-events] shows the names of events given to ~c[:USE] or ~c[:BY]
  ~il[hints], as well as ~il[clause-processor] functions given to
  ~c[:CLAUSE-PROCESSOR] hints that have an effect on the proof.

  Also ~pl[set-inhibit-output-lst].  Note that ~c[set-inhibited-summary-types]
  has no effect when ~c[summary] is one of the types inhibited by
  ~il[set-inhibit-output-lst], because in that case none of the summary will be
  printed.

  To control summary types for a single event, ~pl[with-output]."

  `(let ((lst ,lst)
         (ctx 'set-inhibited-summary-types))
     (cond ((not (true-listp lst))
            (er soft ctx
                "The argument to set-inhibited-summary-types must evaluate ~
                  to a true-listp, unlike ~x0."
                lst))
           ((not (subsetp-eq lst *summary-types*))
            (er soft ctx
                "The argument to set-inhibited-summary-types must evaluate ~
                  to a subset of the list ~X01, but ~x2 contains ~&3."
                *summary-types*
                nil
                lst
                (set-difference-eq lst *summary-types*)))
           (t (pprogn (f-put-global 'inhibited-summary-types lst state)
                      (value lst))))))

#+acl2-loop-only
(defmacro set-state-ok (x)

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

  allow the use of STATE as a formal parameter~/

  Note: This is an event!  It does not print the usual event summary
  but nevertheless changes the ACL2 logical ~il[world] and is so
  recorded.

  In brief:  The variable symbol ~ilc[STATE] has an unusual status in ACL2.
  In order to use it, you either need to issue ~c[:set-state-ok t], as
  we explain below, or you need to declare it to be a ~il[stobj], as
  explained elsewhere (~pl[declare-stobjs]).  Now we explain in
  more detail.

  Because the variable symbol ~ilc[STATE] denotes the ``current ACL2
  state,'' ACL2 treats the symbol very restrictively when it occurs as
  a formal parameter of a defined function.  The novice user, who is
  unlikely to be aware of the special status of that symbol, is
  likely to be confused when error messages about ~c[STATE] are printed
  in response to the innocent choice of that symbol as a formal
  variable.  Therefore the top-level ACL2 loop can operate in a mode
  in which ~ilc[STATE] is simply disallowed as a formal parameter.~/

  For a discussion of ~c[STATE], ~l[state] and ~pl[stobj].  Roughly speaking, at
  the top-level, the ``current ACL2 state'' is denoted by the variable
  symbol ~c[STATE].  Only the current state may be passed into a
  function expecting a state as an argument.  Furthermore, the name of
  the formal parameter into which the current state is passed must be
  ~c[STATE] and nothing but the current state may be passed into a
  formal of that name.  Therefore, only certain access and change
  functions can use that formal ~-[] namely those with a ~c[STATE] formal
  ~-[] and if any such function produces a new state it becomes the
  ``current state'' and must be passed along in the ~c[STATE] position
  thereafter.  Thus, ACL2 requires that the state be single-threaded.
  This, in turn, allows us to represent only one state at a time and
  to produce new states from it destructively in a von Neumaneque
  fashion.  The syntactic restrictions on the variable ~c[STATE] are
  enforced by the translate mechanism (~pl[trans] and ~pl[term]) when
  terms are read.

  To prevent the novice user from seeing messages prohibiting certain
  uses of the variable symbol ~C[STATE] ACL2 has a mode in which it
  simply disallows the use of that symbol as a formal parameter.  Use of
  the symbol causes a simple error message.  The system is initially
  in that mode.

  To get out of that mode, execute:
  ~bv[]
  :set-state-ok t ;;; or, (set-state-ok t)
  ~ev[]
  It is not recommended that you do this until you have read the
  documentation of ~ilc[STATE].

  To enter the mode in which use of ~c[state] is prohibited as a formal
  parameter, do:
  ~bv[]
  :set-state-ok nil
  ~ev[]

  The mode is stored in the defaults table, ~l[acl2-defaults-table].
  Thus, the mode may be set ~ilc[local]ly in books.~/

  :cited-by programming
  "

  `(state-global-let*
    ((inhibit-output-lst (list* 'event 'summary (@ inhibit-output-lst))))
    (progn (table acl2-defaults-table :state-ok ,x)
           (table acl2-defaults-table :state-ok))))

#-acl2-loop-only
(defmacro set-state-ok (x)
  (declare (ignore x))
  nil)

; Rockwell Addition:  This is the standard litany of definitions supporting
; a new acl2-defaults-table entry.  The doc string explains what it is all
; about.

#+acl2-loop-only
(defmacro set-let*-abstractionp (x)

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

  to shorten many prettyprinted clauses~/

  Note: This is an event!  It does not print the usual event summary
  but nevertheless changes the ACL2 logical ~il[world] and is so
  recorded.  Moreover, its effect is to set the ~ilc[acl2-defaults-table], and
  hence its effect is ~ilc[local] to the book or ~ilc[encapsulate] form
  containing it; ~pl[acl2-defaults-table].

  When this flag is set to ~c[t], subterms that occur more than once in
  a clause are abstracted away with ~ilc[let*], generally shortening
  the displayed size of the clauses.  This flag only affects how
  clauses are printed.  It does not change what terms the theorem
  prover manipulates.~/

  ~bv[]
  :set-let*-abstractionp t ;;; or, (set-let*-abstractionp t)
  ~ev[]
  will cause the prettyprinter to do ``let* abstraction'' on clauses
  before they are printed.  The algorithm finds the maximal
  multiply-occuring subterm and extracts it, binding it to some new
  variable and replacing its occurrences by that variable.  This produces
  a ~c[let*] form.  This process is iterated until no subterm occurs more
  than once.  This process generally takes a little time, but less time
  than to print large clauses.  The process can greatly reduce the amount of
  text produced by the prover.

  THIS ONLY AFFECTS HOW THE CLAUSES ARE PRINTED!  The unabstracted
  clauses are manipulated by the theorem prover.

  ~bv[]
  :set-let*-abstractionp nil
  ~ev[]
  restores normal clause printing.

  The mode is stored in the defaults table, ~l[acl2-defaults-table].
  Thus, the mode may be set locally in books."

  `(state-global-let*
    ((inhibit-output-lst (list* 'event 'summary (@ inhibit-output-lst))))
    (progn (table acl2-defaults-table :let*-abstractionp ,x)
           (table acl2-defaults-table :let*-abstractionp))))

#-acl2-loop-only
(defmacro set-let*-abstractionp (x)
  (declare (ignore x))
  nil)

(defmacro set-let*-abstraction (x)

; Usually the names of our set utilities do not end in "p".  We leave
; set-let*-abstractionp for backward compatibility, but we add this version for
; consistency.

  `(set-let*-abstractionp ,x))

(defun let*-abstractionp (state)

; This function returns either nil or else a non-nil symbol in the current
; package.

  (declare (xargs :mode :program))
  (and (cdr (assoc-eq :let*-abstractionp
                      (table-alist 'acl2-defaults-table (w state))))
       (pkg-witness (current-package state))))

; WARNING: If you change the value of *initial-backchain-limit*, be sure
; to change the reference to it in (deflabel backchain-limit ...) and
; (defmacro set-backchain-limit ...).

(defconst *initial-backchain-limit* '(nil nil))

(defconst *initial-default-backchain-limit* '(nil nil))

#+acl2-loop-only
(defmacro set-backchain-limit (limit)

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

  sets the backchain-limit used by the type-set and rewriting mechanisms~/

  Note: This is an event!  It does not print the usual event summary
  but nevertheless changes the ACL2 logical ~il[world] and is so
  recorded.  Moreover, its effect is to set the ~ilc[acl2-defaults-table], and
  hence its effect is ~ilc[local] to the book or ~ilc[encapsulate] form
  containing it; ~pl[acl2-defaults-table].

  This event sets the global ~ilc[backchain-limit] used by the ACL2 type-set
  and rewriting mechanisms.  Its value may be a cons whose car and cdr are each
  either ~c[nil] or a non-negative integer.  Its value ~c[x] may also be
  ~c[nil] or a non-negative integer, which is treated as a cons whose car and
  cdr are both ~c[x].

  The car is used to limit backchaining used by the ACL2 type-set mechanism,
  while the cdr is used to limit backchaining used by the rewriting mechanism.
  ~l[backchain-limit] for details about how backchain-limits are used.  Rewrite
  backchain limits may also be installed at the level of hints; ~pl[hints] for
  a discussion of ~c[:backchain-limit-rw].~/

  ~bv[]
  :set-backchain-limit nil  ; do not impose any additional limits
  :set-backchain-limit 0    ; allow only type-set reasoning for rewriting
                            ; hypotheses
  :set-backchain-limit 500  ; allow backchaining to a depth of no more
                            ; than 500 for rewriting hypotheses
  (set-backchain-limit 500) ; same as above
  :set-backchain-limit (500 500)
                            ; same as above
  (set-backchain-limit '(500 500))
                            ; same as above
  (set-backchain-limit '(3 500))
                            ; allow type-set backchaining to a depth of no more
                            ; than 3 and rewriter backchaining to a depth of no
                            ; more than 500

  ~ev[]
  The default limit is ~c[(nil nil)]."

  `(state-global-let*
    ((inhibit-output-lst (list* 'event 'summary (@ inhibit-output-lst))))
    (progn (table acl2-defaults-table :backchain-limit
                  (let ((limit ,limit))
                    (if (atom limit)
                        (list limit limit)
                      limit)))
           (table acl2-defaults-table :backchain-limit))))

#-acl2-loop-only
(defmacro set-backchain-limit (limit)
  (declare (ignore limit))
  nil)

(defun backchain-limit (wrld flg)

  ":Doc-Section Miscellaneous

  limiting the effort expended on relieving hypotheses~/

  Before ACL2 can apply a rule with hypotheses, it must establish that the
  hypotheses are true.  (We ignore the relaxing of this requirement afforded by
  ~ilc[case-split]s and ~ilc[force]d hypotheses.)  ACL2 typically establishes
  each hypothesis by backchaining ~-[] instantiating the hypothesis and then
  rewriting it recursively.  Here we describe how ACL2 allows the user to limit
  backchaining.  At the end, below, we describe the function
  ~ilc[backchain-limit].~/

  Each hypothesis of a ~ilc[rewrite], ~ilc[meta], ~ilc[linear], or
  ~ilc[type-prescription] rule is assigned a backchain-limit when the rule is
  stored.  By default, this limit is ~c[nil], denoting infinity (no limit).
  However, the value used for the default may be set to a non-negative
  integer (or to ~c[nil]) by the user; ~pl[set-default-backchain-limit].  The
  default is overridden when a ~c[:backchain-limit-lst] is supplied explicitly
  with the rule; ~pl[rule-classes].  The number of recursive applications of
  backchaining starting with the hypothesis of a rule is limited to the
  backchain-limit associated with that hypothesis.

  Moreover, the user may set global backchain-limits that limit the total
  backchaining depth.  ~l[set-backchain-limit].  One limit is for the use of
  ~ilc[rewrite], ~ilc[meta], and ~ilc[linear] rules, while the other limit is
  for so-called ``~il[type-set] reasoning'', which uses rules of class
  ~ilc[type-prescription] rules.  The two limits operate independently.  Below,
  we discuss the first kind of backchain limits, i.e., for other than
  ~ilc[type-prescription] rules, except as otherwise indicated; but the
  mechanism for those rules is similar.

  Below we lay out the precise sense in which a global backchain-limit
  interacts with the backchain-limits of individual rules in order to limit
  backchaining.  But first we note that when further backchaining is
  disallowed, ACL2 can still prove a hypothesis in a given context by using
  that contextual information.  In fact, ~il[type-set] reasoning may be
  used (except that a weaker version of it is used in the second case above,
  i.e., where we are already doing type-set reasoning).  Thus, the relieving of
  hypotheses may be limited to the use of contextual information (without
  backchaining, i.e., without recursively rewriting hypotheses) by executing
  ~c[:set-backchain-limit 0].

  Recall that there are two sorts of backchain limits: those applied to
  hypotheses of individual rules, as assigned by their ~c[:]~ilc[rule-classes]
  or else taken from the default (~pl[set-default-backchain-limit]); and the
  global limit, initially ~c[nil] (no limit) but settable with
  ~c[:]~ilc[set-backchain-limit].  Here is how these two types of limits
  interact to limit backchaining, i.e., recursive rewriting of hypotheses.
  ACL2 maintains a current backchain limit, which is the limit on the depth of
  recursive calls to the rewriter, as well as a current backchain depth, which
  is initially 0 and is incremented each time ACL2 backchains (and is
  decremented when a backchain completes).  When ACL2 begins to rewrite a
  literal (crudely, one of the ``top-level'' terms of the goal currently being
  worked on), it sets the current backchain-limit to the global value, which is
  initially ~c[nil] but can be set using ~c[:]~ilc[set-backchain-limit].  When
  ACL2 is preparing to relieve a hypothesis by backchaining (hence, after it
  has already tried type-set reasoning), it first makes sure that the current
  backchain limit is greater than the current backchain depth.  If not, then it
  refuses to relieve that hypothesis.  Otherwise, it increments the current
  backchain depth and calculates a new current backchain-limit by taking the
  minimum of two values: the existing current backchain-limit, and the sum of
  the current backchain depth and the backchain-limit associated with the
  hypothesis.  Thus, ACL2 only modifies the current backchain-limit if it is
  necessary to decrease that limit in order to respect the backchain limit
  associated with the hypothesis.

  We illustrate with the following examples.

  ~bv[]
  ; We stub out some functions so that we can reason about them.

  (defstub p0 (x) t)
  (defstub p1 (x) t)
  (defstub p2 (x) t)
  (defstub p3 (x) t)

  ; Initially, the default-backchain-limit is nil, or infinite.

  (defaxiom p2-implies-p1-limitless
    (implies (p2 x)
             (p1 x)))

  ; The following rule will have a backchain-limit of 0.

  (defaxiom p1-implies-p0-limit-0
    (implies (p1 x)
             (p0 x))
    :rule-classes ((:rewrite :backchain-limit-lst 0)))

  ; We have (p2 x) ==> (p1 x) ==> (p0 x).  We wish to establish that
  ; (p2 x) ==> (p0 x).  Normally, this would be no problem, but here
  ; we fail because ACL2 cannot establish (p0 x) by type-set reasoning
  ; alone.

  (thm
    (implies (p2 x)
             (p0 x)))

  ; We set the default-backchain-limit (for rewriting) to 1.

  :set-default-backchain-limit 1

  ; The following is more powerful than p1-implies-p0-limit-0
  ; because it can use rewrite rules to establish (p1 x).

  (defaxiom p1-implies-p0-limit-1
    (implies (p1 x)
             (p0 x)))

  ; This theorem will succeed:

  (thm
    (implies (p2 x)
             (p0 x)))

  ; We return the default-backchain-limit to its initial value.

  :set-default-backchain-limit nil

  ; Here is our last axiom.

  (defaxiom p3-implies-p2-limitless
    (implies (p3 x)
             (p2 x)))

  ; We now have (p3 x) ==> (p2 x) ==> (p1 x) ==> (p0 x).  However the
  ; rule p1-implies-p0-limit-1 has a backchain-limit of 1; hence we
  ; are not allowed to backchain far enough back to use
  ; p3-implies-p2-limitless.  We therefore lose.

  (defthm will-fail
    (implies (p3 x)
             (p0 x)))
  ~ev[]

  Finally, we remark that to see the current global backchain-limits, issue the
  following commands.
  ~bv[]
  (backchain-limit wrld :ts) ; backchain limit for type-set reasoning
  (backchain-limit wrld :rewrite) ; backchain limit for rewriting
  ~ev[]"

  (declare (xargs :guard
                  (and (member-eq flg '(:ts :rewrite))
                       (plist-worldp wrld)
                       (alistp (table-alist 'acl2-defaults-table wrld))
                       (true-listp (assoc-eq :backchain-limit
                                             (table-alist 'acl2-defaults-table
                                                          wrld))))))
  (let ((entry (or (cdr (assoc-eq :backchain-limit
                                  (table-alist 'acl2-defaults-table wrld)))
                   *initial-backchain-limit*)))
    (if (eq flg :ts)
        (car entry)
      (cadr entry))))

#+acl2-loop-only
(defmacro set-default-backchain-limit (limit)

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

  sets the default backchain-limit used when admitting a rule~/

  Note: This is an event!  It does not print the usual event summary
  but nevertheless changes the ACL2 logical ~il[world] and is so
  recorded.  Moreover, its effect is to set the ~ilc[acl2-defaults-table], and
  hence its effect is ~ilc[local] to the book or ~ilc[encapsulate] form
  containing it; ~pl[acl2-defaults-table].

  This event sets the default ~ilc[backchain-limit] used when a new
  ~ilc[rewrite], ~ilc[linear], ~ilc[meta], or ~ilc[type-prescription] rule is
  admitted.  Its value may be a two-element list whose elements are each either
  ~c[nil] or a non-negative integer.  Its value ~c[x] may also be ~c[nil] or a
  non-negative integer, which is treated as the two element list ~c[(x x)].

  The first element of the list is used to limit backchaining for a rule of
  class ~ilc[type-prescription] while the second element is used to limit
  backchaining for the other three classes of rules mentioned above.
  ~l[backchain-limit] for details about how backchain-limits are used.  The
  examples below assume that a new rule doesn't itself specify a value for
  ~c[:backchain-limit-lst].~/

  ~bv[]
  :set-default-backchain-limit nil  ; do not impose backchain limits for the
                                    ; rule
  :set-default-backchain-limit 0    ; allow only type-set reasoning for
                                    ; relieving a new rule's hypotheses
  :set-default-backchain-limit 500  ; allow backchaining through a new rewrite,
                                    ; linear, or meta rule's hypotheses to a
                                    ; depth of no more than 500
  (set-default-backchain-limit 500) ; same as above
  :set-default-backchain-limit (nil 500)
                                    ; same as above
  (set-default-backchain-limit '(nil 500))
                                    ; same as above
  (set-default-backchain-limit '(3 500))
                                    ; for a new :type-prescription rule, allow
                                    ; type-set backchaining to a depth
                                    ; of no more than 3; for a new
                                    ; rule of class :rewrite, :linear,
                                    ; or :meta, allow backchaining to
                                    ; a depth of no more than 50
  (set-default-backchain-limit '(nil 500))
                                    ; do not limit backchaining for a
                                    ; new :type-prescription rule; for
                                    ; a new rule of class :rewrite,
                                    ; :linear, or :meta, allow
                                    ; backchaining to a depth of no
                                    ; more than 50
  ~ev[]

  The initial default backchain-limit is ~c[nil]."

  `(state-global-let*
    ((inhibit-output-lst (list* 'event 'summary (@ inhibit-output-lst))))
    (progn (table acl2-defaults-table :default-backchain-limit
                  (let ((limit ,limit))
                    (if (atom limit)
                        (list limit limit)
                      limit)))
           (table acl2-defaults-table :default-backchain-limit))))

#-acl2-loop-only
(defmacro set-default-backchain-limit (limit)
  (declare (ignore limit))
  nil)

(defun default-backchain-limit (wrld flg)
  ":Doc-Section Miscellaneous

  specifying the backchain limit for a rule~/

  ~l[backchain-limit].~/

  The initial value is ~c[(nil nil)].  To inspect the current value (as
  explained elsewhere; ~pl[backchain-limit]):
  ~bv[]
  (default-backchain-limit wrld :ts) ; for type-set reasoning
  (default-backchain-limit wrld :rewrite) ; for rewriting
  ~ev[]"

  (declare (xargs :guard
                  (and (member-eq flg '(:ts :rewrite))
                       (plist-worldp wrld)
                       (alistp (table-alist 'acl2-defaults-table wrld))
                       (true-listp (assoc-eq :default-backchain-limit
                                             (table-alist 'acl2-defaults-table
                                                          wrld))))))
  (let ((entry (or (cdr (assoc-eq :default-backchain-limit
                                  (table-alist 'acl2-defaults-table wrld)))
                   *initial-default-backchain-limit*)))
    (if (eq flg :ts)
        (car entry)
      (cadr entry))))

; Essay on Step-limits

; We assume familiarity with step-limits at the user level; see :DOC
; set-prover-step-limit and see :DOC with-prover-step-limit.

; Step-limits are managed through the following three global data structures.

; - (f-get-global 'last-step-limit state)

; This value records the current step-limit (updated from time to time, but not
; constantly within the rewriter).  In a compound event, this decreases as
; events are executed, except for those within a call of with-prover-step-limit
; whose flag is t (see :DOC with-prover-step-limit).

; - (table acl2-defaults-table :step-limit)

; The table value supplies a starting step-limit for top-level calls that are
; not in the scope of with-prover-step-limit, hence not in the scope of
; with-ctx-summarized (which calls save-event-state-globals, which calls
; with-prover-step-limit with argument :START).

; - (f-get-global 'step-limit-record state)

; This global is bound whenever entering the scope of with-prover-step-limit.
; It stores information about the step-limit being established for that scope,
; including the starting value to use for state global 'last-step-limit.  That
; value is the current value of that state global, unless a call of
; set-prover-step-limit has set a different limit in the same context.

; We may write more if that becomes necessary, but we hope that the summary
; above provides sufficient orientation to make sense of the implementation.

; NOTE: If you change the implementation of step-limits, be sure to LD and
; also certify community book books/misc/misc2/step-limits.lisp.

; When writing a recursive function that uses step-limits, for which you are
; willing to have a return type of (mv step-limit erp val state):
; * give it a step-limit arg;
; * pass that along, for example with sl-let if that is convenient;
; * decrement the step-limit when you deem that a "step" has been taken;
; * call the top-level entry with the step-limit arg set to a fixnum limit that
;   you prefer, for example with (initial-step-limit wrld state) or
;   *default-step-limit*
; * wrap the top-level call in a catch-step-limit as illustrated in
;   prove-loop1

; See also catch-step-limit for more about how step-limits are managed.

(defun step-limit-from-table (wrld)

; We return the top-level prover step-limit, with of course can be overridden
; by calls of with-prover-step-limit.

  (declare (xargs :guard
                  (and (plist-worldp wrld)
                       (alistp (table-alist 'acl2-defaults-table wrld))
                       (let ((val (cdr (assoc-eq :step-limit
                                                 (table-alist 'acl2-defaults-table
                                                              wrld)))))
                         (or (null val)
                             (and (natp val)
                                  (<= val *default-step-limit*)))))))
  (or (cdr (assoc-eq :step-limit
                     (table-alist 'acl2-defaults-table wrld)))
      *default-step-limit*))

#-acl2-loop-only
(defparameter *step-limit-error-p*

; The value of this special variable is nil when not in the scope of
; catch-step-limit.  When in such a scope, the value is t unless a throw has
; occurred to tag 'step-limit-tag, in which case the value is 'error.

  nil)

#+acl2-loop-only
(defmacro set-prover-step-limit (limit)

; See the Essay on Step-limits.

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

  sets the step-limit used by the ACL2 prover~/

  This event provides a way to limit the number of so-called ``prover steps''
  permitted for an event.  ~l[with-prover-step-limit] for a way to specify the
  limit on prover steps for a single event, rather than globally.  For a
  related utility based on time instead of prover steps,
  ~pl[with-prover-time-limit].  For examples of how step limits work, see the
  community book ~c[books/misc/misc2/step-limits.lisp].  For a utility that
  returns an indicator of the number of prover steps most recently taken,
  ~pl[last-prover-steps].

  Note: This is an event!  It does not print the usual event summary
  but nevertheless changes the ACL2 logical ~il[world] and is so
  recorded.  Moreover, its effect is to set the ~ilc[acl2-defaults-table], and
  hence its effect is ~ilc[local] to the book or ~ilc[encapsulate] form
  containing it; ~pl[acl2-defaults-table].

  ~bv[]
  Example Forms:
  (set-prover-step-limit *default-step-limit*) ; no limit on prover steps
  (set-prover-step-limit nil)   ; abbreviation for the form just above
  (set-prover-step-limit 10000) ; allow at most 10,000 prover steps per event~/

  General Form:
  (set-prover-step-limit expr)
  ~ev[]
  where ~c[expr] evaluates either to ~c[nil] or else to a natural number not
  exceeding the value of ~c[*default-step-limit*].  If that value is ~c[nil] or
  the value of ~c[*default-step-limit*], then no default limit is placed on the
  number of prover ``steps'' (see below) during processing of an event.
  Otherwise, that value is the maximum number of prover steps permitted before
  an error occurs.

  This event specifies the limit on the number of ``steps'' counted by the ACL2
  prover during processing of an event.  Currently, a step is counted for each
  call of the system functions ~c[rewrite] and ~c[expand-abbreviations].
  However, the steps counted may change in future releases of ACL2, so users
  would probably be well served by avoiding the assumption that only the above
  two calls are counted as prover steps.

  Depending on the computer you are using, you may have less than a half-hour
  of time before the number of prover steps exceeds the maximum step-limit,
  which is one less than the value of ~c[*default-step-limit*].  Note however
  the exception stated above: if the ``limit'' is ~c[nil] or is the value of
  ~c[*default-step-limit*], then no limit is imposed.

  There is at best a loose connection between the counting of steps and
  ~ilc[with-prover-time-limit].  In particular, for a call of ~c[mfc-rw] or any
  ~c[mfc-] function (~pl[extended-metafunctions]), the steps taken during that
  call are forgotten when returning from that call.

  The limit is relevant for every event, as well as for calls of ~ilc[thm] and
  ~ilc[certify-book] ~-[] and more generally, to any form that creates a
  ``summary context'' to print the usual event summary.  The limit is also put
  in force when entering the ~il[proof-checker].  A call of
  ~c[set-prover-step-limit] applies to each subsequent form unless the call of
  ~c[set-prover-step-limit] is within a summary context, in which case its
  effect disappears when exiting that summary context.

  The limit applies to each event, not just ``atomic'' events.  Consider the
  following example.
  ~bv[]
  (set-prover-step-limit 500)

  (encapsulate
    ()
    (defthm lemma-1 ; takes 380 steps
      (equal (append (append x y) z) (append x y z))
      :rule-classes nil)
    (defthm lemma-2 ; would take 319 steps
      (equal (len (append x y)) (+ (len x) (len y)))
      :rule-classes nil))
  ~ev[]
  The first ~ilc[defthm] event, ~c[lemma-1] takes 380 steps (as of this
  writing), as shown in the summary:
  ~bv[]
  Prover steps counted:  380
  LEMMA-1
  ~ev[]
  The second ~ilc[defthm] event, ~c[lemma-2], takes 319 steps (as of this
  writing) when evaluated at the top level.  However, in the context above, 380
  steps of the available 500 steps (from the ~c[set-prover-step-limit] event
  above) have already been taken under the above ~ilc[encapsulate] event.
  Thus, when the number of steps would exceed 120, the proof of ~c[lemma-2] is
  aborted:
  ~bv[]
  ACL2 Error in STEP-LIMIT:  The prover step-limit, which is 120 in the
  current context, has been exceeded.  See :DOC set-prover-step-limit.
  ~ev[]
  The summary for ~c[lemma-2] reflects that situation:
  ~bv[]
  Prover steps counted:  More than 120
  ~ev[]
  The summary for the ~ilc[encapsulate] event then indicates that the
  available steps for that event have also been exceeded:
  ~bv[]
  Prover steps counted:  More than 500
  ~ev[]
  The discussion above applies to any event that contains other events, hence
  applies similarly to ~ilc[progn] events.

  For those who use ~ilc[make-event], we note that prover steps in the
  expansion phase similarly contribute to the total number of steps counted.
  For example, suppose that the limit is 500 prover steps as above, and you
  submit ~c[(make-event EXPR)], where 300 prover steps take place during
  evaluation of ~c[EXPR], producing event ~c[EV].  Then evaluation of ~c[EV]
  will cause an error if it takes more than 200 prover steps.  This observation
  actually can be used to count prover steps for sequences of forms that are
  not all legal ~ilc[events] (~pl[embedded-event-form]), such as calls of
  ~ilc[thm].  For example, a small built-in ACL2 test suite that includes
  ~ilc[thm] forms can be run by evaluating the form ~c[(mini-proveall)], and
  the steps can be counted as shown below.  (Here we assume a fresh ACL2
  session; an error would occur if first, we evaluate the event
  ~c[(set-prover-step-limit 500)] displayed above.)
  ~bv[]
  ACL2 !>(make-event (er-progn (mini-proveall) (value '(value-triple nil))))
  [[... output omitted here ...]]
  Summary
  Form:  ( MAKE-EVENT (ER-PROGN ...))
  Rules: NIL
  Warnings:  Double-rewrite, Equiv, Subsume and Non-rec
  Time:  0.38 seconds (prove: 0.04, print: 0.29, other: 0.05)
  Prover steps counted:  41090
   NIL
  ACL2 !>
  ~ev[]~/"

  `(state-global-let*
    ((inhibit-output-lst (list* 'event 'summary (@ inhibit-output-lst))))
    (pprogn
     (let ((rec (f-get-global 'step-limit-record state))
           (limit (or ,limit *default-step-limit*)))
       (cond ((and rec

; We check here that limit is legal, even though this is also checked by the
; table event below.  Otherwise, we can get a raw Lisp error from, for example:

; (progn (set-prover-step-limit '(a b)))

                   (natp limit)
                   (<= limit *default-step-limit*))
              (f-put-global 'step-limit-record
                            (change step-limit-record rec
                                    :sub-limit
                                    limit
                                    :strictp
                                    (or (< limit *default-step-limit*)
                                        (access step-limit-record rec
                                                :strictp)))
                            state))
             (t state)))
     (progn (table acl2-defaults-table :step-limit
                   (or ,limit *default-step-limit*))
            (table acl2-defaults-table :step-limit)))))

#-acl2-loop-only
(defmacro set-prover-step-limit (limit)
  (declare (ignore limit))
  nil)

#+(and (not acl2-loop-only) acl2-rewrite-meter) ; for stats on rewriter depth
(progn

; Here we provide a mechanism for checking the maximum stack depth attained by
; the rewrite nest, while at the same time turning off the rewrite-stack depth
; limit check.

; When we do a make certify-books or make regression after compiling with
; acl2-rewrite-meter in *features*, we will create a file foo.rstats for every
; book foo being certified.  We can then collect all those stats into a single
; file by executing the following Unix command, where DIR is the acl2-sources
; directory:

; find DIR/books -name '*.rstats' -exec cat {} \; > rewrite-depth-stats.lisp

(defparameter *rewrite-depth-max* 0)     ; records max depth per event
(defparameter *rewrite-depth-alist* nil) ; records max depth per book

)

; We might as well include code here for analyzing the resulting file
; rewrite-depth-stats.lisp (see comment above).  We comment out this code since
; it will not be used very often.

; (include-book "books/misc/file-io")
;
; (defun collect-rstats-1 (filename alist acc)
;
; ; Elements of alist are of the form (event-name . n).  We extend acc by an
; ; alist with corresponding elements (but no specified order) of the form
; ; ((filename . event-name) . n).
;
;   (if (endp alist)
;       acc
;     (collect-rstats-1 filename
;                       (cdr alist)
;                       (cons (cons (cons filename (caar alist))
;                                   (cdar alist))
;                             acc))))
;
; (defun collect-rstats-2 (alist acc)
;
; ; Elements of alist are of the form (filename . alist2), where alist2 is an
; ; alist with elements of the form (event-name . n).
;
;   (if (endp alist)
;       acc
;     (collect-rstats-2 (cdr alist)
;                       (collect-rstats-1 (caar alist) (cdar alist) acc))))
;
; (defun collect-rstats (infile outfile state)
;
; ; Each object in infile as the form (filename . alist), where alist has
; ; elements of the form (event-name . n), where n is the rewrite stack depth
; ; required for event-name.  We write out outfile, which contains a single form
; ; whose elements are of the form ((filename . event-name) . n).  the cdr of
; ; each object in infile, as well as the object in the resulting outfile, are
; ; alists sorted by cdr (heaviest entry first).
;
;   (declare (xargs :stobjs state :mode :program))
;   (er-let* ((forms (read-list infile 'collect-rstats state)))
;     (write-list (merge-sort-cdr-> (collect-rstats-2 forms nil))
;                 outfile 'collect-rstats state)))

(defconst *default-rewrite-stack-limit*

; A proof at AMD has needed a value of at least 774, because of a subterm in
; hypothesis position of the form (member x '(255 254 253 ... 2 1 0)).  But the
; entire regression suite (as of 1/8/03, during development of v2-8) only
; needed a value of at least 186 (one more than the 185 reported using
; collect-rstats).  The example with :do-not in :doc rewrite-stack-limit
; caused a stack overflow in GCL with (set-rewrite-stack-limit 4350) but not
; with (set-rewrite-stack-limit 4300).  Even 15000 didn't cause a stack
; overflow without the :do-not hint.

  1000)

#+acl2-loop-only
(defmacro set-rewrite-stack-limit (limit)

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

  Sets the rewrite stack depth used by the rewriter~/

  Note: This is an event!  It does not print the usual event summary
  but nevertheless changes the ACL2 logical ~il[world] and is so
  recorded.

  ~bv[]
  Example Forms:
  (set-rewrite-stack-limit 30)                            ; set to small limit
  :set-rewrite-stack-limit 30                             ; same as above
  (set-rewrite-stack-limit *default-rewrite-stack-limit*) ; the default
  (set-rewrite-stack-limit (1- (expt 2 28)))              ; maximum legal limit
  :set-rewrite-stack-limit nil         ; same as above -- essentially, no limit
  ~ev[]
  This event sets the maximum stack depth for calls of certain functions that
  implement the ACL2 rewriter; ~pl[rewrite-stack-limit].  It must be a
  non-negative integer less than 2^28.  A call
  ~c[(set-rewrite-stack-limit limit)] is equivalent to:
  ~bv[]
  (table acl2-defaults-table :rewrite-stack-limit limit).
  ~ev[]
  The use of ~ilc[acl2-defaults-table] ensures that this event's effect is
  implicitly ~ilc[local] to the book or ~ilc[encapsulate] form in which it
  occurs.~/

  For a different but somewhat related concept, ~pl[backchain-limit]."

  `(state-global-let*
    ((inhibit-output-lst (list* 'event 'summary (@ inhibit-output-lst))))
    (progn (table acl2-defaults-table :rewrite-stack-limit
                  ,(if (or (null limit) (equal limit (kwote nil)))
                       (1- (expt 2 28))
                     limit))
           (table acl2-defaults-table :rewrite-stack-limit))))

#-acl2-loop-only
(defmacro set-rewrite-stack-limit (limit)
  (declare (ignore limit))
  nil)

(defun rewrite-stack-limit (wrld)

  ":Doc-Section Miscellaneous

  limiting the stack depth of the ACL2 rewriter~/

  ACL2 users can create rules of class ~c[:]~ilc[rewrite] (~pl[rule-classes])
  that have the potential of causing an infinite loop in the ACL2 rewriter.
  This could lead to Lisp stack overflows and even segmentation faults.  For
  this reason, the depth of certain calls of functions in the ACL2 rewriter is
  limited by default using the value of the form
  ~c[(rewrite-stack-limit (w state))].  To see the limit in action, execute the
  following forms.

  ~bv[]
  (defthm app-assoc-1
    (equal (append (append x y) z)
           (append x y z)))
  (defthm app-assoc-2
    (equal (append x y z)
           (append (append x y) z)))
  (thm (equal (append a b c) xxx)
       ; try without these hints to see a slightly different error message
       :hints ((\"Goal\" :do-not '(preprocess))))
  ~ev[]
  The ensuing error message shows a stack of one greater than the value of
  ~c[(rewrite-stack-limit (w state))], which by default is the value of the
  constant ~c[*default-rewrite-stack-limit*].  The error message also explains
  how to use ~c[:]~ilc[brr]~c[ t] and ~c[(]~ilc[cw-gstack]~c[)] to find looping
  rewrite rules.

  This limit can be changed; ~pl[set-rewrite-stack-limit].~/

  For a related limit, ~pl[backchain-limit].~/"

  (declare (xargs :guard
                  (and (plist-worldp wrld)
                       (alistp (table-alist 'acl2-defaults-table wrld)))))
  #+(and (not acl2-loop-only) acl2-rewrite-meter)
  (prog2$ wrld 0) ; setting this to 0 initializes rdepth to 0 for rewrite calls
  #-(and (not acl2-loop-only) acl2-rewrite-meter)
  (or (cdr (assoc-eq :rewrite-stack-limit
                     (table-alist 'acl2-defaults-table wrld)))
      *default-rewrite-stack-limit*))

#+acl2-loop-only
(defmacro set-nu-rewriter-mode (x)

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

  to turn on and off the nu-rewriter~/

  Note: This is an event!  It does not print the usual event summary
  but nevertheless changes the ACL2 logical ~il[world] and is so
  recorded.

  This event sets a flag that controls whether the ACL2 rewriter uses
  the special-purpose ~c[nth]/~c[update-nth] rewriter (nu-rewriter).
  The flag may have one of three values: ~c[nil], ~c[t], or ~c[:literals].~/

  ~bv[]
  :set-nu-rewriter-mode nil        ; do not use nu-rewriter
  :set-nu-rewriter-mode t          ; use nu-rewriter in rewriting
  :set-nu-rewriter-mode :literals  ; use nu-rewriter in rewriting after
                                   ;  a pre-pass through every literal
  (set-nu-rewriter-mode :literals) ; same as above
  ~ev[]

  The value ~c[nil] prevents the use of the nu-rewriter.  The other two
  values allow the use of the nu-rewriter.

  When the flag is non-~c[nil] and the rewriter encounters a term that
  ``begins with an ~c[nth]'', the nu-rewriter is applied.  By ``begins
  with an ~c[nth]'' here we mean either the term is an application of
  ~c[nth] or is an application of some nonrecursive function or
  ~c[lambda] expression whose body contains an expression that begins
  with an ~c[nth].

  Note that the use of the nu-rewriter here described above is driven
  by the rewriter, i.e., the nu-rewriter is applied only to terms
  visited by the rewriter in its inside-out sweep.  When the flag is
  set to ~c[:literals] the system makes a pre-pass through every goal
  clause and applies the nu-rewriter to every subterm.  The rewriter
  is then used on the output of that pre-pass.

  Note: This is an event!  It does not print the usual event summary
  but nevertheless changes the ACL2 logical ~il[world] and is so
  recorded.  Moreover, its effect is to set the ~ilc[acl2-defaults-table], and
  hence its effect is ~ilc[local] to the book or ~ilc[encapsulate] form
  containing it; ~pl[acl2-defaults-table].

  We expect to write more documentation as we gain experience with the
  nu-rewriter."

  `(state-global-let*
    ((inhibit-output-lst (list* 'event 'summary (@ inhibit-output-lst))))
    (progn (table acl2-defaults-table :nu-rewriter-mode ,x)
           (table acl2-defaults-table :nu-rewriter-mode))))

#-acl2-loop-only
(defmacro set-nu-rewriter-mode (x)
  (declare (ignore x))
  nil)

(defun nu-rewriter-mode (wrld)
  (declare (xargs :mode :program))
  (cdr (assoc-eq :nu-rewriter-mode
                 (table-alist 'acl2-defaults-table wrld))))

; Through Version_2.9.4, we set the nu-rewriter mode by default as follows:
; (set-nu-rewriter-mode nil)
; But nil is the default anyhow, and we prefer to keep the acl2-defaults-table
; clean so that its initial value agrees with the value in
; chk-raise-portcullis1.  This isn't essentially, but for example it avoids
; laying down extra table forms when we :puff.

; Terminology: case-split-limitations refers to a list of two
; "numbers" (either of which might be nil meaning infinity), sr-limit
; is the name of the first number, and case-limit is the name of the
; second.  To see how sr-limit is used, see clausify.  To see how
; case-limit is used, see the Essay on Case Limit and also
; rewrite-clause.  We allow the user only to set the
; case-split-limitations, not the numbers individually.

(defun case-split-limitations (wrld)
  (declare (xargs :guard
                  (and (plist-worldp wrld)
                       (alistp (table-alist 'acl2-defaults-table wrld)))))
  ":Doc-Section Miscellaneous

  a list of two ``numbers'' limiting the number of cases produced at once~/
  ~bv[]
  Examples:
  ACL2 !>(case-split-limitations (w state))
  (500 100)
  ~ev[]
  With the setting above, ~c[clausify] will not try subsumption/replacement
  if more than 500 clauses are involved.  Furthermore, the simplifier,
  as it sweeps over a clause, will inhibit further case splits
  when it has accumulated 100 subgoals.  This inhibition is implemented by
  continuing to rewrite subsequent literals but not splitting out their cases.
  This can produce literals containing ~c[IF]s.~/

  ~l[set-case-split-limitations] for a more general discussion."

  (cdr (assoc-eq :case-split-limitations
                 (table-alist 'acl2-defaults-table wrld))))

; Warning: The function tilde-@-case-split-limitations-phrase builds in the
; fact that the car of case-split-limitations is the sr-limit and cadr is the
; case-limit.  Rewrite-clause makes a similar assumption.  So don't be fooled
; into thinking you can just change the structure here!

(defmacro sr-limit (wrld)
  `(car (case-split-limitations ,wrld)))

(defmacro case-limit (wrld)
  `(cadr (case-split-limitations ,wrld)))

#+acl2-loop-only
(defmacro set-case-split-limitations (lst)

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

  set the case-split-limitations~/
  ~bv[]

  Examples:
  (set-case-split-limitations '(500 100))
  (set-case-split-limitations 'nil)
  (set-case-split-limitations '(500 nil))
  ~ev[]
  The first of these prevents ~c[clausify] from trying the
  subsumption/replacement (see below) loop if more than 500 clauses are
  involved.  It also discourages the clause simplifier from splitting into more
  than 100 cases at once.

  Note: This is an event!  It does not print the usual event summary but
  nevertheless changes the ACL2 logical ~il[world] and is so recorded.
  Moreover, its effect is to set the ~ilc[acl2-defaults-table], and hence its
  effect is ~ilc[local] to the book or ~ilc[encapsulate] form containing it;
  ~pl[acl2-defaults-table].

  ~l[hints] for discussion of a related hint, ~c[:case-split-limitations].
  Also ~pl[splitter] for information about reports on rules that may be
  responsible for case splits.~/

  ~bv[]
  General Form:
  (set-case-split-limitations lst)
  ~ev[]
  where ~c[lst] is either ~c[nil] (denoting a list of two ~c[nil]s), or a list
  of length two, each element of which is either ~c[nil] or a natural number.
  When ~c[nil] is used as an element, it is treated as positive infinity.  The
  default setting is ~c[(500 100)].

  The first number specifies the maximum number of clauses that may participate
  in the ``subsumption/replacement'' loop.  Because of the expensive nature of
  that loop (which compares every clause to every other in a way that is
  quadratic in the number of literals in the clauses), when the number of
  clauses exceeds about 1000, the system tends to ``go into a black hole,''
  printing nothing and not even doing many garbage collections (because the
  subsumption/replacement loop does not create new clauses so much as it just
  tries to delete old ones).  The initial setting is lower than the threshold
  at which we see noticeably bad performance, so you probably will not see this
  behavior unless you have raised or disabled the limit.

  Why raise the subsumption/replacement limit?  The subsumption/replacement
  loop cleans up the set of subgoals produced by the simplifier.  For example,
  if one subgoal is
  ~bv[]
  (implies (and p q r) s)            [1]
  ~ev[]
  and another is
  ~bv[]
  (implies (and p (not q) r) s)      [2]
  ~ev[]
  then the subsumption/replacement loop would produce the single subgoal
  ~bv[]
  (implies (and p r) s)              [3]
  ~ev[]
  instead.  This cleanup process is simply skipped when the number of subgoals
  exceeds the subsumption/replacement limit.  But each subgoal must nonetheless
  be proved.  The proofs of [1] and [2] are likely to duplicate much work,
  which is only done once in proving [3].  So with a low limit, you may find
  the system quickly produces a set of subgoals but then takes a long time to
  prove that set.  With a higher limit, you may find the set of subgoals to be
  ``cleaner'' and faster to prove.

  Why lower the subsumption/replacement limit?  If you see the system go into a
  ``black hole'' of the sort described above (no output, and few garbage
  collections), it could due to the subsumption/replacement loop working on a
  large set of large subgoals.  You might temporarily lower the limit so that
  it begins to print the uncleaned set of subgoals.  Perhaps by looking at the
  output you will realize that some function can be disabled so as to prevent
  the case explosion.  Then raise or disable the limit again!

  The second number in the case-split-limitations specifies how many case
  splits the simplifier will allow before it begins to shut down case
  splitting.  In normal operation, when a literal rewrites to a nest of
  ~c[IF]s, the system simplifies all subsequent literals in all the contexts
  generated by walking through the nest in all possible ways.  This can also
  cause the system to ``go into a black hole'' printing nothing except garbage
  collection messages.  This ``black hole'' behavior is different from than
  mentioned above because space is typically being consumed at a prodigious
  rate, since the system is rewriting the literals over and over in many
  different contexts.

  As the simplifier sweeps across the clause, it keeps track of the number of
  cases that have been generated.  When that number exceeds the second number
  in case-split-limitations, the simplifier stops rewriting literals.  The
  remaining, unrewritten, literals are copied over into the output clauses.
  ~c[IF]s in those literals are split out, but the literals themselves are not
  rewritten.  Each output clause is then attacked again, by subsequent
  simplification, and eventually the unrewritten literals in the tail of the
  clause will be rewritten because the earlier literals will stabilize and stop
  producing case splits.

  The default setting of 100 is fairly low.  We have seen successful proofs in
  which thousands of subgoals were created by a simplification.  By setting the
  second number to small values, you can force the system to case split slowly.
  For example, a setting of 5 will cause it to generate ``about 5'' subgoals
  per simplification.

  You can read about how the simplifier works in the book Computer-Aided
  Reasoning: An Approach (Kaufmann, Manolios, Moore); also
  ~pl[introduction-to-the-theorem-prover] for a detailed tutorial on using the
  ACL2 prover.  If you think about it, you will see that with a low case limit,
  the initial literals of a goal are repeatedly simplified, because each time a
  subgoal is simplified we start at the left-most subterm.  So when case
  splitting prevents the later subterms from being fully split out, we revisit
  the earlier terms before getting to the later ones.  This can be good.
  Perhaps it takes several rounds of rewriting before the earlier terms are in
  normal form and then the later terms rewrite quickly.  But it could happen
  that the earlier terms are expensive to rewrite and do not change, making the
  strategy of delayed case splits less efficient.  It is up to you.

  Sometimes the simplifier produces more clauses than you might expect, even
  with case-split-limitations in effect.  As noted above, once the limit has
  been exceeded, the simplifier does not rewrite subsequent literals.  But
  ~c[IF]s in those literals are split out nonetheless.  Furthermore, the
  enforcement of the limit is -- as described above -- all or nothing: if the
  limit allows us to rewrite a literal then we rewrite the literal fully,
  without regard for limitations, and get as many cases as ``naturally'' are
  produced.  It quite often happens that a single literal, when expanded, may
  grossly exceed the specified limits.

  If the second ``number'' is ~c[nil] and the simplifier is going to produce
  more than 1000 clauses, a ``helpful little message'' to this effect is
  printed out.  This output is printed to the system's ``comment window'' not
  the standard proofs output.~/"

  `(state-global-let*
    ((inhibit-output-lst (list* 'event 'summary (@ inhibit-output-lst))))
    (progn (table acl2-defaults-table :case-split-limitations
                  (let ((lst ,lst))
                    (cond ((eq lst nil)
                           '(nil nil))
                          (t lst))))
           (table acl2-defaults-table :case-split-limitations))))

#-acl2-loop-only
(defmacro set-case-split-limitations (lst)
  (declare (ignore lst))
  nil)

; Up through Version_2.9.4 we set case split limitations as follows:
; (set-case-split-limitations *default-case-split-limitations*)
; But as explained in the comment above for set-nu-rewriter-mode, we prefer to
; start with an acl2-defaults-table that agrees with the one in
; chk-raise-portcullis1.  So we instead we set the initial acl2-defaults-table
; as follows, in end-prehistoric-world.

(defconst *initial-acl2-defaults-table*
  `((:DEFUN-MODE . :LOGIC)
    (:INCLUDE-BOOK-DIR-ALIST . NIL)
    (:CASE-SPLIT-LIMITATIONS . (500 100))
    (:TAU-AUTO-MODEP . ,(cddr *tau-status-boot-strap-settings*)))) ; (2.b)

(defun untrans-table (wrld)

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

  associates a function symbol with a macro for printing user-level terms~/
  ~bv[]
  Examples:
  ACL2 !>(untrans-table (w state))
  ((BINARY-+ + . T)
   (BINARY-* * . T)
   (BINARY-APPEND APPEND . T)
   (BINARY-LOGAND LOGAND . T)
   (BINARY-LOGIOR LOGIOR . T)
   (BINARY-LOGXOR LOGXOR . T)
   (BINARY-LOGEQV LOGEQV . T)
   (BINARY-POR POR . T)
   (BINARY-PAND PAND . T))
  ~ev[]

  ~l[table] for a general discussion of tables.~/

  ~l[add-macro-fn] for a more general discussion of this ~il[table] and for a
  way to associate a macro name with a function name in theory events."

  (declare (xargs :guard (plist-worldp wrld)))
  (table-alist 'untrans-table wrld))

(table untrans-table nil
       '((binary-+ + . t)
         (binary-* * . t)
         (binary-append append . t)
         (binary-logand logand . t)
         (binary-logior logior . t)
         (binary-logxor logxor . t)
         (binary-logeqv logeqv . t)
         (binary-por por . t)
         (binary-pand pand . t))
       :clear)

(defmacro add-macro-fn (macro macro-fn &optional right-associate-p)

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

  associate a function name with a macro name~/
  ~bv[]
  Examples:
  (add-macro-fn append binary-append)
  (add-macro-fn append binary-append t)
  ~ev[]
  These examples each associate the function symbol ~ilc[binary-append] with
  the macro name ~ilc[append].  As a result, theory functions will understand
  that ~c[append] refers to ~c[binary-append] ~-[] ~pl[add-macro-alias] ~-[]
  and moreover, proof output will be printed using ~c[append] rather than
  ~c[binary-append].  In the first case, ~c[(append x (append y z))] is printed
  rather than ~c[(append x y z)].  In the second case, right-associated
  arguments are printed flat: ~c[(append x y z)].  Such right-association is
  considered only for binary function symbols; otherwise the optional third
  argument is ignored.~/
  ~bv[]
  General Forms:
  (add-macro-fn macro-name function-name)
  (add-macro-fn macro-name function-name nil) ; same as abov
  (add-macro-fn macro-name function-name t)
  ~ev[]

  This is a convenient way to add an entry to ~ilc[macro-aliases-table] and at
  the same time extend the ~ilc[untrans-table].  As suggested by the example
  above, calls of a function in this table will be printed as corresponding
  calls of macros, with right-associated arguments printed flat in the case of
  a binary function symbol if the optional third argument is t.  In that case,
  for a binary function symbol ~c[fn] associated with macro name ~c[mac], then
  a call ~c[(fn arg1 (fn arg2 (... (fn argk arg))))] will be displayed to the
  user as though the ``term'' were ~c[(mac arg1 arg2 ... argk arg)].  For a
  call ~c[(f a1 ... ak)] of a function symbol that is not binary, or the
  optional argument is not supplied as ~c[t], then the effect is simply to
  replace ~c[f] by the corresponding macro symbol.  ~l[add-macro-alias], which
  is invoked on the first two arguments.  Also ~pl[remove-macro-alias],
  ~pl[untrans-table], and ~pl[remove-macro-fn].~/"

  `(progn (add-macro-alias ,macro ,macro-fn)
          (table untrans-table ',macro-fn '(,macro . ,right-associate-p))))

(defmacro add-binop (macro macro-fn)

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

  associate a function name with a macro name~/

  The form ~c[(add-binop macro macro-fn)] is an abbreviation for the form
  ~c[(add-macro-fn macro macro-fn t)].  ~l[add-macro-fn].~/~/"

  `(add-macro-fn ,macro ,macro-fn t))

(defmacro remove-macro-fn (macro-fn)

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

  remove the association of a function name with a macro name~/
  ~bv[]
  Example:
  (remove-macro-fn binary-append)~/
  General Form:
  (remove-macro-fn macro-fn)
  ~ev[]
  ~l[add-macro-fn] for a discussion of how to associate a macro name with a
  function name.  This form sets ~ilc[untrans-table] to the result of deleting
  the association of a macro name with the given binary function name.  If the
  function name has no such association, then this form still generates an
  event, but the event has no real effect.~/"

  `(table untrans-table nil
          (let ((tbl (table-alist 'untrans-table world)))
            (if (assoc-eq ',macro-fn tbl)
                (delete-assoc-eq-exec ',macro-fn tbl)
              (prog2$ (cw "~%NOTE:  the name ~x0 did not appear as a key in ~
                           untrans-table.  Consider using :u or :ubt to ~
                           undo this event, which is harmless but does not ~
                           change untrans-table.~%"
                          ',macro-fn)
                      tbl)))
          :clear))

(defmacro remove-binop (macro-fn)

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

  remove the association of a function name with a macro name~/

  The form ~c[(remove-binop macro-fn)] is an abbreviation for the form
  ~c[(remove-macro-fn macro-fn)].  ~l[remove-macro-fn].~/~/"

  `(remove-macro-fn ,macro-fn))

; Begin implementation of tables allowing user control of :once and :all for
; the :match-free behavior of rewrite, linear, and forward-chaining rules.

(defun match-free-default (wrld)
  (declare (xargs :guard (and (plist-worldp wrld)
                              (alistp (table-alist 'acl2-defaults-table
                                                   wrld)))))
  (cdr (assoc-eq :match-free-default
                 (table-alist 'acl2-defaults-table wrld))))

#+acl2-loop-only
(defmacro set-match-free-default (x)

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

  provide default for ~c[:match-free] in future rules~/
  ~bv[]
  General Forms:
  (set-match-free-default :once)
  (set-match-free-default :all)
  (set-match-free-default nil)
  ~ev[]

  Note: This utility does not apply to ~il[type-prescription] rules; for
  a related topic pertinent to such rules,
  ~pl[free-variables-type-prescription].

  As described elsewhere (~pl[free-variables]), a ~il[rewrite], ~il[linear], or
  ~il[forward-chaining] rule may have free variables in its hypotheses, and
  ACL2 can be directed either to try all bindings (``~c[:all]'') or just the
  first (``~c[:once]'') when relieving that hypothesis, as a basis for
  relieving subsequent hypotheses.  This directing of ~c[:all] or ~c[:once] is
  generally provided by specifying either ~c[:match-free :once] or
  ~c[:match-free :all] in the ~c[:]~ilc[rule-classes] of the rule.  If neither
  of these is specified, then the most recent ~c[set-match-free-default] is
  used by ACL2 to fill in this missing ~c[:match-free] field.
  ~l[rule-classes].  Except: If the last ~c[set-match-free-default] specifies
  ~c[nil], then ACL2 reverts to the behavior it had at start-up, as described
  in Remarks (2) and (3) below.

  Note: This is an event!  It does not print the usual event summary
  but nevertheless changes the ACL2 logical ~il[world] and is so
  recorded.  It uses the ~ilc[acl2-defaults-table], and hence its effect is
  ~ilc[local] to the book or ~ilc[encapsulate] form in which it occurs.~/

  Remarks.

  (1) The use of ~c[set-match-free-default] has no effect on existing rules.  In
  order to change the behavior of existing rules with respect to free-variable
  matching, ~pl[add-match-free-override].

  (2) If you submit a ~il[rewrite], ~il[linear], or ~il[forward-chaining] rule
  with a free variable in a hypothesis, and no default setting was previously
  specified with ~c[set-match-free-default] or the default setting is ~c[nil],
  and the rule is not within a book being processed with ~ilc[include-book],
  ~ilc[certify-book], or ~ilc[rebuild], then a warning or error is caused.  In
  order to make this an error instead of a warning, ~pl[set-match-free-error].

  (3) If you submit a ~il[rewrite], ~il[linear], or ~il[forward-chaining] rule
  with a free variable in a hypothesis, and no default setting has been
  previously specified with ~c[set-match-free-default] or the default setting
  is ~c[nil], and no error is caused (see (2) above), then the default ~c[:all]
  is used.~/"

; :cited-by free-variables add-match-free-override set-match-free-error

  `(state-global-let*
    ((inhibit-output-lst (list* 'event 'summary (@ inhibit-output-lst))))
     (progn (table acl2-defaults-table :match-free-default ,x)
            (table acl2-defaults-table :match-free-default))))

#-acl2-loop-only
(defmacro set-match-free-default (x)
  (declare (ignore x))
  nil)

(defmacro set-match-free-error (x)

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

  control error vs. warning when ~c[:match-free] is missing~/
  ~bv[]
  Legal Forms:
  (set-match-free-error nil)
  :set-match-free-error nil
  (set-match-free-error t)
  :set-match-free-error t
  ~ev[]

  As described elsewhere (~pl[free-variables]), when a ~il[rewrite],
  ~il[linear], or ~il[forward-chaining] rule has free variables in its
  hypotheses, the user can specify whether to try all bindings
  (``~c[:all]'') or just the first (``~c[:once]'') when relieving its
  hypotheses, as a basis for relieving subsequent hypotheses.  This direction
  of ~c[:all] or ~c[:once] is generally provided by specifying either
  ~i[:match-free :once] or ~i[:match-free :all] in the ~c[:]~ilc[rule-classes]
  of the rule.

  But suppose that neither of these is specified for such a rule.  (Note:
  ~c[set-match-free-error] is not relevant for ~il[type-prescription] rules.)
  Also suppose that ~c[set-match-free-default] has not specified a default of
  ~c[:once] or ~c[:all] (~pl[set-match-free-default]).  In this case a warning
  will occur except when in the context of ~ilc[include-book].  If you prefer
  to see an error in such cases, except in the context of ~ilc[certify-book],
  execute ~c[(set-match-free-error t)].  If there is no error, then a default
  of ~c[:all] is used.~/

  Note: This is ~sc[not] an event!  Instead, ~c[set-match-free-error] sets the
  state global ~c['match-free-error] (~pl[state] and ~pl[assign]).  Thus, this
  form cannot be put into a book.  If you are tempted to put it into a book,
  consider the fact that it really isn't needed there, since the absence of
  ~c[:match-free] does not cause an error in the context of ~ilc[certify-book]
  or ~ilc[include-book].  If you still feel the need for such a form, consider
  using ~c[set-match-free-default] to provide a default, at least within the
  scope of the current book (if any); ~pl[set-match-free-default].~/"

; :cited-by free-variables add-match-free-override set-match-free-default

  (declare (xargs :guard (booleanp x)))
  `(f-put-global 'match-free-error ,x state))

(defun match-free-override (wrld)

; We return either :clear or else a cons, whose car indicates the minimum nume
; to which the override will not apply, and whose cdr is the list of runes in
; the :match-free-override field of the acl2-defaults-table.

  (declare (xargs :guard (and (plist-worldp wrld)
                              (alistp
                               (table-alist 'acl2-defaults-table wrld)))))
  (let ((pair (assoc-eq :match-free-override
                        (table-alist 'acl2-defaults-table wrld))))
    (if (or (null pair) (eq (cdr pair) :clear))
        :clear
      (cons (cdr (assoc-eq :match-free-override-nume
                           (table-alist 'acl2-defaults-table wrld)))
            (cdr pair)))))

#+acl2-loop-only
(defmacro add-match-free-override (flg &rest runes)

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

  set ~c[:match-free] value to ~c[:once] or ~c[:all] in existing rules~/
  ~bv[]
  Example Forms:
  (add-match-free-override :once t)
      ; Try only the first binding of free variables when relieving hypotheses
      ; of any rule of class :rewrite, :linear, or :forward-chaining.
  (add-match-free-override :all (:rewrite foo) (:rewrite bar))
      ; For rewrite rules foo and bar, try all bindings of free variables when
      ; relieving hypotheses.
  (add-match-free-override :clear)
      ; Restore :match-free to what was originally stored for each rule (either
      ; :all or :once).
  ~ev[]
  As described elsewhere (~pl[free-variables]), a ~il[rewrite], ~il[linear], or
  ~il[forward-chaining] rule may have free variables in its hypotheses, and
  ACL2 can be directed either to try all bindings (``~c[:all]'') or just the
  first (``~c[:once]'') when relieving a hypothesis, as a basis for relieving
  subsequent hypotheses.  This direction is generally provided by specifying
  either ~c[:match-free :once] or ~c[:match-free :all] in the
  ~c[:]~ilc[rule-classes] of the rule, or by using the most recent
  ~ilc[set-match-free-default] event.  Also ~pl[rule-classes].

  However, if a proof is going slowly, you may want to modify the behavior of
  some such rules so that they use only the first match for free variables in a
  hypothesis when relieving subsequent hypotheses, rather than backtracking and
  trying additional matches as necessary.  (But note:
  ~c[add-match-free-override] is not relevant for ~il[type-prescription]
  rules.)  The event ~c[(add-match-free-override :once t)] has that effect.  Or
  at the other extreme, perhaps you want to specify all rules as ~c[:all] rules
  except for a some specific exceptions.  Then you can execute
  ~c[(add-match-free-override :all t)] followed by, say,
  ~c[(add-match-free-override :once (:rewrite foo) (:linear bar))].~/

  ~bv[]
  General Forms:
  (add-match-free-override :clear)
  (add-match-free-override flg t)
  (add-match-free-override flg rune1 rune2 ... runek)
  ~ev[]
  where ~c[flg] is ~c[:once] or ~c[:all] and the ~c[runei] are ~ilc[rune]s.  If
  ~c[:clear] is specified then all rules will have the ~c[:all]/~c[:once]
  behavior from when they were first stored.  The second general form causes
  all ~il[rewrite] ~il[linear], and ~il[forward-chaining] rules to have the
  behavior specified by ~c[flg] (~c[:all] or ~c[:once]).  Finally, the last of
  these, where runes are specified, is additive in the sense that only the
  indicated rules are affected; all others keep the behavior they had just
  before this event was executed (possible because of earlier
  ~c[add-match-free-override] events).

  At the conclusion of this event, ACL2 prints out the list of all
  ~c[:]~ilc[linear], ~c[:]~ilc[rewrite], and ~c[:]~ilc[forward-chaining] runes
  whose rules contain free variables in hypotheses that are to be bound
  ~c[:once], except that if there are no overrides (value ~c[:clear] was used),
  then ~c[:clear] is printed.

  This event only affects rules that exist at the time it is executed.  Future
  rules are not affected by the override.

  Note: This is an event!  It does not print the usual event summary
  but nevertheless changes the ACL2 logical ~il[world] and is so
  recorded.  It uses the ~ilc[acl2-defaults-table], and hence its effect is
  ~ilc[local] to the book or ~ilc[encapsulate] form in which it occurs.

  ~em[Remarks]

  Lists of the ~c[:]~ilc[rewrite], ~c[:]~ilc[linear], and
  ~c[:]~ilc[forward-chaining] ~il[rune]s whose behavior was originally
  ~c[:once] or ~c[:all] are returned by the following forms, respectively.
  ~bv[]
  (free-var-runes :once (w state))
  (free-var-runes :all  (w state))
  ~ev[]
  The form
  ~bv[]
  (match-free-override (w state))
  ~ev[]
  evaluates to a pair, whose ~ilc[car] is a number used by ACL2 to determine
  whether a ~il[rune] is sufficiently old to be affected by the override, and
  whose ~ilc[cdr] is the list of ~il[rune]s whose behavior is specified as
  ~c[:once] by ~c[add-match-free-override]; except, if no runes have been
  overridden, then the keyword ~c[:clear] is returned.~/"

; :cited-by free-variables set-match-free-default set-match-free-error

  `(state-global-let*
    ((inhibit-output-lst (list* 'event 'summary (@ inhibit-output-lst))))
    ,(cond
      ((eq flg :clear)
       (cond
        ((null runes)
         '(progn (table acl2-defaults-table :match-free-override :clear)
                 (table acl2-defaults-table :match-free-override)))
        (t
         `(er soft 'add-match-free-override
              "When the first argument of add-match-free-override is :clear, it ~
               must be the only argument."))))
      ((not (member-eq flg '(:all :once)))
       `(er soft 'add-match-free-override
            "The first argument of add-match-free-override must be :clear, ~
            :all, or :once, but it is:  ~x0."
            ',flg))
      (t
       `(let ((runes ',runes))
          (cond
           ((and (not (equal runes '(t)))
                 (non-free-var-runes runes
                                     (free-var-runes :once (w state))
                                     (free-var-runes :all (w state))
                                     nil))
            (er soft 'add-match-free-override
                "Unless add-match-free-override is given a single argument of ~
                 T, its arguments must be :rewrite, :linear, or ~
                 :forward-chaining runes in the current ACL2 world with free ~
                 variables in their hypotheses.  The following argument~#0~[ ~
                 is~/s are~] thus illegal:  ~&0."
                (non-free-var-runes runes
                                    (free-var-runes :once (w state))
                                    (free-var-runes :all (w state))
                                    nil)))
           (t
            (er-progn
             ,(cond
               ((and (equal runes '(t))
                     (eq flg :all))
                '(er-progn (let ((next-nume (get-next-nume (w state))))
                             (table-fn 'acl2-defaults-table
                                       (list :match-free-override-nume
                                             (list 'quote next-nume))
                                       state
                                       (list 'table
                                             'acl2-defaults-table
                                             ':match-free-override-nume
                                             (list 'quote next-nume))))
                           (table acl2-defaults-table
                                  :match-free-override
                                  nil)))
               (t
                `(let* ((wrld (w state))
                        (old-table-val
                         (match-free-override wrld))
                        (old-once-runes
                         (cond
                          ((equal runes '(t))
                           (union-equal
                            (free-var-runes :all wrld)
                            (free-var-runes :once wrld)))
                          ((eq old-table-val :clear)
                           (free-var-runes :once wrld))
                          (t (cdr old-table-val))))
                        (new-once-runes
                         ,(cond
                           ((equal runes '(t)) ; and (eq flg :once)
                            'old-once-runes)
                           ((eq flg :once)
                            `(union-equal ',runes old-once-runes))
                           (t
                            `(set-difference-equal old-once-runes
                                                   ',runes))))
                        (next-nume (get-next-nume wrld)))
                   (er-progn (table-fn 'acl2-defaults-table
                                       (list :match-free-override-nume
                                             (list 'quote next-nume))
                                       state
                                       (list 'table
                                             'acl2-defaults-table
                                             ':match-free-override-nume
                                             (list 'quote next-nume)))
                             (table-fn 'acl2-defaults-table
                                       (list :match-free-override
                                             (list 'quote
                                                   new-once-runes))
                                       state
                                       (list 'table
                                             'acl2-defaults-table
                                             ':match-free-override
                                             (list 'quote
                                                   new-once-runes)))))))
             (value (let ((val (match-free-override (w state))))
                      (if (eq val :clear)
                          :clear
                        (cdr val))))))))))))

#-acl2-loop-only
(defmacro add-match-free-override (flg &rest runes)
  (declare (ignore flg runes))
  nil)

(defmacro add-include-book-dir (keyword dir)

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

  link keyword for ~c[:dir] argument of ~ilc[ld] and ~ilc[include-book]~/
  ~bv[]
  Example Form:
  (add-include-book-dir :smith \"/u/smith/\")
   ; For (include-book \"foo\" :dir :smith), prepend \"/u/smith/\" to \"foo\".~/

  General Form:
  (add-include-book-dir kwd dir)
  ~ev[]
  where ~c[kwd] is a ~ilc[keywordp] and ~c[dir] is the ~il[pathname] of a
  directory.  (If the final '~c[/]' is missing, ACL2 will add it for you.)  The
  effect of this event is to modify the meaning of the ~c[:dir] keyword
  argument of ~ilc[include-book] as indicated by the examples above, and
  similarly for ~ilc[ld], namely by associating the indicated directory with
  the indicated keyword for purposes of the ~c[:dir] argument.  By the
  ``indicated directory'' we mean, in the case that the pathname is a relative
  pathname, the directory relative to the current connected book directory;
  ~pl[cbd].  ~l[delete-include-book-dir] for how to undo this effect.

  A keyword that is already associated with a directory string by an existing
  invocation of ~c[add-include-book-dir] cannot be associated with a different
  directory string.  If that is your intention, first apply
  ~ilc[delete-include-book-dir] to that keyword; ~pl[delete-include-book-dir].
  If however the new directory string is identical with the old, then the call
  of ~c[add-include-book-dir] will be redundant (~pl[redundant-events]).

  The keyword ~c[:system] can never be redefined.  It will always point to the
  absolute pathname of the system books directory, which by default is
  immediately under the directory where the ACL2 executable was originally
  built (~pl[include-book], in particular the discussion there of ``books
  directory'').

  This macro generates (in essence) a call
  ~c[(table acl2-defaults-table :include-book-dir-alist ...)]
  and hence is ~ilc[local] to any ~il[books] and ~ilc[encapsulate] ~il[events]
  in which it occurs.  ~l[acl2-defaults-table].  Even if you invoke
  ~c[add-include-book-dir] before certifying a book, so that this event is
  among the book's ~il[portcullis] commands rather than in the book itself,
  nevertheless that ~c[add-include-book-dir] event will not be visible after
  the book is included.  (Note: The above behavior is generally preserved in
  raw-mode (~pl[set-raw-mode]),though by means other than a table.)~/"

  `(add-include-book-dir-fn ,keyword
                            ,dir

; We use state in the loop but the live state outside it.  This could be a
; problem if we could define a function that can take a non-live state as an
; argument; see the bug through Version_4.3 explained in a comment in
; with-live-state.  However, we prevent that problem by putting
; add-include-book-dir in a suitable list in the definition of translate11.

                            #+acl2-loop-only state
                            #-acl2-loop-only *the-live-state*))

(defmacro delete-include-book-dir (keyword)

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

  unlink keyword for ~c[:dir] argument of ~ilc[ld] and ~ilc[include-book]~/
  ~bv[]
  Example Forms:
  (delete-include-book-dir :smith)
   ; Remove association of directory with :smith for include-book.~/

  General Form:
  (delete-include-book-dir kwd)
  ~ev[]
  where ~c[kwd] is a ~ilc[keywordp].  The effect of this event is to modify the
  meaning of the ~c[:dir] keyword argument of ~ilc[include-book] and ~ilc[ld]
  as indicated by the examples above, namely by removing association of any
  directory with the indicated keyword for purposes of the ~ilc[include-book]
  (and ~ilc[ld]) ~c[:dir] argument.  Normally one would instead use
  ~ilc[add-include-book-dir] to associate a new directory with that keyword;
  ~pl[add-include-book-dir].

  Note: This is an event!  It does not print the usual event summary
  but nevertheless changes the ACL2 logical ~il[world] and is so recorded.

  This macro is ~ilc[local] to any ~il[books] and ~ilc[encapsulate] ~il[events]
  in which it occurs; ~pl[add-include-book-dir] for a discussion of this aspect
  of both macros.~/"

  `(delete-include-book-dir-fn ,keyword

; We use state in the loop but the live state outside it.  This could be a
; problem if we could define a function that can take a non-live state as an
; argument; see the bug through Version_4.3 explained in a comment in
; with-live-state.  However, we prevent that problem by putting
; delete-include-book-dir in a suitable list in the definition of translate11.

                               #+acl2-loop-only state
                               #-acl2-loop-only *the-live-state*))

; Begin implementation of tables controlling non-linear arithmetic.

(defconst *non-linear-rounds-value* 3)

(defun non-linearp (wrld)
  (declare (xargs :guard
                  (and (plist-worldp wrld)
                       (alistp (table-alist 'acl2-defaults-table wrld)))))
  (let ((temp (assoc-eq :non-linearp
                        (table-alist 'acl2-defaults-table wrld))))
    (if temp
        (cdr temp)
      nil)))

#+acl2-loop-only
(defmacro set-non-linearp (toggle)

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

  to turn on or off non-linear arithmetic reasoning~/
  ~bv[]
  Examples:
  (set-non-linearp t)
  (set-non-linearp nil)
  ~ev[]~/

  ~l[non-linear-arithmetic].   This event is equivalent to
  ~c[(table acl2-defaults-table :non-linearp <t-or-nil>)],
  and hence is ~ilc[local] to any ~il[books] and ~ilc[encapsulate] ~il[events]
  in which it occurs; ~pl[acl2-defaults-table].

  The initial value is ~c[nil]."

  `(state-global-let*
    ((inhibit-output-lst (list* 'event 'summary (@ inhibit-output-lst))))
     (progn (table acl2-defaults-table :non-linearp ,toggle)
            (table acl2-defaults-table :non-linearp))))

#-acl2-loop-only
(defmacro set-non-linearp (toggle)
  (declare (ignore toggle))
  nil)

(defmacro set-non-linear (toggle)

; Usually the names of our set utilities do not end in "p".  We leave
; set-non-linearp for backward compatibility, but we add this version for
; consistency.

  `(set-non-linearp ,toggle))

(defun tau-auto-modep (wrld)

; See the Essay on the Status of the Tau System During and After Bootstrapping
; for further details.

; The tau system either makes :tau-system rules out of non-:tau-system rules on
; the fly or it does not.  It does if auto mode is t; it doesn't if auto mode
; is nil.

; The auto mode is stored in the acl2-defaults-table.  The default auto mode
; when bootstrapping is completed, i.e., choice (2.b) of the essay cited above,
; is t, by virtue of the setting of *initial-acl2-defaults-table*.  However,
; that constant is loaded into the acl2-defaults-table only at the very end of
; the bootstrap process, in end-prehistoric-world.  So how do we implement
; (1.b), the status of tau-auto-modep during bootstrapping?  Answer: here.

; Note: Once we tried to adjust the (1.b) decision by inserting a
; (set-tau-auto-mode ...) event into the boot strap sequence.  But that doesn't
; work because you can't insert it early enough, since many events are
; processed before the acl2-defaults-table even exists.

; Note: if the user clears the acl2-defaults-table, then the auto mode is just
; returns to its default value as specified by
; *tau-status-boot-strap-settings*, not to (cdr nil).

  (declare (xargs :guard
                  (and (plist-worldp wrld)
                       (alistp (table-alist 'acl2-defaults-table wrld)))))
  (let ((temp (assoc-eq :tau-auto-modep
                        (table-alist 'acl2-defaults-table wrld))))
    (cond
     ((null temp)
      (if (global-val 'boot-strap-flg wrld)
          (cdar *tau-status-boot-strap-settings*) ; (1.b) tau auto mode during boot strap
          nil))
     (t (cdr temp)))))

#+acl2-loop-only
(defmacro set-tau-auto-mode (toggle)

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

  turn on or off automatic (``greedy'') generation of ~c[:tau-system] rules~/
  ~bv[]
  Examples:
  (set-tau-auto-mode t)      ; select automatic (``greedy'') mode
  (set-tau-auto-mode nil)    ; select manual mode
  ~ev[]~/

  This event is equivalent to
  ~c[(table acl2-defaults-table :tau-auto-modep <t-or-nil>)], and hence is
  ~ilc[local] to any ~il[books] and
  ~ilc[encapsulate] ~il[events] in which it occurs; ~pl[acl2-defaults-table].
  ~l[introduction-to-the-tau-system] for background details.

  The tau system gathers rules for its database in one of two ways: greedily
  or only at the explicit command of the user.  ``Greedy'' mode is officially
  called ``automatic mode'' and is the default.  The other mode is called
  ``manual mode.''

  In automatic mode, all rules processed by ACL2 are also considered for
  inclusion in the tau database: if the ~c[:corollary] of some proved theorem
  happens to fit into one of the forms described in ~c[:]~ilc[tau-system], that
  rule is quietly added to the tau database ~i[regardless of what]
  ~c[:]~ilc[rule-classes] the user named for the ~c[:corollary].  Of course,
  such rules are also stored in the ways named by the user.  See the
  ~i[Design Philosophy] section of ~il[introduction-to-the-tau-system] for a
  discussion of why the tau system is greedy by default.  More details
  are given on automatic mode after we explain manual mode.

  To more tightly control the rules available to the tau system, the user may
  select manual mode by executing ~c[(set-tau-auto-mode nil)].  In manual mode,
  the only events that create ~c[:tau-system] rules are ~c[defthm] events
  explicitly specifying the ~c[:]~ilc[tau-system] rule class in the
  ~c[:]~ilc[rule-classes] argument.  Of course, for a ~c[:tau-system] rule to
  be created from a proved formula (or its specified ~c[:corollary]), the
  formula must be of the appropriate shape (syntactic form). ~l[tau-system].
  In manual mode, if the ~c[:tau-system] rule class is specified but the
  formula is not of an appropriate form an error is signalled.  (Note: even in
  manual mode, monadic functions that are recognized as Boolean are classified
  as tau predicates; but no rules are created for them.)

  Returning to our discussion of automatic mode, a ~c[:]~ilc[tau-system] rule
  may be created by any of the events below, provided the definition or formula
  proved is of an appropriate shape:

  (1) ~c[defun] events introducing ``big switch'' or ``~c[mv-nth] synonyms,''

  (2) ~c[defun] events creating type-prescription rules that may be also
  represented as ``signature rules'' of form 1, and

  (3) any ~c[defthm] event with a non-~c[nil] ~c[:rule-classes] argument if no
    ~c[:tau-system] rule is among the rule classes and the formula proved is in
    the shape of any ~c[tau-system] rule.

  Of course, events such as ~ilc[defstobj] and ~ilc[defevaluator] may also add
  rules to the tau database when they execute the ~ilc[defun] and ~ilc[defthm]
  events implicit in their descriptions.  ~l[tau-system] for a description of
  the various shapes mentioned above.

  Note that any rule (of any rule class) created when the tau system is in
  manual mode is also created in automatic mode.  For example, if an event
  would create a ~c[:DEFINITION], ~c[:TYPE-PRESCRIPTION], ~c[FORWARD-CHAINING],
  or ~c[:REWRITE] rule when the tau system is in manual mode, then the event
  will create that same rule when the tau system is in automatic mode.
  Automatic mode just means that some additional ~c[:tau-system] rules may be
  created.

  Of course, if a ~c[defthm] event explicitly specifies a ~c[:tau-system] rule
  class, then even if the tau system is in automatic mode, that tau rule is
  created from the proved formula (or the specified ~c[:corollary]) or else an
  error is caused.  But if the tau system is in automatic mode and a ~c[defthm]
  event doesn't explicitly specify a ~c[:tau-system] rule class, then the
  system quietly checks each specified ~c[:corollary] ~-[] or, in the absence
  of any ~c[:corollary], it checks the proved formula ~-[] for whether it can
  be stored as a tau rule.  If so, then the system stores a tau rule, in
  addition to storing the specified rule.  Of course, no error is signalled if
  a proved formula of some non-~c[:tau-system] rule class fails to be of an
  appropriate shape for the tau system.

  In automatic mode, if the ~c[:rule-classes] specified for ~c[defthm] included
  several corollaries and any one of them is of class ~c[:tau-system] then the
  only tau system rules created are those explicitly classed as ~c[:tau-system]
  rules.  For example, suppose a ~c[defthm] has one ~c[:corollary] stored as a
  ~c[:rewrite] rule and another ~c[:corollary] stored as a ~c[:tau-system]
  rule.  But suppose the ~c[:rewrite] rule happens to also to fit the form of a
  ~c[:tau-system] rule.  Is it added to the tau database or not?  The answer
  is no.  If you have taken the trouble to specify ~c[:tau-system] corollaries
  for an event, then those corollaries are the only ones stored as tau sytem
  rules from that event.  Note that had both corollaries been classed as
  ~c[:rewrite] rules (and been of acceptable ~c[:tau-system] form) both would
  have also been made ~c[:tau-system] rules.  This also allows you be in automatic
  mode and state a ~c[:rewrite] or other non-~c[:tau-system] rule and prevent it
  from being also made a tau system rule:  just add a frivolous ~c[:tau-system]
  ~c[:corollary] like ~c[(booleanp (integerp x))].

  Recall that the use of tau rules is controlled by the rune
  ~c[(:EXECUTABLE-COUNTERPART TAU-SYSTEM)].  When that rune is disabled, no tau rules
  are ~i[used] in proofs.  However, the tau system continues to collect tau rules
  if the system is in automatic mode.  Thus, if and when the tau system is
  re-enabled, rules automatically generated while the tau system was disabled
  will be used as usual by the tau system.

  Finally, note that ~c[defthm] events with ~c[:rule-classes] ~c[nil] do not
  create ~c[:tau-system] rules even if the formula proved is of an appropriate
  shape, regardless of whether the tau system is in automatic or manual mode.

  The macro ~ilc[tau-status] provides a convenient way to enable/disable the
  ~c[:]~ilc[executable-counterpart] of ~c[tau-system] and/or to switch between
  manual and automatic modes.  It may also be used to determine the current
  settings of those two flags."

  `(state-global-let*
    ((inhibit-output-lst (list* 'event 'summary (@ inhibit-output-lst))))
     (progn (table acl2-defaults-table :tau-auto-modep ,toggle)
            (table acl2-defaults-table :tau-auto-modep))))

#-acl2-loop-only
(defmacro set-tau-auto-mode (toggle)
  (declare (ignore toggle))
  nil)

#+acl2-loop-only
(defmacro defttag (tag-name &key doc)

  ":Doc-Section Events

  introduce a trust tag (ttag)~/

  ~st[Introduction].  This event is intended for advanced users who, in
  essence, want to build extensions of ACL2.  The typical intended use is to
  create ~il[books] that extend the functionality of ACL2 in ways not allowed
  without a so-called ``active trust tag''.  A trust tag thus represents a
  contract: The writer of such a book is guaranteeing that the book extends
  ACL2 in a ``correct'' way as defined by the writer of the book.  The writer
  of the book will often have a small section of the book in the scope of an
  active trust tag that can be inspected by potential users of that book:
  ~bv[]
  <initial part of book, which does not use trust tags>
  (defttag :some-ttag) ; install :some-ttag as an active trust tag
  <various code that requires an active trust tag>
  (defttag nil)        ; remove active trust tag
  <initial part of book, which does not use trust tags>
  ~ev[]

  Why might trust tags be needed?  The evaluation of certain functions can
  introduce bugs and even unsoundness, but can be useful in restricted ways
  that avoid such issues.  For example, ~ilc[sys-call] can be used in an unsafe
  way, for example to overwrite files, or worse; ~pl[sys-call] for a
  frightening example from Bob Boyer.  The following example shows that the
  function ~ilc[sys-call] is restricted by default, but can be called after
  installing an active trust tag.
  ~bv[]
  ACL2 !>(sys-call \"pwd\" nil)


  ACL2 Error in TOP-LEVEL:  The SYS-CALL function cannot be called unless
  a trust tag is in effect.  See :DOC defttag.

  ACL2 !>(defttag t) ; Install :T as an active trust tag.

  TTAG NOTE: Adding ttag :T from the top level loop.
   T
  ACL2 !>(sys-call \"pwd\" nil) ; print the current directory and return NIL
  /u/kaufmann
  NIL
  ACL2 !>(defttag nil) ; Remove the active trust tag (using value NIL).
   NIL
  ACL2 !>(sys-call \"pwd\" nil) ; Now we get the error again:


  ACL2 Error in TOP-LEVEL:  The SYS-CALL function cannot be called unless
  a trust tag is in effect.  See :DOC defttag.

  ACL2 !>
  ~ev[]

  Of course, using ~ilc[sys-call] with the Linux command ~c[pwd] is not likely
  to cause any soundness problems!  So suppose we want to create a function
  that prints the working directory.  We might put the following ~il[events]
  into a book that is to be certified.
  ~bv[]
  (in-package \"ACL2\")
  (defttag :pwd-ttag)
  (defun print-working-dir ()
    (declare (xargs :mode :program))
    (sys-call \"pwd\" nil))
  (defttag nil) ; optional (books end with this implicitly)
  ~ev[]
  We can certify this book with a specification that ~c[:pwd-ttag] is a legal
  trust tag:
  ~bv[]
  (certify-book \"pwd\" 0 t :ttags (:pwd-ttag))
  ~ev[]
  One can now use this book by executing ~ilc[include-book] with keyword
  parameter ~c[:ttags (:pwd-ttag)] and then calling function
  ~c[print-working-dir]:
  ~bv[]
  (include-book \"pwd\" :ttags (:pwd-ttag))
  (print-working-dir) ; working directory is printed to terminal
  ~ev[]~/

  ~st[Detailed documentation.]
  ~bv[]
  General Forms:
  (defttag tag-name)
  (defttag tag-name :doc doc-string)
  ~ev[]
  where ~c[tag-name] is a symbol.  The ~c[:doc doc-string] argument is
  optional; if supplied, then it must be a valid ~il[documentation] string
  (~pl[doc-string]), and the ~c[defttag] call will generate a corresponding
  ~ilc[defdoc] event for ~c[tag-name].  (For the rest of this discussion we
  ignore the ~c[:doc] argument.)

  Note however that (other than the ~c[:doc] argument), if ~c[tag-name] is not
  ~c[nil] then it is converted to a ``corresponding ~il[keyword]'': a symbol in
  the ~c[\"KEYWORD\"] package with the same ~ilc[symbol-name] as ~c[tag-name].
  Thus, for example, ~c[(defttag foo)] is equivalent to ~c[(defttag :foo)].
  Moreover, a non-~c[nil] symbol with a ~ilc[symbol-name] of ~c[\"NIL\"] is
  illegal for trust tags; thus, for example, ~c[(defttag :nil)] is illegal.

  This event introduces or removes a so-called active trust tag (or ``ttag'',
  pronounced ``tee tag'').  An active ttag is a ~il[keyword] symbol that is
  associated with potentially unsafe evaluation.  For example, calls of
  ~ilc[sys-call] are illegal unless there is an active trust tag.  An active
  trust tag can be installed using a ~c[defttag] event.  If one introduces an
  active ttag and then writes definitions that calls ~ilc[sys-call], presumably
  in a defensibly ``safe'' way, then responsibility for those calls is
  attributed to that ttag.  This attribution (or blame!) is at the level of
  ~il[books]; a book's ~il[certificate] contains a list of ttags that are
  active in that book, or in a book that is included (possibly ~il[local]ly),
  or in a book included in a book that is included (either inclusion being
  potentially ~il[local]), and so on.  We explain all this in more detail
  below.

  ~c[(Defttag :tag-name)] is essentially equivalent to
  ~bv[]
  (table acl2-defaults-table :ttag :tag-name)
  ~ev[]
  and hence is ~ilc[local] to any ~il[books] and ~ilc[encapsulate] ~il[events]
  in which it occurs; ~pl[acl2-defaults-table].  We say more about the scope of
  ~c[defttag] forms below.

  Note: This is an event!  It does not print the usual event summary but
  nevertheless executes the above ~ilc[table] event and hence changes the ACL2
  logical ~il[world], and is so recorded.  Although no event summary is
  printed, it is important to note that the ``TTAG NOTE'', discussed below, is
  always printed for a non-nil ~c[:tag-name] (unless deferred;
  ~pl[set-deferred-ttag-notes]).

  ~st[Active ttags.]  Suppose ~c[tag-name] is a non-~c[nil] symbol.  Then
  ~c[(defttag :tag-name)] sets ~c[:tag-name] to be the (unique) ``active
  ttag.''  There must be an active ttag in order for there to be any mention of
  certain function and macro symbols, including ~ilc[sys-call]; evaluate the
  form ~c[(strip-cars *ttag-fns-and-macros*)] to see the full list of such
  symbols.  On the other hand, ~c[(defttag nil)] removes the active ttag, if
  any; there is then no active ttag.  The scope of a ~c[defttag] form in a book
  being certified or included is limited to subsequent forms in the same book
  before the next ~c[defttag] (if any) in that book.  Similarly, if a
  ~c[defttag] form is evaluated in the top-level loop, then its effect is
  limited to subsequent forms in the top-level loop before the next ~c[defttag]
  in the top-level loop (if any).  Moreoever, ~ilc[certify-book] is illegal
  when a ttag is active; of course, in such a circumstance one can execute
  ~c[(defttag nil)] in order to allow book certification.

  ~st[Ttag notes and the ``certifier.'']  When a ~c[defttag] is executed with
  an argument other than ~c[nil], output is printed, starting on a fresh line
  with:  ~c[TTAG NOTE].  For example:
  ~bv[]
  ACL2 !>(defttag :foo)

  TTAG NOTE: Adding ttag :FOO from the top level loop.
   :FOO
  ACL2 !>
  ~ev[]
  If the ~c[defttag] occurs in an included book, the message looks like this.
  ~bv[]
  TTAG NOTE (for included book): Adding ttag :FOO from file /u/smith/acl2/my-book.lisp.
  ~ev[]
  The ``~c[TTAG NOTE]'' message is always printed on a single line.  The
  intention is that one can search the standard output for all such notes in
  order to find all ~i[defttag] events.  In a sense, ~i[defttag] events can
  allow you to define your own system on top of ACL2 (for example,
  ~pl[progn!]).  So in order for someone else (who we might call the
  ``certifier'') to be confident that your collection of ~il[books] is
  meaningful, that certifier should certify all the user-supplied books from
  scratch and check either that no ~c[:ttags] were supplied to
  ~ilc[certify-book], or else look for every ~c[TTAG NOTE] in the standard
  output in order to locate all ~c[defttag] ~il[events] with non-~c[nil]
  tag name.  In this way, the certifier can in principle decide whether to be
  satisfied that those ~c[defttag] events did not allow inappropriate forms in
  the user-supplied books.

  In order to eliminate much of the output from ~c[TTAG NOTE]s,
  ~pl[set-deferred-ttag-notes].  Note however that the resulting security is
  somewhat less; therefore, a ~c[TTAG NOTE] is printed when invoking
  ~c[set-deferred-ttag-notes] to defer printing of ttag notes.

  ~st[Allowed ttags when certifying and including books.]  A ~c[defttag] form
  may not be evaluated unless its argument is a so-called ``allowed'' ttag.
  All ttags are allowed in the interactive top-level loop.  However, during
  ~ilc[certify-book] and ~ilc[include-book], the set of allowed ttags is
  restricted according to the ~c[:ttags] keyword argument.  If this argument is
  omitted then no ttag is allowed, so a ~c[defttag] call will fail during book
  certification or inclusion in this case.  This restriction applies even to
  ~c[defttag] forms already evaluated in the so-called certification ~il[world]
  at the time ~ilc[certify-book] is called.  But note that ~c[(defttag nil)] is
  always legal.

  A ~c[:ttags] argument of ~ilc[certify-book] and ~ilc[include-book] can have
  value ~c[:all], indicating that every ttag is allowed, i.e., no restriction
  is being placed on the arguments, just as in the interactive top-level loop.
  In the case of ~c[include-book], an omitted ~c[:ttags] argument or an
  argument of ~c[:default] is treated as ~c[:all], except that warnings will
  occur when the book's ~il[certificate] includes ttags; but for
  ~c[certify-book], an omitted ~c[ttags] argument is treated as ~c[nil].
  Otherwise, if the ~c[:ttags] argument is supplied but not ~c[:all], then its
  value is a true list of ttag specifications, each having one of the following
  forms, where ~c[sym] is a non-~c[nil] symbol which is treated as the
  corresponding ~il[keyword].
  ~bq[]

  (1) ~c[:sym]

  (2) ~c[(:sym)]

  (3) ~c[(:sym x1 x2 ... xk)], where k > 0 and each ~c[xi] is a string, except
  that one ~c[xi] may be ~c[nil].~eq[]

  In Case (1), ~c[(defttag :sym)] is allowed to occur in at most one book or
  else in the top-level loop (i.e., the certification world for a book under
  certification or a book being included).  Case (2) allows ~c[(defttag :sym)]
  to occur in an unlimited number of books.  For case (3) the ~c[xi] specify
  where ~c[(defttag :sym)] may occur, as follows.  The case that ~c[xi] is
  ~c[nil] refers to the top-level loop, while all other ~c[xi] are filenames,
  where the ~c[\".lisp\"] extension is optional and relative pathnames are
  considered to be relative to the connected book directory (~pl[cbd]).  Note
  that the restrictions on ~c[(defttag :sym)] apply equally to any equivalent
  for based on the notion of ``corresponding keyword'' discussed above, e.g.,
  ~c[(defttag acl2::sym)].

  An error message, as shown below, illustrates how ACL2 enforcess the notion
  of allowed ttags.  Suppose that you call ~ilc[certify-book] with argument
  ~c[:ttags (:foo)], where you have already executed ~c[(defttag :foo)] in the
  certification world (i.e., before calling ~ilc[certify-book]).  Then ACL2
  immediately associates the ttag ~c[:foo] with ~c[nil], where again, ~c[nil]
  refers to the top-level loop.  If ACL2 then encounters ~c[(defttag foo)]
  inside that book, you will get the following error (using the full book name
  for the book, as shown):
  ~bv[]
  ACL2 Error in ( TABLE ACL2-DEFAULTS-TABLE ...):  The ttag :FOO associated
  with file /u/smith/work/my-book.lisp is not among the set of ttags permitted
  in the current context, specified as follows:
    ((:FOO NIL)).
  See :DOC defttag.
  ~ev[]
  In general the structure displayed by the error message, which is
  ~c[((:FOO NIL))] in this case, represents the currently allowed ttags with
  elements as discussed in (1) through (3) above.  In this case, that list's
  unique element is ~c[(:FOO NIL)], meaning that ttag ~c[:FOO] is only allowed at
  the top level (as represented by ~c[NIL]).

  ~st[Associating ttags with books and with the top-level loop.]  When a book
  is certified, each form ~c[(defttag tag)] that is encountered for non-~c[nil]
  ~c[tag] in that book or an included book is recorded in the generated
  ~il[certificate], which associates the keyword corresponding to ~c[tag] with
  the ~il[full-book-name] of the book containing that ~c[deftag].  If such a
  ~c[defttag] form is encountered outside a book, hence in the ~il[portcullis]
  of the book being certified or one of its included books, then that keyword
  is associated with ~c[nil] in the generated ~il[certificate].  Note that the
  notion of ``included book'' here applies to the recursive notion of a book
  either included directly in the book being certified or else included in such
  a book, where we account even for ~il[local]ly included books.

  For examples of ways to take advantage of ttags, see community book
  ~c[books/hacking/hacker.lisp] and ~pl[ttags-seen], ~pl[progn!],
  ~pl[remove-untouchable], ~pl[set-raw-mode], and ~pl[sys-call]."

  (declare (xargs :guard (symbolp tag-name)))
  `(state-global-let*
    ((inhibit-output-lst (list* 'event 'summary (@ inhibit-output-lst))))
    (progn (table acl2-defaults-table
                  :ttag
                  ',(and tag-name
                         (intern (symbol-name tag-name) "KEYWORD")))
           ,@(cond (doc `((defdoc ,tag-name ,doc)))
                   (t nil))
           (table acl2-defaults-table :ttag))))

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

(defun ttag (wrld)

; This function returns nil if there is no active ttag.

  (declare (xargs :guard
                  (and (plist-worldp wrld)
                       (alistp (table-alist 'acl2-defaults-table wrld)))))
  (cdr (assoc-eq :ttag (table-alist 'acl2-defaults-table wrld))))

; We here document some Common Lisp functions.  The primitives are near
; the end of this file.

(defdoc complex-rationalp
  ":Doc-Section ACL2::ACL2-built-ins

  recognizes complex rational numbers~/
  ~bv[]
  Examples:
  (complex-rationalp 3)       ; nil, as 3 is rational, not complex rational
  (complex-rationalp #c(3 0)) ; nil, since #c(3 0) is the same as 3
  (complex-rationalp t)       ; nil
  (complex-rationalp #c(3 1)) ; t, as #c(3 1) is the complex number 3 + i
  ~ev[]~/

  ~l[complex] for more about complex rationals in ACL2.")

(deflabel let
  :doc
  ":Doc-Section ACL2::ACL2-built-ins

  binding of lexically scoped (local) variables~/
  ~bv[]
  Example LET Form:
  (let ((x (* x x))
        (y (* 2 x)))
   (list x y))
  ~ev[]
  If the form above is executed in an environment in which ~c[x] has the
  value ~c[-2], then the result is ~c['(4 -4)].~/

  ~c[Let] expressions bind variables so that their ``local'' values, the
  values they have when the ``body'' of the ~c[let] is evaluated, are
  possibly different than their ``global'' values, the values they
  have in the context in which the ~c[let] expression appears.  In the ~c[let]
  expression above, the local variables bound by the ~c[let] are ~c[x] and ~c[y].
  They are locally bound to the values delivered by the two forms
  ~c[(* x x)] and ~c[(* 2 x)], respectively, that appear in the
  ``bindings'' of the ~c[let].  The body of the ~c[let] is ~c[(list x y)].

  Suppose that the ~c[let] expression above occurs in a context in which ~c[x]
  has the value ~c[-2].  (The global value of ~c[y] is irrelevant to this
  example.)  For example, one might imagine that the ~c[let] form above
  occurs as the body of some function, ~c[fn], with the formal parameter ~c[x]
  and we are evaluating ~c[(fn -2)].

  To evaluate the ~c[let] above in a context in which ~c[x] is ~c[-2], we first
  evaluate the two forms specifying the local values of the variables.
  Thus, ~c[(* x x)] is evaluated and produces ~c[4] (because ~c[x] is ~c[-2]) and
  ~c[(* 2 x)] is evaluated and produces ~c[-4] (because ~c[x] is ~c[-2]).
  Then ~c[x] and ~c[y] are bound to these values and the body of the ~c[let]
  is evaluated.  Thus, when the body, ~c[(list x y)] is evaluated, ~c[x]
  is ~c[4] and ~c[y] is ~c[-4].  Thus, the body produces ~c['(4 -4)].

  Note that the binding of ~c[y], which is written after the binding of ~c[x]
  and which mentions ~c[x], nevertheless uses the global value of ~c[x], not
  the new local value.  That is, the local variables of the ~c[let] are
  bound ``in parallel'' rather than ``sequentially.'' In contrast, if
  the
  ~bv[]
  Example LET* Form:
  (let* ((x (* x x))
         (y (* 2 x)))
   (list x y))
  ~ev[]
  is evaluated when the global value of ~c[x] is ~c[-2], then the result is
  ~c['(4 8)], because the local value of ~c[y] is computed after ~c[x] has been
  bound to ~c[4].  ~ilc[Let*] binds its local variables ``sequentially.''
  ~bv[]
  General LET Forms:
  (let ((var1 term1) ... (varn termn)) body)
  and
  (let ((var1 term1) ... (varn termn))
   (declare ...) ... (declare ...)
   body)
  ~ev[]
  where the ~c[vari] are distinct variables, the ~c[termi] are terms
  involving only variables bound in the environment containing the
  ~c[let], and ~c[body] is a term involving only the ~c[vari] plus the variables
  bound in the environment containing the ~c[let].  Each ~c[vari] must be used
  in ~c[body] or else ~il[declare]d ignored.

  A ~c[let] form is evaluated by first evaluating each of the ~c[termi],
  obtaining for each a ~c[vali].  Then, each ~c[vari] is bound to the
  corresponding ~c[vali] and ~c[body] is evaluated.

  Actually, ~c[let] forms are just abbreviations for certain uses of
  ~c[lambda] notation.  In particular
  ~bv[]
  (let ((var1 term1) ... (varn termn)) (declare ...) body)
  ~ev[]
  is equivalent to
  ~bv[]
  ((lambda (var1 ... varn)
     (declare ...)
     body)
   term1 ... termn).
  ~ev[]
  ~ilc[Let*] forms are used when it is desired to bind the ~c[vari]
  sequentially, i.e., when the local values of preceding ~c[varj] are to
  be used in the computation of the local value for ~c[vari].
  ~bv[]
  General LET* Forms:
  (let* ((var1 term1) ... (varn termn)) body)
  and
  (let* ((var1 term1) ... (varn termn))
   (declare (ignore x1 ... xm))
   body)
  ~ev[]
  where the ~c[vari] are variables (not necessarily distinct), the
  ~c[termi] are terms involving only variables bound in the environment
  containing the ~ilc[let*] and those ~c[varj] such that ~c[j<i], and ~c[body] is a
  term involving only the ~c[vari] plus the variables bound in the
  environment containing the ~ilc[let*].  Each ~c[vari] must be used either in
  some subsequent ~c[termj] or in ~c[body], except that in the second form
  above we make an exception when ~c[vari] is among the ~c[xk], in which case
  ~c[vari] must not be thus used.  Note that ~ilc[let*] does not permit the
  inclusion of any ~ilc[declare] forms other than one as shown above.  In the
  second general form above, every ~c[xk] must be among the ~c[vari], and
  furthermore, ~c[xk] may not equal ~c[vari] and ~c[varj] for distinct ~c[i], ~c[j].

  The first ~ilc[let*] above is equivalent to
  ~bv[]
  (let ((var1 term1))
   ...
   (let ((varn termn)) body)...)
  ~ev[]
  Thus, the ~c[termi] are evaluated successively and after each
  evaluation the corresponding ~c[vali] is bound to the value of ~c[termi].
  The second ~ilc[let*] is similarly expanded, except that each for each
  ~c[vari] that is among the ~c[(x1 ... xm)], the form ~c[(declare (ignore vari))]
  is inserted immediately after ~c[(vari termi)].

  Each ~c[(vari termi)] pair in a ~c[let] or ~ilc[let*] form is called a ``binding''
  of ~c[vari] and the ~c[vari] are called the ``local variables'' of the ~c[let]
  or ~ilc[let*].  The common use of ~c[let] and ~ilc[let*] is to save the values of
  certain expressions (the ~c[termi]) so that they may be referenced
  several times in the body without suggesting their recomputation.

  ~c[Let] is part of Common Lisp.  See any Common Lisp documentation
  for more information.~/")

(defdoc flet

; Not mentioned here is the fact that oneify-flet-bindings drops type
; declarations in the *1* functions.  That point is so low-level that
; explaining it in the :doc topic is likely to do more harm than good.

  ":Doc-Section ACL2::ACL2-built-ins

  local binding of function symbols~/
  ~bv[]
  Example Form:
  ; The following evaluates to (mv 7 10):
  (flet ((f (x)
            (+ x 3))
         (g (x)
            (declare (type integer x))
            (* x 2)))
    (mv (f 4) (g 5)))~/

  General Forms:
  (flet (def1 ... defk) body)
  (flet (def1 ... defk) declare-form1 .. declare-formk body)
  ~ev[]
  where ~c[body] is a term, and each ~c[defi] is a definition as in ~ilc[defun]
  but with the leading ~c[defun] symbol omitted.  ~l[defun].  If any
  ~c[declare-formi] are supplied, then each must be of the form
  ~c[(declare decl1 ... decln)], where each ~c[decli] is of the form
  ~c[(inline g1 ... gm)] or ~c[(notinline g1 ... gm)], and each ~c[gi] is
  defined by some ~c[defi].

  The only effect of the declarations is to provide advice to the host Lisp
  compiler.  The declarations are otherwise ignored by ACL2, so we mainly
  ignore them in the discussion below.

  The innermost ~c[flet]-binding of a function symbol, ~c[f], above a call of
  ~c[f], is the one that provides the definition of ~c[f] for that call.  Note
  that ~c[flet] does not provide recursion.  Consider the following example.
  ~bv[]
  ; Give a global definition of f:
  (defun f (x) (+ x 3))
  ; Evaluate an expression using a local binding of f:
  (flet ((f (x) (cons x (f (1+ x)))))
    (f 4))
  ~ev[]
  In the above term ~c[(cons x (f (1+ x)))], ~c[f] refers to the global
  definition of ~c[f] above the ~c[flet] expression.  However, ~c[(f 4)] refers
  to the ~c[flet]-binding of ~c[f], ~c[(f (x) (cons x (f x)))].  The result of
  the ~c[flet] expression is thus obtained by evaluating ~c[(f 4)] where
  ~c[(f 4)] is ~c[(cons 4 (f (1+ 4)))], where the latter call of ~c[f] refers
  to the global definition; thus we have ~c[(cons 4 (f 5))], which evaluates to
  ~c[(4 . 8)].

  Although ~c[flet] behaves in ACL2 essentially as it does in Common Lisp, ACL2
  imposes the following restrictions and qualifications.
  ~bq[]
  o Every ~ilc[declare] form for a local definition (~c[def1] through ~c[defk],
  above) must be an ~c[ignore], ~c[ignorable], or ~c[type] expression.

  o Each ~c[defi] must bind a different function symbol.

  o Each ~c[defi] must bind a symbol that is a legal name for an ACL2 function
  symbol.  In particular, the symbol may not be in the keyword package or the
  main Lisp package.  Moreover, the symbol may not be a built-in ACL2 function
  or macro.

  o Every variable occurring in the body of a ~c[defi] must be a formal
  parameter of that ~c[defi].  (This restriction is not enforced in Common
  Lisp.  If the restriction is inconvenient for you, the ACL2 implementors may
  be able to remove it, with some effort, if you ask.)

  o If the ~c[flet]-binding ~c[defi] is in the body of a function ~c[f], then
  the ~il[stobj] inputs for ~c[defi] are implicitly those of its inputs that
  are declared ~il[stobj] inputs of ~c[f].~eq[]

  ~c[Flet] bindings are evaluated in parallel.  Consider the following
  example.
  ~bv[]
  (defun f (x) x)
  (flet ((f (x) (cons x x))
         (g (x) (f x)))
    (g 3))
  ~ev[]
  The binding of ~c[g] refers to the global value of ~c[f], not the
  ~c[flet]-binding of ~c[f].  Thus, the ~c[flet] expression evaluates to 3.
  Compare the ~c[flet] expression above to the following one, which instead
  evaluates to ~c[(3 . 3)].
  ~bv[]
  (defun f (x) x)
  (flet ((f (x) (cons x x)))
    (flet ((g (x) (f x)))
      (g 3)))
  ~ev[]

  Under the hood, ACL2 translates ~c[flet] bindings to ~ilc[lambda] expressions
  (~pl[term]), throwing away the ~c[inline] and ~c[notinline] declarations (if
  any).  The following example illustrates this point.
  ~bv[]
  ACL2 !>:trans (flet ((f (x) (cons x x))
                       (g (x y) (+ x y)))
                  (declare (inline f))
                  (f (g 3 4)))

  ((LAMBDA (X) (CONS X X))
   ((LAMBDA (X Y) (BINARY-+ X Y)) '3 '4))

  => *

  ACL2 !>
  ~ev[]

  ~c[Flet] is part of Common Lisp.  See any Common Lisp documentation
  for more information.  We conclude by pointing out an important aspect of
  ~c[flet] shared by ACL2 and Common Lisp: The binding is lexical, not
  dynamic.  That is, the ~c[flet] binding of a function symbol only applies to
  calls of that function symbol in the body of the ~c[flet], not other calls
  made in the course of evaluation.  Consider the following example.  Suppose
  we define:
  ~bv[]
  (defun f (x) x)
  (defun g (x) x)
  (defun h (x)
    (flet ((f (x) (cons x x)))
      (g x)))
  ~ev[]
  Then evaluation of ~c[(h 3)] results in ~c[3], not in the ~c[cons] pair
  ~c[(3 . 3)], because the ~c[flet] binding of ~c[f] only applies to calls of
  ~c[f] that appear in the body of that ~c[flet].  In this case, only ~c[g] is
  called in the body of that ~c[flet].~/")

#-acl2-loop-only
(defun-one-output what-is-the-global-state ()

;  This function is for cosmetics only and is not called by
;  anything else.  It tells you what you are implicitly passing
;  in at the global-table field when you run with *the-live-state*.

  (list (list :open-input-channels
              (let (ans)
                (do-symbols
                 (sym (find-package "ACL2-INPUT-CHANNEL"))
                 (cond ((and (get sym *open-input-channel-key*)
                             (get sym *open-input-channel-type-key*))
                        (push (cons sym
                                    (list (get sym
                                               *open-input-channel-type-key*)
                                          (strip-numeric-postfix sym)))
                              ans))))
                (sort ans (function (lambda (x y)
                                      (symbol-< (car x) (car y)))))))
        (list :open-output-channels
              (let (ans)
                (do-symbols
                 (sym (find-package "ACL2-OUTPUT-CHANNEL"))
                 (cond ((and (get sym *open-output-channel-key*)
                             (get sym *open-output-channel-type-key*))
                        (push
                         (cons sym
                               (list (get sym *open-output-channel-type-key*)
                                     (strip-numeric-postfix sym)))
                         ans))))
                (sort ans (function (lambda (x y)
                                      (symbol-< (car x) (car y)))))))
        (list :global-table (global-table-cars *the-live-state*))
        (list :t-stack
              (let (ans)
                (do ((i (1- *t-stack-length*) (1- i)))
                    ((< i 0))
                    (push (aref-t-stack i *the-live-state*) ans))
                ans))
        (list :32-bit-integer-stack
              (let (ans)
                (do ((i (1- *32-bit-integer-stack-length*) (1- i)))
                    ((< i 0))
                    (push (aref-32-bit-integer-stack i *the-live-state*) ans))
                ans))
        (list :big-clock '?)
        (list :idates '?)
        (list :acl2-oracle '?)
        (list :file-clock *file-clock*)
        (list :readable-files '?)
        (list :written-files '?)
        (list :read-files '?)
        (list :writeable-files '?)
        (list :list-all-package-names-lst '?)))

; Here we implement the macro-aliases table.

; Since books do not set the acl2-defaults-table (see the end of the :doc for
; that topic), we don't use the acl2-defaults-table to hold the macro-aliases
; information.  Otherwise, one would not be able to export associations of
; functions with new macros outside a book, which seems unfortunate.  Note that
; since macro-aliases are only used for theories, which do not affect the
; soundness of the system, it's perfectly OK to export such information.  Put
; another way:  we already allow the two passes of encapsulate to yield
; different values of theory expressions, so it's silly to start worrying now
; about the dependency of theory information on macro alias information.

(deflabel macro-aliases-table
  :doc
  ":Doc-Section switches-parameters-and-modes

  a ~il[table] used to associate function names with macro names~/
  ~bv[]
  Example:
  (table macro-aliases-table 'append 'binary-append)
  ~ev[]
  This example associates the function symbol ~ilc[binary-append] with the
  macro name ~ilc[append].  As a result, the name ~ilc[append] may be used as a
  runic designator (~pl[theories]) by the various theory functions.  Thus, for
  example, it will be legal to write
  ~bv[]
  (in-theory (disable append))
  ~ev[]
  as an abbreviation for
  ~bv[]
  (in-theory (disable binary-append))
  ~ev[]
  which in turn really abbreviates
  ~bv[]
  (in-theory (set-difference-theories (current-theory :here)
                                      '(binary-append)))~/
  General Form:

  (table macro-aliases-table 'macro-name 'function-name)
  ~ev[]
  or very generally
  ~bv[]
  (table macro-aliases-table macro-name-form function-name-form)
  ~ev[]
  where ~c[macro-name-form] and ~c[function-name-form] evaluate, respectively,
  to a macro name and a symbol in the current ACL2 ~il[world].  ~l[table] for a
  general discussion of tables and the ~c[table] event used to manipulate
  tables.

  Note that ~c[function-name-form] (above) does not need to evaluate to a
  function symbol, but only to a symbol.  As a result, one can introduce the
  alias before defining a recursive function, as follows.
  ~bv[]
  (table macro-aliases-table 'mac 'fn)
  (defun fn (x)
    (if (consp x)
        (mac (cdr x))
      x))
  ~ev[]
  Although this is obviously contrived example, this flexibility can be useful
  to macro writers; see for example the definition of ACL2 system macro
  ~ilc[defun-inline].

  The ~ilc[table] ~ilc[macro-aliases-table] is an alist that associates macro
  symbols with function symbols, so that macro names may be used as runic
  designators (~pl[theories]).  For a convenient way to add entries to this
  ~il[table], ~pl[add-macro-alias].  To remove entries from the ~il[table] with
  ease, ~pl[remove-macro-alias].

  This ~il[table] is used by the theory functions; ~pl[theories].  For example,
  in order that ~c[(disable append)] be interpreted as
  ~c[(disable binary-append)], it is necessary that the example form above has
  been executed.  In fact, this ~il[table] does indeed associate many of the
  macros provided by the ACL2 system, including ~ilc[append], with function
  symbols.  Loosely speaking, it only does so when the macro is ``essentially
  the same thing as'' a corresponding function; for example, ~c[(append x y)]
  and ~c[(binary-append x y)] represent the same term, for any expressions
  ~c[x] and ~c[y].~/")

(table macro-aliases-table nil nil
       :guard
       (and (symbolp key)
            (not (eq (getprop key 'macro-args t 'current-acl2-world world) t))
            (symbolp val)

; We no longer (as of August 2012) require that val be a function symbol, so
; that we can support recursive definition with defun-inline.  It would be nice
; to use the following code as a replacement.  However,
; chk-all-but-new-name-cmp is not defined at this point, and we don't think
; it's worth the trouble to fight this boot-strapping battle.  If we decide
; later to strengthen the guard this, then we will need to update :doc
; macro-aliases-table to require that the value is a function symbol, not just
; a symbol.

;           (mv-let (erp val)
;                   (chk-all-but-new-name-cmp
;                    val
;                    "guard for macro-aliases-table"
;                    'function
;                    world)
;                   (declare (ignore val))
;                   (null erp)))

            ))

(table macro-aliases-table nil
       '((+ . binary-+)
         (* . binary-*)
         (digit-char-p . our-digit-char-p)
         (intern . intern-in-package-of-symbol)
         (append . binary-append)
         (logand . binary-logand)
         (logior . binary-logior)
         (logxor . binary-logxor)
         (logeqv . binary-logeqv)
         (variablep . atom)
         (ffn-symb . car)
         (fargs . cdr)
         (first . car)
         (rest . cdr)
         (build-state . build-state1)
         (f-boundp-global . boundp-global)
         (f-get-global . get-global)
         (f-put-global . put-global)
         (f-big-clock-negative-p . big-clock-negative-p)
         (f-decrement-big-clock . decrement-big-clock))
       :clear)

(defun macro-aliases (wrld)
  (declare (xargs :guard (plist-worldp wrld)))
  (table-alist 'macro-aliases-table wrld))

(defmacro add-macro-alias (macro-name fn-name)

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

  associate a function name with a macro name~/
  ~bv[]
  Example:
  (add-macro-alias append binary-append)
  ~ev[]
  This example associates the function symbol ~ilc[binary-append] with the
  macro name ~ilc[append].  As a result, the name ~ilc[append] may be used as a
  runic designator (~pl[theories]) by the various theory
  functions.  ~l[macro-aliases-table] for more details.  Also ~pl[add-macro-fn]
  for an extension of this utility that also affects printing.~/
  ~bv[]
  General Form:
  (add-macro-alias macro-name function-name)
  ~ev[]
  This is a convenient way to add an entry to ~ilc[macro-aliases-table].
  ~l[macro-aliases-table] and also ~pl[remove-macro-alias].~/"

  `(table macro-aliases-table ',macro-name ',fn-name))

(add-macro-alias real/rationalp
                 #+:non-standard-analysis realp
                 #-:non-standard-analysis rationalp)

(add-macro-alias member-eq member-equal)
(add-macro-alias member member-equal)
(add-macro-alias assoc-eq assoc-equal)
(add-macro-alias assoc assoc-equal)
(add-macro-alias subsetp-eq subsetp-equal)
(add-macro-alias subsetp subsetp-equal)
(add-macro-alias no-duplicatesp-eq no-duplicatesp-equal)
(add-macro-alias no-duplicatesp no-duplicatesp-equal)
(add-macro-alias rassoc-eq rassoc-equal)
(add-macro-alias rassoc rassoc-equal)
(add-macro-alias remove-eq remove-equal)
(add-macro-alias remove remove-equal)
(add-macro-alias remove1-eq remove1-equal)
(add-macro-alias remove1 remove1-equal)
(add-macro-alias remove-duplicates-eq remove-duplicates-equal)
(add-macro-alias remove-duplicates remove-duplicates-equal)
(add-macro-alias position-ac-eq position-equal-ac)
(add-macro-alias position-eq-ac position-equal-ac)
(add-macro-alias position-ac position-equal-ac)
(add-macro-alias position-eq position-equal)
(add-macro-alias position position-equal)
(add-macro-alias set-difference-eq set-difference-equal)
(add-macro-alias set-difference$ set-difference-equal)
(add-macro-alias add-to-set-eq add-to-set-equal)
(add-macro-alias add-to-set-eql add-to-set-equal) ; for pre-v4-3 compatibility
(add-macro-alias add-to-set add-to-set-equal)
(add-macro-alias intersectp-eq intersectp-equal)
(add-macro-alias intersectp intersectp-equal)
(add-macro-alias put-assoc-eq put-assoc-equal)
(add-macro-alias put-assoc-eql put-assoc-equal) ; for pre-v4-3 compatibility
(add-macro-alias put-assoc put-assoc-equal)
(add-macro-alias delete-assoc-eq delete-assoc-equal)
(add-macro-alias delete-assoc delete-assoc-equal)
(add-macro-alias union-eq union-equal)
(add-macro-alias union$ union-equal)
(add-macro-alias intersection-eq intersection-equal)
(add-macro-alias intersection$ intersection-equal)

(defmacro remove-macro-alias (macro-name)

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

  remove the association of a function name with a macro name~/
  ~bv[]
  Example:
  (remove-macro-alias append)~/
  General Form:
  (remove-macro-alias macro-name)
  ~ev[]
  ~l[macro-aliases-table] for a discussion of macro aliases; also
  ~pl[add-macro-alias].  This form sets ~ilc[macro-aliases-table] to
  the result of deleting the key ~c[macro-name] from that ~il[table].  If
  the name does not occur in the ~il[table], then this form still generates
  an event, but the event has no real effect.~/"

  `(table macro-aliases-table nil
          (let ((tbl (table-alist 'macro-aliases-table world)))
            (if (assoc-eq ',macro-name tbl)
                (delete-assoc-eq-exec ',macro-name tbl)
              (prog2$ (cw "~%NOTE:  the name ~x0 did not appear as a key in ~
                           macro-aliases-table.  Consider using :u or :ubt to ~
                           undo this event, which is harmless but does not ~
                           change macro-aliases-table.~%"
                          ',macro-name)
                      tbl)))
          :clear))

; Here we implement the nth-aliases table.  This is quite analogous to the
; macro-aliases table; see the comment above for a discussion of why we do not
; use the acl2-defaults-table here.

(deflabel nth-aliases-table
  :doc
  ":Doc-Section switches-parameters-and-modes

  a ~il[table] used to associate names for nth/update-nth printing~/
  ~bv[]
  Example:
  (table nth-aliases-table 'st0 'st)
  ~ev[]
  This example associates the symbol ~c[st0] with the symbol ~c[st].  As a
  result, when the theorem prover prints terms of the form
  ~c[(nth n st0)] or ~c[(update-nth n val st0)], where ~c[st] is a ~il[stobj]
  whose ~c[n]th accessor function is ~c[f-n], then it will print ~c[n] as
  ~c[*f-n*].~/
  ~bv[]
  General Form:
  (table nth-aliases-table 'alias-name 'name)
  ~ev[]
  This event causes ~c[alias-name] to be treated like ~c[name] for purposes
  of the printing of terms that are calls of ~c[nth] and ~c[update-nth].
  (Note however that ~c[name] is not recursively looked up in this
  table.)  Both must be symbols other than ~ilc[state].  ~l[term], in
  particular the discussion there of untranslated terms.

  For a convenient way to add entries to this ~il[table],
  ~pl[add-nth-alias].  To remove entries from the ~il[table] with ease,
  ~pl[remove-nth-alias].~/")

(table nth-aliases-table nil nil
       :guard
       (and (symbolp key)
            (not (eq key 'state))
            (eq (getprop key 'accessor-names t
                         'current-acl2-world world)
                t)
            (symbolp val)
            (not (eq val 'state))))

(table nth-aliases-table nil nil :clear)

(defun nth-aliases (wrld)
  (declare (xargs :guard (plist-worldp wrld)))
  (table-alist 'nth-aliases-table wrld))

(defmacro add-nth-alias (alias-name name)

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

  associate one symbol with another for printing of ~ilc[nth]/~ilc[update-nth] terms~/
  ~bv[]
  Example:
  (add-nth-alias st0 st)
  ~ev[]
  This example associates the symbol ~c[st0] with the symbol
  ~c[st] for purposes of printing certain terms of the form
  ~c[(nth n st0)] and ~c[(update-nth n val st0)].~/
  ~bv[]
  General Form:
  (add-nth-alias alias-name name)
  ~ev[]
  This is a convenient way to add an entry to ~ilc[nth-aliases-table].
  ~l[nth-aliases-table] and also ~pl[remove-nth-alias].~/"

  `(table nth-aliases-table ',alias-name ',name))

(defmacro remove-nth-alias (alias-name)

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

  remove a symbol alias for printing of ~ilc[nth]/~ilc[update-nth] terms~/
  ~bv[]
  Example:
  (remove-nth-alias append)~/
  General Form:
  (remove-nth-alias alias-name)
  ~ev[]
  ~l[nth-aliases-table] for further discussion; also
  ~pl[add-nth-alias].  This form sets ~ilc[nth-aliases-table] to
  the result of deleting the key ~c[alias-name] from that ~il[table].  If
  the name does not occur in the ~il[table], then this form still generates
  an event, but the event has no real effect.~/"

  `(table nth-aliases-table nil
          (let ((tbl (table-alist 'nth-aliases-table world)))
            (if (assoc-eq ',alias-name tbl)
                (delete-assoc-eq-exec ',alias-name tbl)
              (prog2$ (cw "~%NOTE:  the name ~x0 did not appear as a key in ~
                           nth-aliases-table.  Consider using :u or :ubt to ~
                           undo this event, which is harmless but does not ~
                           change nth-aliases-table.~%"
                          ',alias-name)
                      tbl)))
          :clear))

; Here we implement the default-hints table.  This is quite analogous to the
; macro-aliases table; see the comment above for a discussion of why we do not
; use the acl2-defaults-table here.  In this case that decision is perhaps a
; little less clear; in fact, we used the acl2-defaults-table for this purpose
; before Version_2.9.  But Jared Davis pointed out that his sets books could be
; more useful if the setting of default-hints could be visible outside a book.

(deflabel default-hints-table
  :doc
  ":Doc-Section switches-parameters-and-modes

  a ~il[table] used to provide ~il[hints] for proofs~/

  Please ~pl[set-default-hints], ~pl[add-default-hints], and
  ~pl[remove-default-hints] for how to use this table.  For completeness, we
  mention here that under the hood, these events all update the
  ~c[default-hints-table] by updating its key, ~c[t], for example as follows.
  ~bv[]
  (table default-hints-table t
         '((computed-hint-1 clause)
           (computed-hint-2 clause
                            stable-under-simplificationp)))
  ~ev[]~/
  The use of default hints is explained elsewhere; ~pl[set-default-hints].

  Advanced users only: ~pl[override-hints] for an advanced variant of default
  hints.")

(defun default-hints (wrld)
  (declare (xargs :guard (and (plist-worldp wrld)
                              (alistp (table-alist 'default-hints-table
                                                   wrld)))))

  ":Doc-Section Miscellaneous

  a list of hints added to every proof attempt~/
  ~bv[]
  Examples:
  ACL2 !>(default-hints (w state))
  ((computed-hint-1 clause)
   (computed-hint-2 clause stable-under-simplificationp))
  ~ev[]
  The value returned by this function is added to the right of the
  ~c[:]~ilc[hints] argument of every ~ilc[defthm] and ~ilc[thm] command, and to
  hints provided to ~ilc[defun]s as well (~c[:hints], ~c[:guard-hints], and
  (for ACL2(r)) ~c[:std-hints]).~/

  ~l[set-default-hints] for a more general discussion.  Advanced users only:
  ~pl[override-hints] for an advanced variant of default hints that are not
  superseded by ~c[:]~ilc[hints] arguments."

  (cdr (assoc-eq t (table-alist 'default-hints-table wrld))))

(defmacro set-default-hints (lst)

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

  set the default hints~/
  ~bv[]

  Examples:
  (set-default-hints '((computed-hint-1 clause)
                       (computed-hint-2 clause
                                        stable-under-simplificationp)))
  (set-default-hints nil)
  ~ev[]

  Note: This is an event!  It does not print the usual event summary
  but nevertheless changes the ACL2 logical ~il[world] and is so
  recorded.  It is ~ilc[local] to the book or ~ilc[encapsulate] form in which it
  occurs; ~pl[set-default-hints!] for a corresponding non-~ilc[local] event.~/
  ~bv[]
  General Form:
  (set-default-hints lst)
  ~ev[]
  where ~c[lst] is a list.  Generally speaking, the elements of
  ~c[lst] should be suitable for use as ~ilc[computed-hints].

  Whenever a ~ilc[defthm] or ~ilc[thm] command is executed, the default
  hints are appended to the right of any explicitly provided
  ~c[:]~ilc[hints] in the command.  The same applies to ~ilc[defun]s as well
  (~c[:hints], ~c[:guard-hints], and (for ACL2(r)) ~c[:std-hints]).  The hints
  are then translated and processed just as though they had been explicitly
  included.

  Technically, we do not put restrictions on ~c[lst], beyond that it
  is a true list.  It would be legal to execute
  ~bv[]
  (set-default-hints '((\"Goal\" :use lemma23)))
  ~ev[]
  with the effect that the given hint is added to subsequent hints supplied
  explicitly.  An explicit \"Goal\" hint would, however, take priority, as
  suggested by the mention above of ``appended to the right.''

  Note that ~c[set-default-hints] sets the default hints as specified.
  To add to or remove from the current default, ~pl[add-default-hints] and
  ~pl[remove-default-hints].  To see the current default hints,
  ~pl[default-hints].

  Finally, note that the effects of ~c[set-default-hints],
  ~ilc[add-default-hints], and ~ilc[remove-default-hints] are ~ilc[local] to the
  book in which they appear.  Thus, users who include a book with such forms
  will not have their default hints affected by such forms.  In order to export
  the effect of setting the default hints, use ~ilc[set-default-hints!],
  ~ilc[add-default-hints!], or ~ilc[remove-default-hints!].

  For a related feature, which however is only for advanced system builders,
  ~pl[override-hints].~/"

  `(local (set-default-hints! ,lst)))

#+acl2-loop-only
(defmacro set-default-hints! (lst)

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

  set the default hints non-~ilc[local]ly~/

  Please ~pl[set-default-hints], which is the same as ~c[set-default-hints!]
  except that the latter is not ~ilc[local] to the ~ilc[encapsulate] or the book
  in which it occurs.  Probably ~il[set-default-hints] is to be preferred
  unless you have a good reason for wanting to export the effect of this event
  outside the enclosing ~ilc[encapsulate] or book.~/~/"

  `(state-global-let*
    ((inhibit-output-lst (list* 'event 'summary (@ inhibit-output-lst))))
    (progn (table default-hints-table t ,lst)
           (table default-hints-table t))))

#-acl2-loop-only
(defmacro set-default-hints! (lst)
  (declare (ignore lst))
  nil)

(defmacro add-default-hints (lst &key at-end)

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

  add to the default hints~/
  ~bv[]

  Examples:
  (add-default-hints '((computed-hint-1 clause)
                       (computed-hint-2 clause
                                        stable-under-simplificationp)))
  (add-default-hints '((computed-hint-3 id clause world))
                     :at-end t)
  ~ev[]

  Note: This is an event!  It does not print the usual event summary
  but nevertheless changes the ACL2 logical ~il[world] and is so
  recorded.  It is ~ilc[local] to the book or ~ilc[encapsulate] form in which it
  occurs (~pl[add-default-hints!] for a corresponding non-~ilc[local] event).~/
  ~bv[]
  General Forms:
  (add-default-hints lst)
  (add-default-hints lst :at-end flg)
  ~ev[]
  where ~c[lst] is a list.  Generally speaking, the elements of
  ~c[lst] should be suitable for use as ~ilc[computed-hints].

  This event is completely analogous to ~ilc[set-default-hints], the difference
  being that ~c[add-default-hints] appends the indicated hints to the front of
  the list of default hints, so that they are tried first ~-[] or, if ~c[flg]
  is supplied and evaluates to other than ~c[nil], at the end of the list, so
  that they are tried last ~-[] rather than ~st[replacing] the default hints
  with the indicated hints.  Each new hint is thus considered after each
  existing hints when both are applied to the same goal.  Also
  ~l[set-default-hints], ~pl[remove-default-hints], and ~pl[default-hints].

  Finally, note that the effects of ~c[set-default-hints],
  ~ilc[add-default-hints], and ~ilc[remove-default-hints] are ~ilc[local] to the
  book in which they appear.  Thus, users who include a book with such forms
  will not have their default hints affected by such forms.  In order to export
  the effect of setting the default hints, use ~ilc[set-default-hints!],
  ~ilc[add-default-hints!], or ~ilc[remove-default-hints!].

  For a related feature, which however is only for advanced system builders,
  ~pl[override-hints].~/"

  `(local (add-default-hints! ,lst :at-end ,at-end)))

#+acl2-loop-only
(defmacro add-default-hints! (lst &key at-end)

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

  add to the default hints non-~ilc[local]ly~/
  Please ~pl[add-default-hints], which is the same as ~c[add-default-hints!]
  except that the latter is not ~ilc[local] to the ~ilc[encapsulate] or the book
  in which it occurs.  Probably ~il[add-default-hints] is to be preferred
  unless you have a good reason for wanting to export the effect of this event
  outside the enclosing ~ilc[encapsulate] or book.~/~/"

  `(state-global-let*
    ((inhibit-output-lst (list* 'event 'summary (@ inhibit-output-lst))))
    (progn (table default-hints-table t
                  (if ,at-end
                      (append (default-hints world) ,lst)
                    (append ,lst (default-hints world))))
           (table default-hints-table t))))

#-acl2-loop-only
(defmacro add-default-hints! (lst)
  (declare (ignore lst))
  nil)

(defmacro remove-default-hints (lst)

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

  remove from the default hints~/
  ~bv[]

  Examples:
  (remove-default-hints '((computed-hint-1 clause)
                          (computed-hint-2 clause
                                           stable-under-simplificationp)))
  ~ev[]

  Note: This is an event!  It does not print the usual event summary but
  nevertheless changes the ACL2 logical ~il[world] and is so recorded.  It is
  ~ilc[local] to the book or ~ilc[encapsulate] form in which it occurs
  (~pl[remove-default-hints!] for a corresponding non-~ilc[local] event).~/
  ~bv[]
  General Form:
  (remove-default-hints lst)
  ~ev[]
  where ~c[lst] is a list.  Generally speaking, the elements of
  ~c[lst] should be suitable for use as ~ilc[computed-hints].  Also
  ~pl[add-default-hints].

  If some elements of the given list do not belong to the existing default
  hints, they will simply be ignored by this event.

  Also ~l[set-default-hints], ~pl[add-default-hints], and ~pl[default-hints].

  Finally, note that the effects of ~c[set-default-hints],
  ~ilc[add-default-hints], and ~ilc[remove-default-hints] are ~ilc[local] to the
  book in which they appear.  Thus, users who include a book with such forms
  will not have their default hints affected by such forms.  In order to export
  the effect of setting the default hints, use ~ilc[set-default-hints!],
  ~ilc[add-default-hints!], or ~ilc[remove-default-hints!].~/"

  `(local (remove-default-hints! ,lst)))

#+acl2-loop-only
(defmacro remove-default-hints! (lst)

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

  remove from the default hints non-~ilc[local]ly~/
  Please ~pl[remove-default-hints], which is the same as ~c[remove-default-hints!]
  except that the latter is not ~ilc[local] to the ~ilc[encapsulate] or the book
  in which it occurs.  Probably ~il[remove-default-hints] is to be preferred
  unless you have a good reason for wanting to export the effect of this event
  outside the enclosing ~ilc[encapsulate] or book.~/~/"

  `(state-global-let*
    ((inhibit-output-lst (list* 'event 'summary (@ inhibit-output-lst))))
    (progn (table default-hints-table t
                  (set-difference-equal (default-hints world) ,lst))
           (table default-hints-table t))))

#-acl2-loop-only
(defmacro remove-default-hints! (lst)
  (declare (ignore lst))
  nil)

#+acl2-loop-only
(defmacro set-override-hints-macro (lst at-end ctx)
  `(state-global-let*
    ((inhibit-output-lst (list* 'summary (@ inhibit-output-lst))))
    (set-override-hints-fn ,lst ,at-end ,ctx (w state) state)))

#-acl2-loop-only
(defmacro set-override-hints-macro (&rest args)
  (declare (ignore args))
  nil)

(defmacro add-override-hints! (lst &key at-end)

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

  add non-~il[local]ly to the ~il[override-hints]~/

  ~c[Add-override-hints!] is the same as ~ilc[add-override-hints], except that
  the former is not ~il[local] to ~il[books] or ~ilc[encapsulate] ~il[events]
  in which it occurs.  ~l[add-override-hints]; also
  ~pl[set-override-hints].~/~/"

  (declare (xargs :guard (booleanp at-end)))
  `(set-override-hints-macro ,lst ,at-end 'add-override-hints!))

(defmacro add-override-hints (lst &key at-end)

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

  add to the ~il[override-hints]~/

  ~l[override-hints] for a discussion of override-hints.  Here we describe how
  to extend the list of override-hints.  Note that the effects of
  ~c[add-override-hints] ~il[events] are ~il[local] to the ~il[books] or
  ~c[encapsulate] ~il[events] in which they reside; ~pl[add-override-hints!] to
  avoid that restriction.  Also ~pl[set-override-hints] to set a new list of
  override-hints to it, ignoring the present list rather than adding to it.

  ~bv[]
  General Forms:
  (add-override-hints form)
  (add-override-hints form :at-end t)
  (add-override-hints form :at-end nil) ; default for :at-end
  ~ev[]
  where ~c[form] evaluates to a list of computed hint forms.  The effect of
  this event is to extend the current list of ~il[override-hints] by appending
  the result of that evaluation.  The default is to append the evaluation
  result to the front of the current list of override-hints, but if
  ~c[:at-end t] is specified, then the evaluation result is appended to the end
  of the current list.~/~/"

  (declare (xargs :guard (booleanp at-end)))
  `(local
    (set-override-hints-macro ,lst ,at-end 'add-override-hints)))

(defmacro set-override-hints! (lst)

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

  set the ~il[override-hints] non-~il[local]ly~/

  ~c[Set-override-hints!] is the same as ~ilc[set-override-hints], except that
  the former is not ~il[local] to ~il[books] or ~ilc[encapsulate] ~il[events]
  in which it occurs.  ~l[set-override-hints]; also
  ~pl[add-override-hints].~/~/"

  `(set-override-hints-macro ,lst :clear 'set-override-hints!))

(defmacro set-override-hints (lst)

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

  set the ~il[override-hints]~/

  ~l[override-hints] for a discussion of override-hints.  Here we describe how
  to set them.  Note that the effects of ~c[set-override-hints] ~il[events] are
  ~il[local] to the ~il[books] or ~c[encapsulate] ~il[events] in which they
  reside; ~pl[set-override-hints!] to avoid that restriction.  Also
  ~pl[add-override-hints] to add to the list of override-hints, rather than
  setting a new list and ignoring the present list.

  ~bv[]
  General Form:
  (set-override-hints form)
  ~ev[]
  where ~c[form] evaluates to a list of computed hint forms.  The effect of
  this event is to set the list of ~il[override-hints] to the result of that
  evaluation.~/~/"

  `(local
    (set-override-hints-macro ,lst :clear 'set-override-hints)))

(defmacro remove-override-hints! (lst)

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

  delete non-~il[local]ly from the list of ~il[override-hints]~/

  ~c[Remove-override-hints!] is the same as ~ilc[remove-override-hints], except
  that the former is not ~il[local] to ~il[books] or ~ilc[encapsulate]
  ~il[events] in which it occurs.  ~l[remove-override-hints]; also
  ~pl[add-override-hints] and ~pl[set-override-hints].~/~/"

  `(set-override-hints-macro ,lst :remove 'remove-override-hints!))

(defmacro remove-override-hints (lst)

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

  delete from the list of ~il[override-hints]~/

  ~l[override-hints] for a discussion of override-hints.  Here we describe how
  to delete from the list of override-hints.  Note that the effects of
  ~c[remove-override-hints] ~il[events] are ~il[local] to the ~il[books] or
  ~c[encapsulate] ~il[events] in which they reside; ~pl[remove-override-hints!]
  to avoid that restriction.  Also ~pl[add-override-hints] and
  ~pl[set-override-hints].

  ~bv[]
  General Form:
  (remove-override-hints form)
  ~ev[]
  where ~c[form] should evaluate to a list of computed hint forms.  The effect
  of this event is to set the list of ~il[override-hints] to the result of
  deleting each element of the evaluation result from the ~il[override-hints],
  if that element indeed belongs to the override-hints; no check is made that
  these elements are actually elements of the existing override-hints.~/~/"

  `(local
    (set-override-hints-macro ,lst :remove 'remove-override-hints)))

(defmacro set-rw-cache-state (val)

; Essay on Rw-cache

; Introduction

; We cache failed attempts to relieve hypotheses.  The basic idea is that
; whenever a hypothesis rewrites to other than true, we store that fact so that
; the rewrite rule is not tried again with the same unify-subst.  The failure
; information is stored in tag-trees.  Two kinds of failures are stored: those
; for which the unify-subst includes at least one variable bound from an
; earlier free-variable hypothesis (the "free-failure" cases), and the rest
; (the "normal-failure" cases).  The free-failure case is stored in a tree
; structure with normal-failures at the leaves; see the definition of record
; rw-cache-entry.  Normal-failures are recognized by
; rw-cacheable-failure-reason, which is an attachable function.  When cached
; failures are found, they can be ignored if the user attaches to
; relieve-hyp-failure-entry-skip-p.

; When relieve-hyps is called, it looks in the tag-tree for a relevant failure.
; If a normal-failure record is found, then the attempt can quickly fail.  If a
; free-failure record is found, then it is passed along through the process of
; relieving the hypotheses, so that after variables are bound by a hypothesis,
; this record can be consulted on subsequent hypotheses to abort rewriting.
; New failure information is recorded upon exit from relieve-hyps; in the
; free-failure case, the information to be recorded was accumulated during the
; process of relieving hypotheses.

; Rw-cache-states: *legal-rw-cache-states* = (t nil :disabled :atom)

; In a preliminary implementation we tried a scheme in which the rw-cache
; persisted through successive literals of a clause.  However, we encountered
; dozens of failures in the regression suite, some of them probably because the
; tail-biting heuristic was causing failures whose caching wasn't suitable for
; other literals.  Such a scheme, which also allows the rw-cache to persist to
; a single child, is represented by rw-cache-state t.  When a clause reaches
; stable-under-simplificationp without any appropriate computed hint, if the
; state is t then it transitions to :disabled so that a pass is made through
; simplify-clause without interference from the rw-cache.  (See for example the
; end of waterfall-step-cleanup.)  Some failures with rw-cache-state t
; disappear if the rw-cache-state begins at :disabled, so that some preliminary
; simplification occurs before any failure caching.

; But even starting with :disabled, we have seen regression failures.
; Therefore our default rw-cache-state is :atom, which creates a fresh rw-cache
; for each literal of a clause; see rewrite-atm.  An advantage of :atom is that
; we do not transition to a disabled state.  That transition for rw-cache-state
; t is responsible for larger numbers reported in event summaries for "Prover
; steps counted" in the mini-proveall, presumably because an extra pass must be
; made through the simplifier sometime before going into induction even though
; that rarely helps (probably, never in the mini-proveall).

; Overview of some terminology, data structures, and algorithms

; We store relieve-hyps failures in tag-trees.  As we discuss below, there are
; two tags associated with this failure information: 'rw-cache-any-tag and
; 'rw-cache-nil-tag.  Each tag is associated with what we also call an
; "rw-cache".  Sometimes we refer abstractly the values of both tags as the
; "rw-cache"; we expect that the context will resolve any possible confusion
; between the value of a tag and the entire cache (from both tags).  Each tag's
; value is what we call a "psorted symbol-alist": a true list that may have at
; most one occurrence of t, where each non-t element is a cons pair whose car
; is a symbol, and where the tail past the occurrence of t (if any) is sorted
; by car.  In general, the notion of "psorted" can be applied to any kind of
; true-list that has a natural notion of "sort" associated with it: then a
; psorted list is one that has at most one occurrence of t as a member, such
; that (cdr (member-equal t s)) is sorted.  Indeed, we use a second kind of
; psorted list, which we call an "rw-cache-list": the elements (other than t)
; are rw-cache-entry records, and the sort relation is lexorder.  By using
; psorted lists, we defer the cost of sorting until merge-time, where sorting
; is important to avoid quadratic blow-up; the use of t as a marker allows us
; to avoid re-sorting the same list.

; We maintain the invariant that the information in the "nil" cache is also in
; the "any" cache.  The "nil" cache is thus more restrictive: it only stores
; cases in which the failure is suitable for a stronger context.  It gets its
; name because one such case is when a hypothesis rewrites to nil.  But we also
; store syntaxp and bind-free hypotheses that fail (except, we never store such
; failures when extended metafunctions are involved, because of their high
; level of dependence on context beyond the unify-subst).  Thus, the "nil"
; cache is preserved when we pass to a branch of an IF term; the "any" cache is
; however replaced in that case by the "nil" cache (which preserves the above
; invariant).  On the other hand, when we pop up out of an IF branch, we throw
; away any accumulation into the "nil" cache but we merge the new "any" cache
; into the old "any" cache.  See rw-cache-enter-context and
; rw-cache-exit-context.

; The following definitions and trace$ forms can be evaluated in order to do
; some checking of the above invariant during subsequent proofs (e.g., when
; followed by :mini-proveall).

;   (defun rw-tagged-objects-subsetp (alist1 alist2)
;     (declare (xargs :mode :program))
;     (cond ((endp alist1) t)
;           (t (and (or (eq (car alist1) t)
;                       (subsetp-equal (cdar alist1)
;                                      (cdr (assoc-rw-cache (caar alist1)
;                                                           alist2))))
;                   (rw-tagged-objects-subsetp (cdr alist1) alist2)))))
;
;   (defun chk-rw-cache-inv (ttree string)
;     (declare (xargs :mode :program))
;     (or (rw-tagged-objects-subsetp (tagged-objects 'rw-cache-nil-tag ttree)
;                                    (tagged-objects 'rw-cache-any-tag ttree))
;         (prog2$ (cw string)
;                 (break$))))
;
;   (trace$ (relieve-hyps
;            :entry (chk-rw-cache-inv ttree "Relieve-hyps entry~%")
;            :exit (chk-rw-cache-inv (car (last values)) "Relieve-hyps exit~%")
;            :evisc-tuple :no-print))
;   (trace$ (rewrite
;            :entry (chk-rw-cache-inv ttree "Rewrite entry~%")
;            :exit (chk-rw-cache-inv (car (last values)) "Rewrite exit~%")
;            :evisc-tuple :no-print))
;   (trace$ (rewrite-fncall
;            :entry (chk-rw-cache-inv ttree "Rewrite-fncall entry~%")
;            :exit (chk-rw-cache-inv (car (last values)) "Rewrite-fncall exit~%")
;            :evisc-tuple :no-print))

; Our rw-cache-entry records store a unify-subst rather than an instance of a
; rule's left-hand side.  One advantage is that the unify-subst may be smaller,
; because of repeated occurrences of a variable on the left-hand side.  Another
; advantage is that in the normal-failure case, we restrict the unify-subst to
; the variables occurring in the failed hypothesis; see the call of
; restrict-alist-to-all-vars in note-relieve-hyp-failure.  This clearly permits
; more hits in the rw-cache, and of course it may result in less time being
; spent in equality checking (see the comment in restrict-alist-to-all-vars
; about the order being unchanged by restriction).

; Here we record some thoughts on a preliminary implementation, in which we
; kept the "nil" and "any" caches disjoint, rather than including the "nil"
; cache in the "any" cache.

;   With that preliminary implementation, we accumulated both the "nil" and
;   "any" caches into the "any" cache when popping out of an IF context.  We
;   experimented a bit with instead ignoring the "nil" cache, even though we
;   could lose some cache hits.  We saw two potential benefits for such a
;   change.  For one, it would save the cost of doing the union operation that
;   would be required.  For another, it would give us a chance to record a hit
;   outside that IF context as a bona fide "nil" entry, which is preserved when
;   diving into future IF contexts or (for rw-cache-state t) into a unique
;   subgoal.  Ultimately, though, experiments pointed us to continuing our
;   popping of "nil" entries into the "any" cache.

; Finally, we list some possible improvements that could be considered.

;   Consider sorting in the free-failure case (see
;   combine-free-failure-alists).

;   Remove assert$ in split-psorted-list1 (which checks that t doesn't occur
;   twice in a list).

;   For free-failure case, consider optimizing to avoid checking for equality
;   against a suitable tail of unify-subst that know must be equal; see for
;   example rw-cache-list-lookup and replace-free-rw-cache-entry1.

;   For free-failure case, consider doing a tighter job of assigning the
;   failure-reason to a unify-subst.  For example, if hypothesis 2 binds free
;   variable y and hypothesis 5 binds free variable z, and hypothesis 6 is (foo
;   y) and its rewrite fails, then associate the failure with the binding of y
;   at hypothesis 2.  And in that same scenario, if hypothesis 6 is instead
;   (foo x), where x is bound on the left-hand side of the rule, then create a
;   normal-failure reason instead of a free-failure reason.  If we make any
;   such change, then revisit the comments in (defrec rw-cache-entry ...).

;   In restrict-alist-to-all-vars, as noted in a comment there,
;   we could do a better job of restricting the unify-subst in the case of
;   at least one binding hypothesis.

;   In accumulate-rw-cache1, consider eliminating a COND branch that can
;   require an equality test to save a few conses, as noted in a comment
;   there.

;   Modify accumulate-rw-cache to be more efficient, by taking advantage of the
;   invariant that the "nil" cache is contained in the "any" cache.

;   Consider saving a few conses in rw-cache-exit-context by avoiding
;   modification of the nil cache if the old and new nil caches are equal,
;   indeed, eq.  Maybe a new primitive that tests with eq, but has a guard that
;   the true and false branches are equal, would help.  (Maybe this would
;   somehow be implemented using return-last.)  It is not sufficient to check
;   the lengths of the caches, or even of their elements, because with
;   free-vars one can make an extension without changing these lengths.

;   Perhaps modify restore-rw-cache-any-tag to extend old "any" cache with the
;   new "nil" cache, instead of throwing away new "nil" entries entirely.  See
;   restore-rw-cache-any-tag.

;   Extend debug handling to free case in relieve-hyps, and/or explain in :doc
;   (or at least comments) how this works.

;   Perhaps we could keep around the "nil" cache longer than we currently do.

;   Consider changing functions in the rewrite nest that deal with linear
;   arithmetic, such as add-linear-lemma, to use the rw-cache of the input
;   ttree rather than ignoring it, and to return a ttree with an extension of
;   that rw-cache.  A related idea is to take more advantage in such functions
;   of rw-caches in intermediate ttrees, such as rw-caches in ttrees of
;   irrelevant-pot-lst values in rewrite-with-linear.  [The two of us discussed
;   this idea.  I think we decided that although we can't rule out the value of
;   the above, maybe it's not too important.  Note that when the pot-lst
;   contributes to the proof, the cache entries will then work their way into
;   the main tag-tree.]  There may be other opportunities to accumulate into
;   rw-caches, for example inside simplify-clause1 by passing input ttree0 into
;   pts-to-ttree-lst, under the call of setup-simplify-clause-pot-lst.

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

  set the default rw-cache-state~/

  The ACL2 rewriter uses a data structure, called the rw-cache (rewriter
  cache), to save failed attempts to apply conditional ~il[rewrite] rules.  The
  regression suite has taken approximately 11% less time with this mechanism.
  The rw-cache is active by default but this event allows it to be turned off
  or modified.  Note that this event is ~il[local] to its context (from
  ~ilc[encapsulate] or ~ilc[include-book]).  For a non-local version, use
  ~il[set-rw-cache-state!].

  ~bv[]
  Example forms:
  (set-rw-cache-state :atom)     ; default: rw-cache cleared for each literal
                                 ;   (i.e., hypothesis or conclusion of a goal)
  (set-rw-cache-state nil)       ; rw-cache is inactive
  (set-rw-cache-state t)         ; rw-cache persists beyond each literal
  (set-rw-cache-state :disabled) ; rw-cache is inactive, but the rw-cache-state
                                 ;   transitions to state t after
                                 ;   simplification takes place~/

  General Form:
  (set-rw-cache-state val)
  ~ev[]
  where ~c[val] evaluates to one of the four values shown in ``Example forms''
  above.  The default is ~c[:atom], which enables the rw-cache but clears it
  before rewriting a hypothesis or conclusion of any goal.  The value ~c[t] is
  provides more aggresive use of the rw-cache, basically preserving the
  rw-cache when there is a single subgoal.  The value ~c[:disabled] is the same
  as ~c[t], except that the rw-cache is initially inactive and only becomes
  active when some simplification has taken place.  We have seen a few cases
  where value ~c[t] will make a proof fail but ~c[:disabled] does not.

  The following example illustrates the rw-cache in action.  You will see a
  break during evaluation of the ~ilc[thm] form.  Type ~c[:eval] and you will
  see a failed rewriting attempt.  Type ~c[:go] to continue, and at the next
  break type ~c[:eval] again.  This time you will see the same failed rewriting
  attempt, but this time labeled with a notation saying that the failure was
  cached earlier, which indicates that this time the rewriter did not even
  attempt to prove the hypothesis of the ~il[rewrite] rule ~c[f1->f2].

  ~bv[]
  (defstub f1 (x) t)
  (defstub f2 (x) t)
  (defaxiom f1->f2
           (implies (f1 x) (equal (f2 x) t)))
  :brr t
  :monitor (:rewrite f1->f2) t
  (thm (equal (car (f2 a)) (cdr (f2 a))))
  ~ev[]

  Note: This is an event!  It does not print the usual event summary
  but nevertheless changes the ACL2 logical ~il[world] and is so
  recorded.  It is ~ilc[local] to the book or ~ilc[encapsulate] form in which it
  occurs (~pl[set-rw-cache-state!] for a corresponding non-~ilc[local] event).

  We also note that rw-cache-state changes may also be caused at the subgoal
  level; ~pl[hints].

  We welcome you to experiment with different rw-cache states.  If the more
  aggressive values of ~c[t] and ~c[:disabled] cause proofs to fail, then you
  can revert to the default of ~c[:atom] or even turn off the rw-cache using
  ~c[(set-rw-cache-state nil)].  We don't expect users to need a deep knowledge
  of the rw-cache in order to do such experiments, but readers interested in
  details of the rw-cache implementation are invited to read the ``Essay on
  Rw-cache'' in the ACL2 source code.~/"

  `(local (set-rw-cache-state! ,val)))

#+acl2-loop-only
(defmacro set-rw-cache-state! (val)

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

  set the default rw-cache-state non-~ilc[local]ly~/
  Please ~pl[set-rw-cache-state], which is the same as ~c[set-rw-cache-state!]
  except that the latter is not ~ilc[local] to the ~ilc[encapsulate] or the book
  in which it occurs.~/~/"

  `(state-global-let*
    ((inhibit-output-lst (list* 'event 'summary (@ inhibit-output-lst))))
    (progn (table rw-cache-state-table t ,val)
           (table rw-cache-state-table t))))

#-acl2-loop-only
(defmacro set-rw-cache-state! (val)
  (declare (ignore val))
  nil)

(defconst *legal-rw-cache-states*
  '(t nil :disabled :atom))

(table rw-cache-state-table nil nil
       :guard
       (case key
         ((t) (member-eq val *legal-rw-cache-states*))
         (t nil)))

(defun fix-true-list (x)

  ":Doc-Section ACL2::ACL2-built-ins

  coerce to a true list~/

  ~c[Fix-true-list] is the identity function on ~ilc[true-listp] objects.
  It converts every list to a true list by dropping the final ~ilc[cdr],
  and it converts every ~il[atom] to ~c[nil].

  To see the ACL2 definition of this function, ~pl[pf].~/~/"

  (declare (xargs :guard t))
  (if (consp x)
      (cons (car x)
            (fix-true-list (cdr x)))
    nil))

(defthm pairlis$-fix-true-list
  (equal (pairlis$ x (fix-true-list y))
         (pairlis$ x y)))

(defun boolean-listp (lst)

; We define this in axioms.lisp so that we can use this function in theorems
; whose proof uses BDDs.

  (declare (xargs :guard t))
  (cond ((atom lst) (eq lst nil))
        (t (and (or (eq (car lst) t)
                    (eq (car lst) nil))
                (boolean-listp (cdr lst))))))

(defthm boolean-listp-cons

; This rule is important for simplifying the trivial boolean-listp hypothesis
; of a goal that is given to the OBDD package.

  (equal (boolean-listp (cons x y))
         (and (booleanp x)
              (boolean-listp y))))

(defthm boolean-listp-forward

; We expect this rule to be crucial in many circumstances where a :BDD hint is
; given.

  (implies (boolean-listp (cons a lst))
           (and (booleanp a)
                (boolean-listp lst)))
  :rule-classes :forward-chaining)

(defthm boolean-listp-forward-to-symbol-listp

; We expect this rule, in combination with symbol-listp-forward-to-true-listp,
; to be crucial in many circumstances where a :BDD hint is given.

  (implies (boolean-listp x)
           (symbol-listp x))
  :rule-classes :forward-chaining)

; Here we record axioms pertaining to the values returned by primitives on
; inputs violating their guards.  These all have :rule-classes nil, and should
; be kept in sync with the defun-*1* definitions in interface-raw.lisp, as
; well as with the documentation that follows them.

; In some of these cases we prove rewrite rules that default "wrong" arguments.
; We think this will help linear arithmetic, among other things, without
; significantly slowing down the rewriter.  We'll see.

(defaxiom completion-of-+
  (equal (+ x y)
         (if (acl2-numberp x)
             (if (acl2-numberp y)
                 (+ x y)
               x)
           (if (acl2-numberp y)
               y
             0)))
  :rule-classes nil)

(defthm default-+-1
  (implies (not (acl2-numberp x))
           (equal (+ x y) (fix y)))
  :hints (("Goal" :use completion-of-+)))

(defthm default-+-2
  (implies (not (acl2-numberp y))
           (equal (+ x y) (fix x)))
  :hints (("Goal" :use completion-of-+)))

(defaxiom completion-of-*
  (equal (* x y)
         (if (acl2-numberp x)
             (if (acl2-numberp y)
                 (* x y)
               0)
           0))
  :rule-classes nil)

(defthm default-*-1
  (implies (not (acl2-numberp x))
           (equal (* x y) 0)))

(defthm default-*-2
  (implies (not (acl2-numberp y))
           (equal (* x y) 0)))

(defaxiom completion-of-unary-minus
  (equal (- x)
         (if (acl2-numberp x)
             (- x)
           0))
  :rule-classes nil)

(defthm default-unary-minus
  (implies (not (acl2-numberp x))
           (equal (- x) 0)))

(defaxiom completion-of-unary-/
  (equal (/ x)
         (if (and (acl2-numberp x)
                  (not (equal x 0)))
             (/ x)
           0))
  :rule-classes nil)

(defthm default-unary-/
  (implies (or (not (acl2-numberp x))
               (equal x 0))
           (equal (/ x) 0)))

;; RAG - This axiom was strengthened to include the reals.

(defaxiom completion-of-<
  (equal (< x y)
         (if (and (real/rationalp x)
                  (real/rationalp y))
             (< x y)
           (let ((x1 (if (acl2-numberp x) x 0))
                 (y1 (if (acl2-numberp y) y 0)))
             (or (< (realpart x1) (realpart y1))
                 (and (equal (realpart x1) (realpart y1))
                      (< (imagpart x1) (imagpart y1)))))))
  :rule-classes nil)

(defthm default-<-1
  (implies (not (acl2-numberp x))
           (equal (< x y)
                  (< 0 y)))
  :hints (("Goal" :use
           (completion-of-<
            (:instance completion-of-<
                       (x 0))))))

(defthm default-<-2
  (implies (not (acl2-numberp y))
           (equal (< x y)
                  (< x 0)))
  :hints (("Goal" :use
           (completion-of-<
            (:instance completion-of-<
                       (y 0))))))

(defaxiom completion-of-car
  (equal (car x)
         (cond
          ((consp x)
           (car x))
          (t nil)))
  :rule-classes nil)

(defthm default-car
  (implies (not (consp x))
           (equal (car x) nil)))

(defaxiom completion-of-cdr
  (equal (cdr x)
         (cond
          ((consp x)
           (cdr x))
          (t nil)))
  :rule-classes nil)

(defthm default-cdr
  (implies (not (consp x))
           (equal (cdr x) nil)))

(defthm cons-car-cdr
  (equal (cons (car x) (cdr x))
         (if (consp x)
             x
           (cons nil nil))))

(defaxiom completion-of-char-code
  (equal (char-code x)
         (if (characterp x)
             (char-code x)
           0))
  :rule-classes nil)

(defthm default-char-code
  (implies (not (characterp x))
           (equal (char-code x) 0))
  :hints (("Goal" :use completion-of-char-code)))

(defaxiom completion-of-code-char
  (equal (code-char x)
         (if (and (integerp x)
                  (>= x 0)
                  (< x 256))
             (code-char x)
           (code-char 0)))
  :rule-classes nil)

; Omitted for now; maybe slows down the rewriter too much.
;
; (defthm default-code-char
;   (implies (not (and (integerp x)
;                      (>= x 0)
;                      (< x 256)))
;            (equal (code-char x)
;                   (code-char 0)))
;   :hints (("Goal" :use completion-of-code-char)))

;; RAG - This axiom was strengthened to include the reals.

(defaxiom completion-of-complex
  (equal (complex x y)
         (complex (if (real/rationalp x) x 0)
                  (if (real/rationalp y) y 0)))
  :rule-classes nil)

;; RAG - This axiom was weakened to include the reals.

(defthm default-complex-1
  (implies (not (real/rationalp x))
           (equal (complex x y)
                  (complex 0 y)))
  :hints (("Goal" :use completion-of-complex)))

;; RAG - This axiom was weakened to include the reals.

(defthm default-complex-2
  (implies (not (real/rationalp y))
           (equal (complex x y)
                  (if (real/rationalp x) x 0)))
  :hints (("Goal" :use ((:instance completion-of-complex)
                        (:instance complex-definition (y 0))))))

;; RAG - This axiom was modified to include the reals.

(defthm complex-0
  (equal (complex x 0)
         #+:non-standard-analysis
         (realfix x)
         #-:non-standard-analysis
         (rfix x))
  :hints (("Goal" :use ((:instance complex-definition (y 0))))))

(defthm add-def-complex
  (equal (+ x y)
         (complex (+ (realpart x) (realpart y))
                  (+ (imagpart x) (imagpart y))))
  :hints (("Goal" :use ((:instance complex-definition
                                   (x (+ (realpart x) (realpart y)))
                                   (y (+ (imagpart x) (imagpart y))))
                        (:instance complex-definition
                                   (x (realpart x))
                                   (y (imagpart x)))
                        (:instance complex-definition
                                   (x (realpart y))
                                   (y (imagpart y))))))
  :rule-classes nil)

(defthm realpart-+
  (equal (realpart (+ x y))
         (+ (realpart x) (realpart y)))
  :hints (("Goal" :use add-def-complex)))

(defthm imagpart-+
  (equal (imagpart (+ x y))
         (+ (imagpart x) (imagpart y)))
  :hints (("Goal" :use add-def-complex)))

(defaxiom completion-of-coerce
  (equal (coerce x y)
         (cond
          ((equal y 'list)
           (if (stringp x)
               (coerce x 'list)
             nil))
          (t
           (coerce (make-character-list x) 'string))))
  :rule-classes nil)

(defthm default-coerce-1
  (implies (not (stringp x))
           (equal (coerce x 'list)
                  nil))
  :hints (("Goal" :use (:instance completion-of-coerce (y 'list)))))

(defthm make-character-list-make-character-list
  (equal (make-character-list (make-character-list x))
         (make-character-list x)))

(defthm default-coerce-2
  (implies (and (syntaxp (not (equal y ''string)))
                (not (equal y 'list)))
           (equal (coerce x y) (coerce x 'string)))
  :hints (("Goal"
           :use ((:instance completion-of-coerce)
                 (:instance completion-of-coerce
                            (x x)
                            (y 'string))))))

; This next one is weaker than it could be.  If x is not a true list of
; characters it is coerced to one with make-character-list.  We deal with only
; the simplest case where x is some atom.

(defthm default-coerce-3
  (implies (not (consp x))
           (equal (coerce x 'string)
                  ""))
  :hints (("Goal" :use (:instance completion-of-coerce (y 'string)))))

(defaxiom completion-of-denominator
  (equal (denominator x)
         (if (rationalp x)
             (denominator x)
           1))
  :rule-classes nil)

(defthm default-denominator
  (implies (not (rationalp x))
           (equal (denominator x)
                  1))
  :hints (("Goal" :use completion-of-denominator)))

;; RAG - The following axioms give the rules for working with the
;; undefined predicate floor1.  We start with the completion axiom,
;; which says floor1 is only useful for real numbers.

#+:non-standard-analysis
(defaxiom completion-of-floor1
  (equal (floor1 x)
         (if (realp x)
             (floor1 x)
           0))
  :rule-classes nil)

;; RAG - The second axiom about floor1 is that it returns 0 for any
;; invalid argument.

#+:non-standard-analysis
(defthm default-floor1
  (implies (not (realp x))
           (equal (floor1 x)
                  0)))

;; RAG - We also know that floor1 is the identity function for the integers.

#+:non-standard-analysis
(defaxiom floor1-integer-x
  (implies (integerp x)
           (equal (floor1 x) x)))

;; RAG - And, we know that the floor1 of x is no larger than x itself.

#+:non-standard-analysis
(defaxiom floor1-x-<=-x
  (implies (realp x)
           (<= (floor1 x) x))
  :rule-classes :linear)

;; RAG - Finally, we know that the floor1 of x is larger than x-1.

#+:non-standard-analysis
(defaxiom x-<-add1-floor1-x
  (implies (realp x)
           (< x (1+ (floor1 x))))
  :rule-classes :linear)

;; RAG - This theorem is useful for proving the value of floor1 is a
;; specific value.  It is probably only useful when instantiated
;; manually, so we do not make it a rewrite rule.

#+:non-standard-analysis
(defthm floor1-value
  (implies (and (realp x)
                (integerp fx)
                (<= fx x)
                (< x (1+ fx)))
           (equal (floor1 x) fx))
  :rule-classes nil)

(defaxiom completion-of-imagpart
  (equal (imagpart x)
         (if (acl2-numberp x)
             (imagpart x)
           0))
  :rule-classes nil)

(defthm default-imagpart
  (implies (not (acl2-numberp x))
           (equal (imagpart x)
                  0)))

(defaxiom completion-of-intern-in-package-of-symbol
  (equal (intern-in-package-of-symbol x y)
         (if (and (stringp x)
                  (symbolp y))

; We avoid calling INTERN here, which might otherwise lead to a guard
; violation.  It's certainly OK to lay down the original call at this point!

             (intern-in-package-of-symbol x y)
           nil))
  :rule-classes nil)

; (defthm default-intern-in-package-of-symbol
;   (implies (not (and (stringp x)
;                      (symbolp y)))
;            (equal (intern-in-package-of-symbol x y)
;                   nil))
;   :hints (("Goal" :use completion-of-intern-in-package-of-symbol)))

(defaxiom completion-of-numerator
  (equal (numerator x)
         (if (rationalp x)
             (numerator x)
           0))
  :rule-classes nil)

(defthm default-numerator
  (implies (not (rationalp x))
           (equal (numerator x)
                  0)))

(defaxiom completion-of-realpart
  (equal (realpart x)
         (if (acl2-numberp x)
             (realpart x)
           0))
  :rule-classes nil)

(defthm default-realpart
  (implies (not (acl2-numberp x))
           (equal (realpart x)
                  0)))

(defaxiom completion-of-symbol-name
  (equal (symbol-name x)
         (if (symbolp x)
             (symbol-name x)
           ""))
  :rule-classes nil)

(defthm default-symbol-name
  (implies (not (symbolp x))
           (equal (symbol-name x)
                  ""))
  :hints (("Goal" :use completion-of-symbol-name)))

(defaxiom completion-of-symbol-package-name
  (equal (symbol-package-name x)
         (if (symbolp x)
             (symbol-package-name x)
           ""))
  :rule-classes nil)

(defthm default-symbol-package-name
  (implies (not (symbolp x))
           (equal (symbol-package-name x)
                  ""))
  :hints (("Goal" :use completion-of-symbol-package-name)))

;; RAG - Here, I put in the basic theory that we will use for
;; non-standard analysis.

(defdoc i-small
  ":Doc-Section ACL2::Real

  ACL2(r) recognizer for infinitesimal numbers~/

  ~c[(I-small x)] is true if and only if ~c[x] is an infinitesimal
  number (possibly 0).  This predicate is only defined in ACL2(r)
  (~pl[real]).~/~/")

(defdoc i-close
  ":Doc-Section ACL2::Real

  ACL2(r) test for whether two numbers are infinitesimally close~/

  ~c[(I-close x y)] is true if and only if ~c[x-y] is an infinitesimal number.
  This predicate is only defined in ACL2(r) (~pl[real]).~/~/")

(defdoc i-large
  ":Doc-Section ACL2::Real

  ACL2(r) recognizer for infinitely large numbers~/

  ~c[(I-large x)] is true if and only if ~c[x] is non-zero and ~c[1/x] is an
  infinitesimal number.  This predicate is only defined in ACL2(r)
  (~pl[real]).~/~/")

(defdoc i-limited
  ":Doc-Section ACL2::Real

  ACL2(r) recognizer for limited numbers~/

  ~c[(I-limited x)] is true if and only if ~c[x] is a number that is not
  infinitely large.  This predicate is only defined in ACL2(r)
  (~pl[real]).~/~/")

(defdoc standardp
  ":Doc-Section ACL2::Real

  ACL2(r) recognizer for standard objects~/

  ~c[(Standardp x)] is true if and only if ~c[x] is a ``standard''
  object.  This notion of ``standard'' comes from non-standard analysis
  and is discussed in Ruben Gamboa's dissertation.  In brief, all the
  familiar objects are standard: e.g., the familiar real numbers are
  standard, but non-zero infinitesimals are not standard, and the familiar
  integers are standard, but not those that exceed every integer that
  you can express in the usual way (1, 2, 3, and so on).  Similarly,
  the familiar lists are standard, but not so a list that contains a
  large number of integers, where ``large'' means more than the standard
  integers.  The set of standard numbers is closed under the usual
  arithmetic operations, hence the sum of a standard number and a
  non-zero infinitesimal is not standard, though it is what is called
  ``limited'' (~pl[i-limited]).

  This predicate is only defined in ACL2(r) (~pl[real]).~/~/")

(defdoc standard-part
  ":Doc-Section ACL2::Real

  ACL2(r) function mapping limited numbers to standard numbers~/

  ~c[(Standard-part x)] is, for a given ~ilc[i-limited] number ~c[x], the unique
  real number infinitesimally close (~pl[i-close]) to ~c[x].  This
  function is only defined in ACL2(r) (~pl[real]).~/~/")

#+:non-standard-analysis
(progn

(defun i-small (x)
  (declare (xargs :guard t))
  (and (acl2-numberp x)
       (equal (standard-part x) 0)))

(defun i-close (x y)
  (declare (xargs :guard t))
  (and (acl2-numberp x)
       (acl2-numberp y)
       (i-small (- x y))))

(defun i-large (x)
  (declare (xargs :guard t))
  (and (acl2-numberp x)
       (not (equal x 0))
       (i-small (/ x))))

(defmacro i-limited (x)
  `(and (acl2-numberp ,x)
        (not (i-large ,x))))

; The first axiom is crucial in the theory.  We establish that there
; is at least one non-standard number, namely (i-large-integer).

(defaxiom i-large-integer-is-large
  (i-large (i-large-integer)))

; Now, we have some axioms about standardp.  Standardp
; behaves reasonably with respect to the arithmetic operators.
; RAGTODO: Some of these are theorems now, and should be introduced
; as theorems instead of axioms.

(defaxiom standardp-plus
  (implies (and (standardp x)
                (standardp y))
           (standardp (+ x y))))

(defaxiom standardp-uminus
  (equal (standardp (- x))
         (standardp (fix x))))

(defaxiom standardp-times
  (implies (and (standardp x)
                (standardp y))
           (standardp (* x y))))

(defaxiom standardp-udivide
  (equal (standardp (/ x))
         (standardp (fix x))))

(defaxiom standardp-complex
  (equal (standardp (complex x y))
         (and (standardp (realfix x))
              (standardp (realfix y)))))

; The following should not be needed; in fact, when attempting to interpret
; this terms as a rewrite rule, ACL2(r) will complain because (cons-term
; 'standardp ''1) is *t*.
(defaxiom standardp-one
  (standardp 1)
  :rule-classes nil)

;; Now, we have some theorems (axioms?) about standard-part.

(defaxiom standard-part-of-standardp
  (implies (and (acl2-numberp x)
                (standardp x))
           (equal (standard-part x) x)))

(defaxiom standardp-standard-part
  (implies (i-limited x)
           (standardp (standard-part x))))

(defaxiom standard-part-of-reals-is-idempotent
  (implies (realp x)
           (equal (standard-part (standard-part x))
                  (standard-part x))))

(defaxiom standard-part-of-complex
  (equal (standard-part (complex x y))
         (complex (standard-part x) (standard-part y))))

;; We consider the arithmetic operators now.

(defaxiom standard-part-of-plus
  (equal (standard-part (+ x y))
         (+ (standard-part (fix x))
            (standard-part (fix y)))))

(defaxiom standard-part-of-uminus
  (equal (standard-part (- x))
         (- (standard-part (fix x)))))

(defaxiom standard-part-of-times
  (implies (and (i-limited x) (i-limited y))
           (equal (standard-part (* x y))
                  (* (standard-part x) (standard-part y)))))

(defaxiom standard-part-of-udivide
  (implies (and (i-limited x)
                (not (i-small x)))
           (equal (standard-part (/ x))
                  (/ (standard-part x)))))

(defaxiom standard-part-<=
  (implies (and (realp x)
                (realp y)
                (<= x y))
           (<= (standard-part x) (standard-part y))))

(defaxiom small-are-limited
  (implies (i-small x)
           (i-limited x))
  :rule-classes (:forward-chaining :rewrite))

(in-theory (disable (:rewrite small-are-limited)))

(defaxiom standards-are-limited
  (implies (and (acl2-numberp x)
                (standardp x))
           (i-limited x))
  :rule-classes (:forward-chaining :rewrite))

(defthm standard-constants-are-limited
  (implies (and (syntaxp (and (consp x) (eq (car x) 'quote)))
                (acl2-numberp x)
                (standardp x))
           (i-limited x)))

(in-theory (disable (:rewrite standards-are-limited)))

(defaxiom limited-integers-are-standard
  (implies (and (i-limited x)
                (integerp x))
           (standardp x))
  :rule-classes (:forward-chaining :rewrite))
(in-theory (disable (:rewrite limited-integers-are-standard)))

(defaxiom standard+small->i-limited
  (implies (and (standardp x)
                (i-small eps))
           (i-limited (+ x eps))))
(in-theory (disable standard+small->i-limited))

)

(defdoc acl2-numberp
  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for numbers~/

  ~c[(acl2-numberp x)] is true if and only if ~c[x] is a number, i.e., a
  rational or complex rational number.~/~/")

(defdoc +
  ":Doc-Section ACL2::ACL2-built-ins

  addition macro~/

  ~c[+] is really a macro that expands to calls of the function
  ~ilc[binary-+].  So for example
  ~bv[]
  (+ x y 4 z)
  ~ev[]
  represents the same term as
  ~bv[]
  (binary-+ x (binary-+ y (binary-+ 4 z))).
  ~ev[]
  ~l[binary-+].~/~/")

(defdoc binary-+
  ":Doc-Section ACL2::ACL2-built-ins

  addition function~/

  Completion Axiom (~c[completion-of-+]):
  ~bv[]
  (equal (binary-+ x y)
         (if (acl2-numberp x)
             (if (acl2-numberp y)
                 (binary-+ x y)
               x)
           (if (acl2-numberp y)
               y
             0)))
  ~ev[]~/
  ~il[Guard] for ~c[(binary-+ x y)]:
  ~bv[]
  (and (acl2-numberp x) (acl2-numberp y))
  ~ev[]
  Notice that like all arithmetic functions, ~c[binary-+] treats
  non-numeric inputs as ~c[0].

  Calls of the macro ~ilc[+] expand to calls of ~c[binary-+];
  ~pl[+].")

(defdoc binary-*
  ":Doc-Section ACL2::ACL2-built-ins

  multiplication function~/

  Completion Axiom (~c[completion-of-*]):
  ~bv[]
  (equal (binary-* x y)
         (if (acl2-numberp x)
             (if (acl2-numberp y)
                 (binary-* x y)
               0)
           0))
  ~ev[]~/
  ~il[Guard] for ~c[(binary-* x y)]:
  ~bv[]
  (and (acl2-numberp x) (acl2-numberp y))
  ~ev[]
  Notice that like all arithmetic functions, ~c[binary-*] treats
  non-numeric inputs as ~c[0].

  Calls of the macro ~ilc[*] expand to calls of ~c[binary-*];
  ~pl[*].")

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

  macro for subtraction and negation~/

  ~l[binary-+] for addition and ~pl[unary--] for negation.~/

  Note that ~c[-] represents subtraction as follows:
  ~bv[]
  (- x y)
  ~ev[]
  represents the same term as
  ~bv[]
  (+ x (- y))
  ~ev[]
  which is really
  ~bv[]
  (binary-+ x (unary-- y)).
  ~ev[]
  Also note that ~c[-] represents arithmetic negation as follows:
  ~bv[]
  (- x)
  ~ev[]
  expands to
  ~bv[]
  (unary-- x).
  ~ev[]
  ")

(defdoc unary--
  ":Doc-Section ACL2::ACL2-built-ins

  arithmetic negation function~/

  Completion Axiom (~c[completion-of-unary-minus]):
  ~bv[]
  (equal (unary-- x)
         (if (acl2-numberp x)
             (unary-- x)
           0))
  ~ev[]~/
  ~il[Guard] for ~c[(unary-- x)]:
  ~bv[]
  (acl2-numberp x)
  ~ev[]
  Notice that like all arithmetic functions, ~c[unary--] treats
  non-numeric inputs as ~c[0].

  Calls of the macro ~ilc[-] on one argument expand to calls of
  ~c[unary--]; ~pl[-].")

(defdoc unary-/
  ":Doc-Section ACL2::ACL2-built-ins

  reciprocal function~/

  Completion Axiom (~c[completion-of-unary-/]):
  ~bv[]
  (equal (unary-/ x)
         (if (and (acl2-numberp x)
                  (not (equal x 0)))
             (unary-/ x)
           0))
  ~ev[]~/
  ~il[Guard] for ~c[(unary-/ x)]:
  ~bv[]
  (and (acl2-numberp x)
       (not (equal x 0)))
  ~ev[]
  Notice that like all arithmetic functions, ~c[unary-/] treats
  non-numeric inputs as ~c[0].

  Calls of the macro ~ilc[/] on one argument expand to calls of
  ~c[unary-/]; ~pl[/].")

(defdoc <
  ":Doc-Section ACL2::ACL2-built-ins

  less-than~/

  Completion Axiom (~c[completion-of-<]):
  ~bv[]
  (equal (< x y)
         (if (and (rationalp x)
                  (rationalp y))
             (< x y)
           (let ((x1 (if (acl2-numberp x) x 0))
                 (y1 (if (acl2-numberp y) y 0)))
             (or (< (realpart x1) (realpart y1))
                 (and (equal (realpart x1) (realpart y1))
                      (< (imagpart x1) (imagpart y1)))))))
  ~ev[]~/

  ~il[Guard] for ~c[(< x y)]:
  ~bv[]
  (and (rationalp x) (rationalp y))
  ~ev[]
  Notice that like all arithmetic functions, ~c[<] treats non-numeric
  inputs as ~c[0].

  This function has the usual meaning on the rational numbers, but is
  extended to the complex rational numbers using the lexicographic
  order:  first the real parts are compared, and if they are equal,
  then the imaginary parts are compared.")

(defdoc car
  ":Doc-Section ACL2::ACL2-built-ins

  returns the first element of a non-empty list, else ~c[nil]~/

  Completion Axiom (~c[completion-of-car]):
  ~bv[]
  (equal (car x)
         (cond
          ((consp x)
           (car x))
          (t nil)))
  ~ev[]~/
  ~il[Guard]:
  ~bv[]
  (or (consp x) (equal x nil))
  ~ev[]
  Notice that in the ACL2 logic, ~c[car] returns ~c[nil] for every ~il[atom].")

(defdoc cdr
  ":Doc-Section ACL2::ACL2-built-ins

  returns the second element of a ~ilc[cons] pair, else ~c[nil]~/

  Completion Axiom (~c[completion-of-cdr]):
  ~bv[]
  (equal (cdr x)
         (cond
          ((consp x)
           (cdr x))
          (t nil)))
  ~ev[]~/
  ~il[Guard]:
  ~bv[]
  (or (consp x) (equal x nil))
  ~ev[]
  Notice that in the ACL2 logic, ~c[cdr] returns ~c[nil] for every ~il[atom].")

(defdoc char-code
  ":Doc-Section ACL2::ACL2-built-ins

  the numeric code for a given character~/

  Completion Axiom (~c[completion-of-char-code]):
  ~bv[]
  (equal (char-code x)
         (if (characterp x)
             (char-code x)
           0))
  ~ev[]~/
  ~il[Guard] for ~c[(char-code x)]:
  ~bv[]
  (characterp x)
  ~ev[]
  This function maps all non-characters to ~c[0].")

(defdoc characterp
  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for ~il[characters]~/

  ~c[(characterp x)] is true if and only if ~c[x] is a
  character.~/~/")

(defdoc code-char
  ":Doc-Section ACL2::ACL2-built-ins

  the character corresponding to a given numeric code~/

  Completion Axiom (~c[completion-of-code-char]):
  ~bv[]
  (equal (code-char x)
         (if (and (integerp x)
                  (>= x 0)
                  (< x 256))
             (code-char x)
           (code-char 0)))
  ~ev[]~/
  ~il[Guard] for ~c[(code-char x)]:
  ~bv[]
  (and (integerp x)
       (>= x 0)
       (< x 256))
  ~ev[]
  ACL2 supports 8-bit ~il[characters].  Inputs not between ~c[0] and ~c[255]
  are treated as ~c[0].")

(defdoc complex
  ":Doc-Section ACL2::ACL2-built-ins

  create an ACL2 number~/
  ~bv[]
  Examples:
  (complex x 3) ; x + 3i, where i is the principal square root of -1
  (complex x y) ; x + yi
  (complex x 0) ; same as x, for rational numbers x~/
  ~ev[]
  The function ~c[complex] takes two rational number arguments and
  returns an ACL2 number.  This number will be of type
  ~c[(complex rational)] [as defined in the Common Lisp language], except
  that if the second argument is zero, then ~c[complex] returns its first
  argument.  The function ~ilc[complex-rationalp] is a recognizer for
  complex rational numbers, i.e. for ACL2 numbers that are not
  rational numbers.

  The reader macro ~c[#C] (which is the same as ~c[#c]) provides a convenient
  way for typing in complex numbers.  For explicit rational numbers ~c[x]
  and ~c[y], ~c[#C(x y)] is read to the same value as ~c[(complex x y)].

  The functions ~ilc[realpart] and ~ilc[imagpart] return the real and imaginary
  parts (respectively) of a complex (possibly rational) number.  So
  for example, ~c[(realpart #C(3 4)) = 3], ~c[(imagpart #C(3 4)) = 4],
  ~c[(realpart 3/4) = 3/4], and ~c[(imagpart 3/4) = 0].

  The following built-in axiom may be useful for reasoning about complex
  numbers.
  ~bv[]
  (defaxiom complex-definition
    (implies (and (real/rationalp x)
                  (real/rationalp y))
             (equal (complex x y)
                    (+ x (* #c(0 1) y))))
    :rule-classes nil)
  ~ev[]

  A completion axiom that shows what ~c[complex] returns on arguments
  violating its ~il[guard] (which says that both arguments are rational
  numbers) is the following, named ~c[completion-of-complex].
  ~bv[]
  (equal (complex x y)
         (complex (if (rationalp x) x 0)
                  (if (rationalp y) y 0)))
  ~ev[]
  ")

(defdoc cons
  ":Doc-Section ACL2::ACL2-built-ins

  pair and list constructor~/

  ~c[(cons x y)] is a pair whose first component is ~c[x] and second
  component is ~c[y].  If ~c[y] is a list, then ~c[(cons x y)] is a list
  that has an addtional element ~c[x] on the front.~/~/")

(defdoc consp
  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for ~il[cons] pairs~/

  ~c[(consp x)] is true if and only if ~c[x] is a ~il[cons] pair.~/~/")

(defdoc coerce

; Jared Davis has written a faster version of coercing a character list to a
; string, which is displayed just below.  But we have decided not to try to
; meddle with the underlying Lisp implementation of coerce (though on 2/27/09
; Bob Boyer temporarily added a patch from Gary Byers to hons-raw.lisp to speed
; this up for CCL).  Jared adds (6/30/09) that CCL now handles coerce
; efficiently, both to strings and to lists.

;  (defun my-coerce (chars)
;    (let* ((length (the integer (length (the list chars))))
;           (str    (the vector (make-string (the integer length))))
;           (i      (the integer 0)))
;      (loop for char in chars
;            do
;            (setf (aref (the vector str) (the integer i))
;                  (the character char))
;            (incf (the integer i)))
;      str))

  ":Doc-Section ACL2::ACL2-built-ins

  coerce a character list to a string and a string to a list~/

  Completion Axiom (~c[completion-of-coerce]):
  ~bv[]
  (equal (coerce x y)
         (cond
          ((equal y 'list)
           (if (stringp x)
               (coerce x 'list)
             nil))
          (t
           (coerce (make-character-list x) 'string))))
  ~ev[]~/
  ~il[Guard] for ~c[(coerce x y)]:
  ~bv[]
  (if (equal y 'list)
      (stringp x)
    (if (equal y 'string)
        (character-listp x)
      nil))
  ~ev[]

  Also see community book ~c[books/misc/fast-coerce.lisp], contributed by Jared
  Davis, for a version of ~c[coerce] that may be faster for Common Lisp
  implementations other than CCL 1.3 or later, if the second argument is
  ~c['list] (for coercing a string to a list).  ~/")

(defdoc denominator
  ":Doc-Section ACL2::ACL2-built-ins

  divisor of a ratio in lowest terms~/

  Completion Axiom (~c[completion-of-denominator]):
  ~bv[]
  (equal (denominator x)
         (if (rationalp x)
             (denominator x)
           1))
  ~ev[]~/
  ~il[Guard] for ~c[(denominator x)]:
  ~bv[]
  (rationalp x)
  ~ev[]
  ~/")

(defdoc equal
  ":Doc-Section ACL2::ACL2-built-ins

  true equality~/

  ~c[(equal x y)] is equal to ~c[t] or ~c[nil], according to whether or
  not ~c[x] and ~c[y] are the same value.~/

  For a discussion of the various idioms for testing against 0,
  ~l[zero-test-idioms].~/")

(defdoc if
  ":Doc-Section ACL2::ACL2-built-ins

  if-then-else function~/

  ~c[(if x y z)] is equal to ~c[y] if ~c[x] is any value
  other than ~c[nil], and is equal to ~c[z] if ~c[x] is ~c[nil].~/

  Only one of ~c[y], ~c[z] is evaluated when ~c[(if x y z)] is
  evaluated.

  ~c[If] has a ~il[guard] of ~c[t].

  ~c[If] is part of Common Lisp.  See any Common Lisp documentation for
  more information.~/")

(defdoc imagpart
  ":Doc-Section ACL2::ACL2-built-ins

  imaginary part of a complex number~/

  Completion Axiom (~c[completion-of-imagpart]):
  ~bv[]
  (equal (imagpart x)
         (if (acl2-numberp x)
             (imagpart x)
           0))
  ~ev[]~/
  ~il[Guard] for ~c[(imagpart x)]:
  ~bv[]
  (acl2-numberp x)
  ~ev[]
  ~/")

(defdoc integerp
  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for whole numbers~/

  ~c[(integerp x)] is true if and only if ~c[x] is an integer.~/~/")

(defdoc intern-in-package-of-symbol
  ":Doc-Section ACL2::ACL2-built-ins

  create a symbol with a given name~/

  Completion Axiom (~c[completion-of-intern-in-package-of-symbol]):
  ~bv[]
  (equal (intern-in-package-of-symbol x y)
         (if (and (stringp x)
                  (symbolp y))
             (intern-in-package-of-symbol x y)
           nil))
  ~ev[]~/
  ~il[Guard] for ~c[(intern-in-package-of-symbol x y)]:
  ~bv[]
  (and (stringp x) (symbolp y))
  ~ev[]

  Intuitively, ~c[(intern-in-package-of-symbol x y)] creates a symbol
  with ~ilc[symbol-name] ~c[x] ~il[intern]ed in the package containing ~c[y].
  More precisely, suppose ~c[x] is a string, ~c[y] is a symbol with
  ~ilc[symbol-package-name] pkg and that the ~ilc[defpkg] event creating pkg
  had the list of symbols imports as the value of its second argument.
  Then ~c[(intern-in-package-of-symbol x y)] returns a symbol, ans, the
  ~ilc[symbol-name] of ans is ~c[x], and the ~ilc[symbol-package-name] of ans
  is pkg, unless ~c[x] is the ~ilc[symbol-name] of some member of imports
  with ~ilc[symbol-package-name] ipkg, in which case the
  ~ilc[symbol-package-name] of ans is ipkg.  Because ~ilc[defpkg] requires
  that there be no duplications among the ~ilc[symbol-name]s of the
  imports, ~c[intern-in-package-of-symbol] is uniquely defined.

  For example, suppose ~c[\"MY-PKG\"] was created by
  ~bv[]
  (defpkg \"MY-PKG\" '(ACL2::ABC LISP::CAR)).
  ~ev[]
  Let ~c[w] be ~c['my-pkg::witness].  Observe that
  ~bv[]
  (symbolp w) is t                     ; w is a symbol
  (symbol-name w) is \"WITNESS\"         ; w's name is \"WITNESS\"
  (symbol-package-name w) is \"MY-PKG\"  ; w is in the package \"MY-PKG\"
  ~ev[]
  The construction of ~c[w] illustrates one way to obtain a symbol in a given
  package:  write it down as a constant using the double-colon notation.

  But another way to obtain a symbol in a given package is to create it with
  ~c[intern-in-package-of-symbol].
  ~bv[]
  (intern-in-package-of-symbol \"XYZ\" w) is MY-PKG::XYZ

  (intern-in-package-of-symbol \"ABC\" w) is ACL2::ABC

  (intern-in-package-of-symbol \"CAR\" w) is LISP::CAR

  (intern-in-package-of-symbol \"car\" w) is MY-PKG::|car|
  ~ev[]")

(defdoc numerator
  ":Doc-Section ACL2::ACL2-built-ins

  dividend of a ratio in lowest terms~/

  Completion Axiom (~c[completion-of-numerator]):
  ~bv[]
  (equal (numerator x)
         (if (rationalp x)
             (numerator x)
           0))
  ~ev[]~/
  ~il[Guard] for ~c[(numerator x)]:
  ~bv[]
  (rationalp x)
  ~ev[]
  ~/")

(defdoc rationalp
  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for rational numbers (ratios and integers)~/

  ~c[(rationalp x)] is true if and only if ~c[x] is an rational
  number.~/~/")

(defdoc realpart
  ":Doc-Section ACL2::ACL2-built-ins

  real part of a complex number~/

  Completion Axiom (~c[completion-of-realpart]):
  ~bv[]
  (equal (realpart x)
         (if (acl2-numberp x)
             (realpart x)
           0))
  ~ev[]~/
  ~il[Guard] for ~c[(realpart x)]:
  ~bv[]
  (acl2-numberp x)
  ~ev[]
  ~/")

(defdoc stringp
  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for strings~/

  ~c[(stringp x)] is true if and only if ~c[x] is a string.~/~/")

(defdoc symbol-name
  ":Doc-Section ACL2::ACL2-built-ins

  the name of a symbol (a string)~/

  Completion Axiom (~c[completion-of-symbol-name]):
  ~bv[]
  (equal (symbol-name x)
         (if (symbolp x)
             (symbol-name x)
           \"\"))
  ~ev[]~/
  ~il[Guard] for ~c[(symbol-name x)]:
  ~bv[]
  (symbolp x)
  ~ev[]
  ~/")

(defdoc symbol-package-name
  ":Doc-Section ACL2::ACL2-built-ins

  the name of the package of a symbol (a string)~/

  WARNING: While ~c[symbol-package-name] behaves properly on all ACL2 objects,
  it may give surprising results when called in raw Lisp.  For more details
  ~pl[pkg-imports], in particular the discussion there of the
  ~c[\"COMMON-LISP\"] package.

  Completion Axiom (~c[completion-of-symbol-package-name]):
  ~bv[]
  (equal (symbol-package-name x)
         (if (symbolp x)
             (symbol-package-name x)
           \"\"))
  ~ev[]~/
  ~il[Guard] for ~c[(symbol-package-name x)]:
  ~bv[]
  (symbolp x)
  ~ev[]
  Note: ~c[Symbol-package-name] may diverge from the name of the symbol's
  package in raw Lisp, in the case that this package is the main Lisp package.
  For example, in GCL ~c[(symbol-package-name 'car)] evaluates to
  \"COMMON-LISP\" even though the actual package name for the symbol, ~c[car],
  is \"LISP\".~/")

(defdoc symbolp
  ":Doc-Section ACL2::ACL2-built-ins

  recognizer for symbols~/

  ~c[(symbolp x)] is true if and only if ~c[x] is a symbol.~/~/")

(defdoc quote
  ":Doc-Section ACL2::ACL2-built-ins

  create a constant~/

  The form ~c[(quote x)] evaluates to ~c[x].  See any Common Lisp
  documentation.~/~/")

(defun double-rewrite (x)
  (declare (xargs :guard t))
  ":Doc-Section Miscellaneous

  cause a term to be rewritten twice~/

  Logically, ~c[double-rewrite] is the ~ilc[identity] function:
  ~c[(double-rewrite x)] is equal to ~c[x].  However, the ACL2 rewriter treats
  calls of ~c[double-rewrite] in the following special manner.  When it
  encounters a term ~c[(double-rewrite u)], it first rewrites ~c[u] in the current
  context, and then the rewriter rewrites the result.

  Such double-rewriting is rarely necessary, but it can be useful when
  rewriting under non-trivial equivalence relations (~pl[equivalence]).  The
  following example will illustrate the issue.
  ~bv[]
  ; Define an equivalence relation.
  (defun my-equiv (x y)
    (equal x y))
  (defequiv my-equiv)

  ; Define a unary function whose argument is preserved by my-equiv.
  (defun foo (x)
    (declare (ignore x))
    t)
  (defcong my-equiv equal (foo x) 1)

  ; Define some other unary functions.
  (defun g (x) x)
  (defun h1 (x) x)
  (defun h2 (x) x)

  ; Prove some lemmas and then disable the functions above.
  (defthm lemma-1
    (my-equiv (h1 x) (h2 x)))
  (defthm lemma-2
    (foo (h2 x)))
  (defthm lemma-3
    (implies (foo x)
             (equal (g x) x)))
  (in-theory (union-theories (theory 'minimal-theory)
                             '(lemma-1 lemma-2 lemma-3
                               my-equiv-implies-equal-foo-1)))

  ; Attempt to prove a simple theorem that follows ``obviously'' from the
  ; events above.
  (thm (equal (g (h1 a)) (h1 a)))
  ~ev[]
  We might expect the proof of this final ~c[thm] to succeed by the following
  reasoning.  It is immediate from ~c[lemma-3] provided we can establish
  ~c[(foo (h1 a))].  By the ~c[defcong] event above, we know that
  ~c[(foo (h1 a))] equals ~c[(foo (h2 a))] provided
  ~c[(my-equiv (h1 a) (h2 a))]; but this is immediate from ~c[lemma-1].  And
  finally, ~c[(foo (h2 a))] is true by ~c[lemma-2].

  Unfortunately, the proof fails.  But fortunately, ACL2 gives the following
  useful warning when ~c[lemma-3] is submitted:
  ~bv[]
  ACL2 Warning [Double-rewrite] in ( DEFTHM LEMMA-3 ...):  In the :REWRITE
  rule generated from LEMMA-3, equivalence relation MY-EQUIV is maintained
  at one problematic occurrence of variable X in hypothesis (FOO X),
  but not at any binding occurrence of X.  Consider replacing that occurrence
  of X in this hypothesis with (DOUBLE-REWRITE X).  See :doc double-
  rewrite for more information on this issue.
  ~ev[]
  We can follow the warning's advice by changing ~c[lemma-3] to the following.
  ~bv[]
  (defthm lemma-3
    (implies (foo (double-rewrite x))
             (equal (g x) x)))
  ~ev[]
  With this change, the proof succeeds for the final ~c[thm] above.

  In practice, it should suffice for users to follow the advice given in the
  ``~c[Double-rewrite]'' warnings, by adding calls of ~c[double-rewrite] around
  certain variable occurrences.  But this can cause inefficiency in large proof
  efforts.  For that reason, and for completeness, it seems prudent to explain
  more carefully what is going on; and that is what we do for the remainder of
  this ~il[documentation] topic.  Optionally, also see the paper ``Double
  Rewriting for Equivalential Reasoning in ACL2'' by Matt Kaufmann and J
  Strother Moore, in the proceedings of the 2006 ACL2 Workshop
  (paper is published in ACM Digital Library,
  ~url[http://portal.acm.org/toc.cfm?id=1217975]).~/

  ~st[Suggesting congruence rules.]

  Sometimes the best way to respond to a ``~c[Double-rewrite]'' warning may be
  to prove a congruence rule.  Consider for example this rule.
  ~bv[]
  (defthm insert-sort-is-id
    (perm (insert-sort x) x))
  ~ev[]
  Assuming that ~c[perm] has been identified as an ~il[equivalence] relation
  (~pl[defequiv]), we will get the following warning.
  ~bv[]
  ACL2 Warning [Double-rewrite] in ( DEFTHM INSERT-SORT-IS-ID ...):
  In a :REWRITE rule generated from INSERT-SORT-IS-ID, equivalence relation
  PERM is maintained at one problematic occurrence of variable X in the
  right-hand side, but not at any binding occurrence of X.  Consider
  replacing that occurrence of X in the right-hand side with
  (DOUBLE-REWRITE X).  See :doc double-rewrite for more information on
  this issue.
  ~ev[]
  The problem is that the second occurrence of ~c[x] (the right-hand side of
  the rule ~c[insert-sort-is-id]) is in a context where ~c[perm] is to be
  maintained, yet in this example, the argument ~c[x] of ~c[insert-sort] on the
  left-hand side of that rule is in a context where ~c[perm] will not be
  maintained.  This can lead one to consider the possibility that ~c[perm]
  could be maintained in that left-hand side occurrence of ~c[x], and if so, to
  prove the following congruence rule.
  ~bv[]
  (defcong perm perm (insert-sort x) 1)
  ~ev[]
  This will eliminate the above warning for ~c[insert-sort-is-id].  More
  important, this ~ilc[defcong] event would probably be useful, since it would
  allow rewrite rules with equivalence relation ~c[perm] to operate on the
  first argument of any call of ~c[insert-sort] whose context calls for
  maintaining ~c[perm].

  ~st[Details on double-rewrite.]

  The reader who wants these details may first wish to ~pl[equivalence] for
  relevant review.

  The ACL2 rewriter takes a number of contextual arguments,
  including the generated equivalence relation being maintained
  (~pl[congruence]) and an association list that maps variables to terms.  We
  call the latter alist the ~c[unify-subst] because it is produced by unifying
  (actually matching) a pattern against a current term; let us explain this
  point by returning to the example above.  Consider what happens when the
  rewriter is given the top-level goal of the ~c[thm] above.
  ~bv[]
  (equal (g (h1 a)) (h1 a))
  ~ev[]
  This rewrite is performed with the empty alist (~c[unify-subst]), and is
  begun by rewriting the first argument (in that same empty ~c[unify-subst]):
  ~bv[]
  (g (h1 a))
  ~ev[]
  Note that the only equivalence relation being maintained at this point is
  ~c[equal].  Now, the rewriter notices that the left-hand side of ~c[lemma-3],
  which is ~c[(g x)], matches ~c[(g (h1 a))].  The rewriter thus creates a
  ~c[unify-subst] binding ~c[x] to ~c[(h1 a)]: ~c[((x . (h1 a)))].  It now
  attempts to rewrite the hypothesis of ~c[lemma-3] to ~c[t] under this
  ~c[unify-subst].

  Consider what happens now if the hypothesis of ~c[lemma-3] is ~c[(foo x)].
  To rewrite this hypothesis under a ~c[unify-subst] of ~c[((x . (h1 a)))], it
  will first rewrite ~c[x] under this ~c[unify-subst].  The key observation
  here is that this rewrite takes place simply by returning the value of ~c[x]
  in the ~c[unify-subst], namely ~c[(h1 a)].  No further rewriting is done!
  The efficiency of the ACL2 rewriter depends on such caching of previous
  rewriting results.

  But suppose that, instead, the hypothesis of ~c[lemma-3] is
  ~c[(foo (double-rewrite x))].  As before, the rewriter dives to the first
  argument of this call of ~c[foo].  But this time the rewriter sees the call
  ~c[(double-rewrite x)], which it handles as follows.  First, ~c[x] is
  rewritten as before, yielding ~c[(h1 a)].  But now, because of the call of
  ~c[double-rewrite], the rewriter takes ~c[(h1 a)] and rewrites it under the
  empty ~c[unify-subst].  What's more, because of the ~c[defcong] event above,
  this rewrite takes place in a context where it suffices to maintain the
  equivalence relation ~c[my-equiv].  This allows for the application of
  ~c[lemma-1], hence ~c[(h1 a)] is rewritten (under ~c[unify-subst] = ~c[nil])
  to ~c[(h2 a)].  Popping back up, the rewriter will now rewrite the call of
  ~c[foo] to ~c[t] using ~c[lemma-2].

  The example above explains how the rewriter treats calls of
  ~c[double-rewrite], but it may leave the unfortunate impression that the user
  needs to consider each ~c[:]~ilc[rewrite] or ~c[:]~ilc[linear] rule
  carefully, just in case a call of ~c[double-rewrite] may be appropriate.
  Fortunately, ACL2 provides a ``[Double-rewrite]'' warning to inform the user
  of just this sort of situation.  If you don't see this warning when you
  submit a (~c[:]~ilc[rewrite] or ~c[:]~ilc[linear]) rule, then the issue
  described here shouldn't come up for that rule.  Such warnings may appear for
  hypotheses or right-hand side of a ~c[:]~ilc[rewrite] rule, and for
  hypotheses or full conclusion (as opposed to just the trigger term) of a
  ~c[:]~ilc[linear] rule.

  If you do see a ``[Double-rewrite]'' warning, then should you add the
  indicated call(s) of ~c[double-rewrite]?  At the time of writing this
  ~il[documentation], the answer is not clear.  Early experiments with double
  rewriting suggested that it may be too expensive to call ~c[double-rewrite]
  in every instance where a warning indicates that there could be an advantage
  to doing so.  And at the time of this writing, the ACL2 regression suite has
  about 1900 such warnings (but note that books were developed before
  ~c[double-rewrite] or the ``[Double-rewrite]'' warning were implemented),
  which suggests that one can often do fine just ignoring such warnings.
  However, it seems advisable to go ahead and add the calls of
  ~c[double-rewrite] indicated by the warnings unless you run across
  efficiency problems caused by doing so.  Of course, if you decide to ignore
  all such warnings you can execute the event:~nl[]
  ~c[(]~ilc[set-inhibit-warnings]~c[ \"Double-rewrite\")].

  Finally, we note that it is generally not necessary to call
  ~c[double-rewrite] in order to get its effect in the following case, where
  the discussion above might have led one to consider a call of
  ~c[double-rewrite]: a hypothesis is a variable, or more generally, we are
  considering a variable occurrence that is a branch of the top-level ~c[IF]
  structure of a hypothesis.  The automatic handling of this case, by a form of
  double rewriting, was instituted in ACL2 Version_2.9 and remains in place
  with the introduction of ~c[double-rewrite].  Here is a simple illustrative
  example.  Notice that ~c[foo-holds] applies to prove the final ~ilc[thm]
  below, even without a call of ~c[double-rewrite] in the hypothesis of
  ~c[foo-holds], and that there is no ``[Double-rewrite]'' warning when
  submitting ~c[foo-holds].
  ~bv[]
  (encapsulate
   (((foo *) => *)
    ((bar *) => *))

   (local (defun foo (x) (declare (ignore x)) t))
   (local (defun bar (x) (declare (ignore x)) t))

   (defthm foo-holds
     (implies x
              (equal (foo x) t)))
   (defthm bar-holds-propositionally
     (iff (bar x) t)))

  (thm (foo (bar y)))
  ~ev[]~/"

  x)

#-acl2-loop-only
(progn

; The following variables implement time limits.  Only bind-acl2-time-limit
; should bind *acl2-time-limit*, as described in a comment in
; bind-acl2-time-limit, where one may find a a discussion of how these
; variables are handled.

(defparameter *acl2-time-limit* nil)

(defparameter *acl2-time-limit-boundp* nil)

)

(defun chk-with-prover-time-limit-arg (time)
  (declare (xargs :guard t))
  (or (let ((time (if (and (consp time)
                           (null (cdr time)))
                      (car time)
                    time)))
        (and (rationalp time)
             (< 0 time)
             time))
      (hard-error 'with-prover-time-limit
                  "The first argument to ~x0 must evaluate to a non-negative ~
                   rational number or a list containing such a number, but ~
                   such an argument has evaluated to ~x1."
                  (list (cons #\0 'with-prover-time-limit)
                        (cons #\1 time)))))

#-acl2-loop-only
(defmacro with-prover-time-limit1-raw (time form)

; This macro does not check that time is of a suitable form (see :doc
; with-prover-time-limit).  However, with-prover-time-limit lays down a call of
; chk-with-prover-time-limit-arg, which is called before return-last passes
; control to the present macro.

  (let ((time-limit-var (gensym)))
    `(let* ((,time-limit-var ,time)
            (temp (+ (get-internal-time)
                     (* internal-time-units-per-second
                        (if (consp ,time-limit-var)
                            (car ,time-limit-var)
                          ,time-limit-var))))
            (*acl2-time-limit* (if (or (consp ,time-limit-var)
                                       (null *acl2-time-limit*))
                                   temp
                                 (min temp *acl2-time-limit*))))
       ,form)))

(defmacro with-prover-time-limit1 (time form)
  `(return-last 'with-prover-time-limit1-raw ,time ,form))

(defmacro with-prover-time-limit (time form)

  ":Doc-Section Other

  limit the time for proofs~/

  ~bv[]
  Examples:

  ; Limit (mini-proveall) to about 1/4 second:
  (with-prover-time-limit 1/4 (mini-proveall))

  ; Limit (mini-proveall) to about 1/4 second, even if surrounding call of
  ; with-prover-time-limit provides for a more restrictive bound:
  (with-prover-time-limit '(1/4) (mini-proveall))

  ; Limit the indicated theorem to about 1/50 second, and if the proof does not
  ; complete or it fails, then put down a label instead.
  (mv-let (erp val state)
          (with-prover-time-limit
           1/50
           (thm (equal (append (append x x) x)
                       (append x x x))))
          (if erp
              (deflabel foo :doc \"Attempt failed.\")
            (value (list :succeeded-with val))))~/

  General Form:
  (with-prover-time-limit time form)
  ~ev[]
  where ~c[time] evaluates to a positive rational number or to a list
  containing such, and ~c[form] is arbitrary.  Logically,
  ~c[(with-prover-time-limit time form)] is equivalent to ~c[form].  However,
  if the time for evaluation of ~c[form] exceeds the value specified by
  ~c[time], and if ACL2 notices this fact during a proof, then that proof will
  abort, for example like this:
  ~bv[]
  ACL2 Error in ( DEFTHM PERM-REFLEXIVE ...):  Out of time in the rewriter.
  ~ev[]
  If there is already a surrounding call of ~c[with-prover-time-limit] that has
  set up an expiration time, the inner ~c[with-prover-time-limit] call is not
  allowed to push that time further into the future unless the inner time is
  specified as a list containing a rational, rather than as a rational.

  Note that by default, the time used is runtime (cpu time); to switch to
  realtime (elapsed time), ~pl[get-internal-time].

  For a related utility based on prover steps instead of time,
  ~pl[with-prover-step-limit]; also ~pl[set-prover-step-limit].  Those
  utilities have the advantage of having platform-independent behavior, unlike
  time limits, which of course are generally less restrictive for faster
  processors.  But note that the prover steps counted need not correspond
  closely to prover time.

  Although ~c[with-prover-time-limit] behaves like an ACL2 function in the
  sense that it evaluates both its arguments, it is however actually a macro
  that behaves as follows.  (1) The value of its first (time limit) argument
  affects the evaluation of its second argument (by causing an error during
  that evaluation if the time for completion is insufficient).  (2) The second
  argument can return multiple values (~pl[mv]), which are then returned by the
  call of ~c[with-prover-time-limit].  (3) Thus, there is not a fixed number of
  values returned by ~c[with-prover-time-limit].

  If you find that the time limit appears to be implemented too loosely, it may
  be because the prover only checks the time elapsed at certain points during
  the proof process, for example at entry to the rewriter.  For example, if you
  write your own ~ilc[clause-processor] that does an expensive computation, the
  time is unlikely to be checked during its execution.  If however you find the
  time limit seems to be ignored even during ordinary prover operation, you are
  encouraged to email an example to the ACL2 implementors with instructions on
  how to observe the undesirable behavior.  This information can perhaps be
  used to improve ACL2 by the insertion of more checks for expiration of the
  time limit.

  The rest of this documentation topic explains the rather subtle logical
  story, and is not necessary for understanding how to use
  ~c[with-prover-time-limit].  The ACL2 ~ilc[state] object logically contains a
  field called the ~c[acl2-oracle], which is an arbitrary true list of objects.
  This field can be read by a function called ~c[read-acl2-oracle], which
  however is untouchable (~pl[push-untouchable]), meaning that it is cannot be
  called by ACL2 users.  The ~c[acl2-oracle] field is thus ``secret''.  Our
  claim is that any ACL2 session makes sense for ~st[some] value of
  ~c[acl2-oracle] in the initial ~c[state] for that session.  Logically,
  ~c[with-prover-time-limit] is a no-op, just returning its second value.  But
  under the hood, it provides a ``hint'' for the ~c[acl2-oracle], so that
  (logically speaking) when its first element (~ilc[car]) is consulted by
  ACL2's prover to see if the time limit has expired, it gets the ``right''
  answer (specifically, either nil if all is well or else a message to print if
  the time limit has expired).  Logically, the ~c[acl2-oracle] is then
  ~ilc[cdr]'ed ~-[] that is, its first element is popped off ~-[] so that
  future results from ~c[read-acl2-oracle] are independent of the one just
  obtained.~/"

  `(with-prover-time-limit1 (chk-with-prover-time-limit-arg ,time)
                            ,form))

#-acl2-loop-only
(defparameter *time-limit-tags* nil)

(defmacro catch-time-limit5 (form)

; Keep in sync with catch-time-limit5@par.

  `(mv-let (step-limit x1 x2 x3 x4 ; values that cannot be stobjs
                       state)
           #+acl2-loop-only
           ,form ; so, except for state, form does not return a stobj
           #-acl2-loop-only
           (progn
             (setq *next-acl2-oracle-value* nil)
             (catch 'time-limit5-tag
               (let ((*time-limit-tags* (add-to-set-eq 'time-limit5-tag
                                                       *time-limit-tags*)))
                 ,form)))
           (pprogn
            (f-put-global 'last-step-limit step-limit state)
            (mv-let (nullp temp state)
                    (read-acl2-oracle state) ; clears *next-acl2-oracle-value*
                    (declare (ignore nullp))
                    (cond (temp (mv step-limit temp nil nil nil nil state))
                          (t (mv step-limit nil x1 x2 x3 x4 state)))))))

#+acl2-par
(defmacro catch-time-limit5@par (form)

; Keep in sync with catch-time-limit5.

  `(mv-let (step-limit x1 x2 x3 x4) ; values that cannot be stobjs
           #+acl2-loop-only
           ,form ; so, form returns neither a stobj nor state
           #-acl2-loop-only
           (progn

; Parallelism blemish: there is a rare race condition related to
; *next-acl2-oracle-value*.  Specifically, a thread might set the value of
; *next-acl2-oracle-value*, throw the 'time-limit5-tag, and the value of
; *next-acl2-oracle-value* wouldn't be read until after that tag was caught.
; In the meantime, maybe another thread would have cleared
; *next-acl2-oracle-value*, and the needed value would be lost.

             (setq *next-acl2-oracle-value* nil)
             (catch 'time-limit5-tag
               (let ((*time-limit-tags* (add-to-set-eq 'time-limit5-tag
                                                       *time-limit-tags*)))
                 ,form)))
           (pprogn@par

; Parallelism no-fix: we haven't analyzed the code to determine whether the
; following call of (f-put-global@par 'last-step-limit ...) will be overridden
; by another similar call performed by a concurrent thread.  But we can live
; with that because step-limits do not affect soundness.

            (f-put-global@par 'last-step-limit step-limit state)
            (mv-let (nullp temp)
                    (read-acl2-oracle@par state);clears *next-acl2-oracle-value*
                    (declare (ignore nullp))
                    (cond (temp (mv step-limit temp nil nil nil nil))
                          (t (mv step-limit nil x1 x2 x3 x4)))))))

(defun time-limit5-reached-p (msg)

; Where should we call this function?  We want to strike a balance between
; calling it often enough that we get reasonably tight results for
; with-prover-time-limit, yet calling it rarely enough so that we don't slow
; down the prover, in particular from calls of (get-internal-time).

; As of this writing we call this function in add-poly,
; quick-and-dirty-subsumption-replacement-step, subsumption-replacement-loop,
; rewrite, subsumes, and expand-abbreviations.  Here are some results for run
; times in Allegro CL with output inhibited.  For (verify-guards read-utf8-fast
; ...) in community book books/unicode/read-utf8.lisp, total cpu time went from
; 353.70 to 436.89 seconds when wrapped as (with-prover-time-limit 5000
; (verify-guards read-utf8-fast ...)).  That's about 24%.  On the other hand,
; (with-prover-time-limit 5000 (mini-proveall)) had total cpu times of 720,
; 750, and 680 while (mini-proveall) had times of 710, 660, and 600, which is
; (very roughly) a 9% drop.

; At one time, including the time at which the above statistics were gathered,
; we also called this function in ev-fncall, ev, ev-lst, and ev-fncall-w (and
; at this writing we also see ev-w-lst and ev-w).  But we found an infinite
; loop with ev, as documented there.

  (declare (xargs :guard t))
  #+acl2-loop-only
  (declare (ignore msg))
  #-acl2-loop-only
  (when (and *acl2-time-limit*

; The following test isn't currently necessary, strictly speaking.  But it's a
; cheap test so we include it for robustness, in case for example someone calls
; rewrite not in the scope of catch-time-limit5.

             (member-eq 'time-limit5-tag *time-limit-tags*)
             (< *acl2-time-limit* (get-internal-time)))
    (setq *next-acl2-oracle-value*
          (if (eql *acl2-time-limit* 0)
              "Aborting due to an interrupt."
            msg))
    (throw 'time-limit5-tag
           (mv (f-get-global 'last-step-limit *the-live-state*)
               nil nil nil nil *the-live-state*)))
  nil)

(defmacro catch-step-limit (form)

; Form should evaluate to a result of the form (mv step-limit erp val state).
; Wrap this macro around any form for which you want an error to occur if the
; step-limit transitions from 0 to -1.  Search for occurrences of
; *step-limit-error-p* for details of how this works.

  #+acl2-loop-only
  `(mv-let (step-limit erp val state)
           ,form
           (mv-let (erp2 val2 state)
                   (read-acl2-oracle state)
                   (cond ((and (null erp2) (natp val2))
                          (mv val2 t nil state))
                         (t (mv step-limit erp val state)))))
  #-acl2-loop-only
  `(let ((*step-limit-error-p* t))
     (assert$
      (eq state *the-live-state*)
      (let ((sl/erp/val (catch 'step-limit-tag
                          (mv-let (step-limit erp val ignored-state)
                                  ,form
                                  (declare (ignore ignored-state))
                                  (list* step-limit erp val)))))
        (cond
         ((eq *step-limit-error-p* 'error)
          (mv -1 t nil state))
         (t (mv (car sl/erp/val) (cadr sl/erp/val) (cddr sl/erp/val) state)))))))

(defconst *guard-checking-values*
  '(t nil :nowarn :all :none))

(defun chk-with-guard-checking-arg (val)
  (declare (xargs :guard t))
  (cond ((member-eq val *guard-checking-values*)
         val)
        (t (hard-error 'with-guard-checking
                       "The first argument to ~x0 must evaluate to one of ~
                        ~v1.  But such an argument has evaluated to ~x2."
                       (list (cons #\0 'with-guard-checking)
                             (cons #\1 *guard-checking-values*)
                             (cons #\2 val))))))

#-acl2-loop-only
(defmacro with-guard-checking1-raw (val form)

; This macro does not check that val is a member of *guard-checking-values*.
; However, with-guard-checking lays down a call of chk-with-guard-checking-arg,
; which is called before return-last passes control to the present macro.

  (let ((v (global-symbol 'guard-checking-on)))
    `(let ((,v ,val))
       (declare (special ,v))
       ,form)))

(defmacro with-guard-checking1 (val form)
  `(return-last 'with-guard-checking1-raw ,val ,form))

(defmacro with-guard-checking (val form)

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

  suppressing or enable guard-checking for a form~/
  ~bv[]
  Example:

  ; Turn off all guard-checking for the indicated calls of append and car:
  (with-guard-checking :none
                       (car (append 3 4)))~/

  General Form:
  (with-guard-checking val form)
  ~ev[]
  where ~c[val] evaluates to a legal guard-checking value
  (~pl[set-guard-checking], or evaluate ~c[*guard-checking-values*] to see the
  list of such values), and ~c[form] is a form to be evaluated as though we had
  first executed ~c[(set-guard-checking val)].  Of course, this gaurd-checking
  setting is active only during evaluation of ~c[form], and is ignored once
  evaluation passes into raw Lisp functions (~pl[guards-and-evaluation])."

  (declare (xargs :guard t))
  `(with-guard-checking1 (chk-with-guard-checking-arg ,val)
                         ,form))

(defun abort! ()

  ":Doc-Section Miscellaneous

  to return to the top-level of ACL2's command loop~/

  This is an alias for ~c[a!]; ~pl[a!].  For a related feature that only pops
  up one level, ~pl[p!].~/~/"

  (declare (xargs :guard t))
  #-acl2-loop-only
  (throw 'local-top-level :abort)
  nil)

(defmacro a! ()

  ":Doc-Section Miscellaneous

  to return to the top-level of ACL2's command loop~/

  When ~c[(a!)] is evaluated inside of ACL2's command loop, the current
  computation is aborted and control returns to the top of the command loop,
  exactly as though the user had interrupted and aborted the current
  computation.  (Note: Versions of ACL2 up to Version_3.4 provided `~c[#.]' for
  this purpose, but no longer; ~pl[sharp-dot-reader].)

  If you are at an ACL2 prompt (as opposed to a raw Lisp break), then you may
  type ~c[:a!] in place of ~c[(a!)]; ~pl[keyword-commands].

  For a related feature that only pops up one level, ~pl[p!].~/

  Logically speaking, ~c[(a!) = nil].  But imagine that it is defined in such a
  way that it causes a stack overflow or other resource exhaustion when
  called."

  (declare (xargs :guard t))
  '(abort!))

(defun p! ()

  ":Doc-Section Miscellaneous

  to pop up (at least) one level of ACL2's command loop~/

  Logically speaking, ~c[(p!) = nil].  If you are already at the top level of
  the ACL2 command loop, rather than being in a subsidiary call of ~ilc[ld],
  then the keyword then a call of ~c[(p!)] returns ~c[nil] and has no other
  effect.

  Otherwise, ~c[(p!)] is evaluated inside a call of ~ilc[ld] that was made
  inside ACL2's command loop.  In that case, the current computation is aborted
  and treating as causing an error, and control returns to the superior call of
  ~c[ld].

  Here is a more detailed description of the effect of ~c[(p!)] when not at the
  top level of the ACL2 command loop.  The current call of ~c[LD] is treated as
  though ~c[ld-error-action] is ~c[:RETURN!] (the default) and hence
  immediately returns control to the superior call of ~ilc[ld].  If all calls
  of ~ilc[ld] were made with the default ~c[ld-error-action] of ~c[:RETURN!],
  then all superior calls of ~c[ld] will then complete until you are back at
  top level of the ACL2 loop.  For more information, ~pl[ld-error-action].

  If you are at an ACL2 prompt (as opposed to a raw Lisp break), then you may
  type ~c[:p!] in place of ~c[(p!)]; ~pl[keyword-commands].~/~/"

  (declare (xargs :guard t))
  #-acl2-loop-only
  (throw 'local-top-level :pop)
  nil)

(in-theory (disable abort!
                    (:executable-counterpart abort!)
                    p!
                    (:executable-counterpart p!)

; We could disable (:executable-counterpart hide) earlier, but this is a
; convenient place to do it.

                    (:executable-counterpart hide)))

#-acl2-loop-only
(defparameter *wormhole-status-alist* nil)

#-acl2-loop-only
(defparameter *inhibit-wormhole-activityp* nil)

(defun wormhole1 (name input form ld-specials)

; Here is the world's fanciest no-op.

; We need a guard to force guard verification to happen.  This way, a
; call of wormhole1 will definitely invoke the -acl2-loop-only code
; below, not the logical version.

  (declare (xargs :guard t))
  #+acl2-loop-only
  (declare (ignore name input form ld-specials))
  #+acl2-loop-only
  nil

  #-acl2-loop-only
  (cond
   (*inhibit-wormhole-activityp* nil)
   ((let ((temp (cdr (assoc-equal name *wormhole-status-alist*))))

; Note:  Below we inline wormhole-entry-code, to be defined later.

      (and (consp temp)
           (eq (car temp) :SKIP)))
    nil)
   (t
    (let ((*wormholep* t)
          (state *the-live-state*)
          (*wormhole-cleanup-form*

; WARNING:  The own-cons and the progn form constructed below must be NEW!
; See note below.

           (let ((own-cons (cons nil nil)))
             (list 'progn
                   `(cond ((car (quote ,own-cons))
                           (error "Attempt to execute *wormhole-cleanup-form* ~
                                   twice!"))
                          (t (setq *wormhole-status-alist*
                                   (put-assoc-equal
                                    ',name
                                    (f-get-global 'wormhole-status
                                                  *the-live-state*)
                                    *wormhole-status-alist*))))
                   `(fix-trace ',(f-get-global 'trace-specs *the-live-state*))
                   `(setf (car (quote ,own-cons)) t)
                   'state))))

; Note: What's going on above? The cleanup form's spine is new conses because
; we smash them, inserting new formi's between the cond and the setf.  When
; the setf is executed it sets a flag owned by this particular form.  When
; that flag is set, this form cannot be executed again.  Instead it causes an
; error.  I am afraid that this form might be executed repeatedly by
; interrupted interrupt processing.  One might think that would be ok.  But
; inspection of the value of this form reveals that it is not unusual for it
; to contain (MAKUNBOUND-GLOBAL 'WORMHOLE-STATUS *THE-LIVE-STATE*) near the
; bottom and that, in turn, would cause the f-get-global reference to
; wormhole-status in the cond to go astray (with or without an error message).
; So rather than take random luck on whether an error message is printed or an
; ``unbound value'' is returned as a value, we force an error message that
; will cause us to come back here.  The likely scenarios are that the cleanup
; form got executed twice because of repeated, rapid ctrl-c inputs or that it
; got executed once by Lisp's unwind-protect and later by our acl2-unwind or
; the eval below.

      (cond ((null name) (return-from wormhole1 nil)))
      (push-car (cons "Post-hoc unwind-protect for wormhole"

; Robert Krug tells us that CCL complained before we introduced function
; below.  We use a non-special lexical variable to capture the current value of
; *wormhole-cleanup-form* (as we formerly did) as we push the function onto the
; stack.

                      (let ((acl-non-special-var *wormhole-cleanup-form*))
                        (function
                         (lambda nil (eval acl-non-special-var)))))
                *acl2-unwind-protect-stack*
                'wormhole1)

; The f-put-globals about to be performed will be done undoably.

      (f-put-global 'wormhole-name name state)
      (f-put-global 'wormhole-input input state)
      (f-put-global 'wormhole-status
                    (cdr (assoc-equal name *wormhole-status-alist*))
                    state)
      (ld-fn (append
              `((standard-oi . (,form . ,*standard-oi*))
                (standard-co . ,*standard-co*)
                (proofs-co . ,*standard-co*))
              ld-specials)
             state
             t)
      (eval *wormhole-cleanup-form*)
      (pop (car *acl2-unwind-protect-stack*))
      nil))))

(defun wormhole-p (state)

  ":Doc-Section Miscellaneous

  predicate to determine if you are inside a ~ilc[wormhole]~/

  ~l[wormhole] for a discussion of wormholes.  ~c[(Wormhole-p state)] returns
  ~c[(mv nil t state)] when evaluated inside a wormhole, else
  ~c[(mv nil nil state)].~/~/"

  (declare (xargs :guard (state-p state)))
  #-acl2-loop-only
  (when (live-state-p state)
    (return-from wormhole-p
                 (value *wormholep*)))
  (read-acl2-oracle state))

(defun duplicates (lst)
  (declare (xargs :guard (symbol-listp lst)))
  (cond ((endp lst) nil)
        ((member-eq (car lst) (cdr lst))
         (add-to-set-eq (car lst) (duplicates (cdr lst))))
        (t (duplicates (cdr lst)))))

(defun evens (l)
  (declare (xargs :guard (true-listp l)))
  (cond ((endp l) nil)
        (t (cons (car l)
                 (evens (cddr l))))))

(defun odds (l)
  (declare (xargs :guard (true-listp l)))
  (evens (cdr l)))

(defun set-equalp-equal (lst1 lst2)
  (declare (xargs :guard (and (true-listp lst1)
                              (true-listp lst2))))
  (and (subsetp-equal lst1 lst2)
       (subsetp-equal lst2 lst1)))

; Essay on Metafunction Support, Part 1

; (The second part of this essay is in ld.lisp.)

; Historical Note: Metafunctions have traditionally taken just one argument:
; the term to be simplified.  In 1999, Robert Krug, working on arithmetic
; metafunctions, wished to call type-set from within a metafunction.  This
; inspired the creation of what were called ``extended metafunctions'' in
; contrast to the ``vanilla metafunctions'' that had gone before.  (Originally,
; we used the name ``tutti-frutti metafunctions'' but that seemed too silly.)
; In June, 1999, a patch supporting extended metafunctions in Version_2.4 was
; given to Robert for experimental purposes.  He extended it and gave it back
; in July, 2000.  It was integrated into Version_2.6 in July, 2000.

; Historical Note 2: Previous to Version_2.7 the functions below could only be
; used in the context of a metafunction.  As per a suggestion by Eric Smith,
; and incorporating an implementation provided by Robert Krug, they can now be
; called from within a syntaxp or bind-free hypothesis.  We refer to a function
; that appears in one of these three contexts as a meta-level function.
; However, we still continue to use the term metafunction context, even though
; this is somewhat inconsistent.

; We wish to allow the user to call certain theorem proving functions, like
; type-set and rewrite, from within meta-level functions, without defining
; those functions logically.  We provide uninterpreted function symbols, e.g.,
; mfc-ts and mfc-rw+, for this purpose and arrange for them to be type-set and
; rewrite within the context of a meta-level function's execution.

; Notes:
; 1. There are two kinds of functions with the prefix ``mfc-''.
;    * ordinary defined :logic mode functions used to access parts of
;      the ``metafunction context.''  Example:  mfc-clause.

;    * uninterpreted functions with execution-only-in-meta-level-functions
;      semantics.  Example: mfc-ts.

;    The user may be unaware that these are two different classes of symbols.
;    But the first is given explicit axioms and the second is not.

; 2. If a new function is added, functions of the first type are preferred
;    because they are what they seem.  Such functions are defined here in
;    axioms.lisp.

; 3. Functions of the second type are introduced with unknown constraints from
;    a define-trusted-clause-processor event, and are defined in raw
;    Lisp using the defun-overrides mechanism.

; In the next four paragraphs, we typically refer only to metafunctions, but
; most of the below applies to meta-level functions generally.

; Originally, these uninterpreted functions were essentially defstubs,
; logically, and were only to be used to make heuristic choices between correct
; alternative transformations within the metafunction.  That is, practically
; speaking, the metatheorem stating the correctness of a metafunction was
; proved in the absence of any axioms about mfc-tc and mfc-rw+.  Now we have
; meta-extract-contextual-fact available for reasoning about these functions;
; see :DOC meta-extract.

; Metafunctions providing this additional capability are called extended
; metafunctions and can be recognized by having more than one argument.  We
; still support vanilla flavored, one argument, metafunctions.

; It is necessary to pass ``type-set'' and ``rewrite'' (really, mfc-ts and
; mfc-rw+) additional arguments, arguments not available to vanilla
; metafunctions, like the type-alist, the simplify-clause-pot-lst, etc.  To
; make this convenient, we will bundle these arguments up into a record
; structure called the metafunction-context (``mfc'').  When an extended
; metafunction is called from within the rewriter, we will construct a suitable
; record and pass it into the metafunction in the appropriate argument
; position.  We give the user functions, e.g., mfc-clause, to access parts of
; this structure; we could provide functions for every component but in fact
; only provide the ones Robert Krug has needed so far.  But in general the user
; could access the context arbitrarily with cars and cdrs from within the
; metafunction and there is nothing we can do to hide its actual structure.
; Indeed, there is no reason to do so.  The required metatheorem does not
; constrain that argument at all, so nothing but heuristic decisions can be
; made on the basis of what we actually pass in.

; The main use of the metafunction-context is to pass into mfc-ts and mfc-rw+
; (and mfc-rw).  We execute them only on a live STATE argument, so that
; execution results are explained by the implicit axioms on these functions;
; see the discussion of meta-extract-contextual-fact in the Essay on
; Correctness of Meta Reasoning.  Before the introduction of
; meta-extract-contextual-fact, it was necessary to insist on a live state
; argument, for correctness.  Now it may well be sufficient to insist only that
; the mfc argument is the raw-Lisp *metafunction-context*, which holds a
; suitable logical world used by these mfc-xx functions.  But here is our
; thinking prior to the addition of meta-extract-contextual-fact.

;   The live state cannot be a value in a theorem.  So these functions are
;   uninterpreted there.  When a metafunction is called in the theorem prover,
;   the live state is passed in, to be used to authorize the functions to
;   execute.  Thus, these uninterpreted functions must be provided a STATE
;   argument even if they would not otherwise need it.  Mfc-ts is an example of
;   a function that has an otherwise unneeded STATE argument: type-set does not
;   need state.

; How do we know that the context passed into the meta-level function will
; permit type-set and rewrite to execute without error?  How do we know that
; such complicated components as the world, the type-alist, and
; simplify-clause-pot-lst are well-formed?  One way would be to formalize
; guards on all the theorem prover's functions and require guard proofs on
; metafunctions.  But the system is not ready for that yet.  (We believe we
; know the guards for our functions, but we have never written them down
; formally.)

; To ensure that the metafunction context is well-formed (and also for the
; logical reason mentioned above, where we using implicit axioms on mfc-xx
; functions to justify meta-extract-contextual-fact hypotheses in meta rules),
; we refuse to execute unless the context is EQ to the one created by rewrite
; when it calls the meta-level function.  Sensible errors are generated
; otherwise.  When rewrite generates a context, it binds the Lisp special
; *metafunction-context* to the context, to permit this check.  That special
; has value NIL outside meta-level functions.

#-acl2-loop-only
(defparameter *metafunction-context* nil)

; The ``term'' passed to the type-set and rewrite is checked explicitly to be
; well-formed with respect to the world passed in the context.  This gives the
; meta-level function author the freedom to ask type-set questions about
; subterms of what the meta-level function was passed, or even questions about
; newly consed up terms.

; In this section we define the metafunction context accessors, i.e., :logic
; mode functions of the first type noted above.  We are free to add more
; functions analogous to mfc-clause to recover components of the
; metafunction-context mfc.  If you add more functions to the
; metafunction-context record, be sure to define them below, updating existing
; definitions as necessary due to layout changes for that record.

; First, we define some accessor functions that should really be defined by
; defrec, except that we don't want to go through the effort to move the
; definition of defrec to axioms.lisp.

; The present PROGN form is the result of executing the following forms in an
; ACL2 built without this form -- but be sure to replace the defrec form below
; with the corresponding defrec that appears later in the sources!

(PROGN

; :set-raw-mode-on!
; (cons 'progn
;       (er-let* ((form (trans1 '(defrec metafunction-context ...))))
;                (loop for x in (cdr (butlast form 2))
;                      collect (er-let* ((y (trans1 x))) y))))

 (DEFMACRO |Access METAFUNCTION-CONTEXT record field RDEPTH|
           (RDEPTH)
           (LIST 'LET
                 (LIST (LIST 'RDEPTH RDEPTH))
                 '(CAR RDEPTH)))
 (DEFMACRO |Access METAFUNCTION-CONTEXT record field TYPE-ALIST|
           (TYPE-ALIST)
           (LIST 'LET
                 (LIST (LIST 'TYPE-ALIST TYPE-ALIST))
                 '(CAR (CDR TYPE-ALIST))))
 (DEFMACRO |Access METAFUNCTION-CONTEXT record field OBJ|
           (OBJ)
           (LIST 'LET
                 (LIST (LIST 'OBJ OBJ))
                 '(CAR (CDR (CDR OBJ)))))
 (DEFMACRO |Access METAFUNCTION-CONTEXT record field GENEQV|
           (GENEQV)
           (LIST 'LET
                 (LIST (LIST 'GENEQV GENEQV))
                 '(CAR (CDR (CDR (CDR GENEQV))))))
 (DEFMACRO |Access METAFUNCTION-CONTEXT record field WRLD|
           (WRLD)
           (LIST 'LET
                 (LIST (LIST 'WRLD WRLD))
                 '(CAR (CDR (CDR (CDR (CDR WRLD)))))))
 (DEFMACRO |Access METAFUNCTION-CONTEXT record field FNSTACK|
           (FNSTACK)
           (LIST 'LET
                 (LIST (LIST 'FNSTACK FNSTACK))
                 '(CAR (CDR (CDR (CDR (CDR (CDR FNSTACK))))))))
 (DEFMACRO |Access METAFUNCTION-CONTEXT record field ANCESTORS|
           (ANCESTORS)
           (LIST 'LET
                 (LIST (LIST 'ANCESTORS ANCESTORS))
                 '(CAR (CDR (CDR (CDR (CDR (CDR (CDR ANCESTORS)))))))))
 (DEFMACRO
     |Access METAFUNCTION-CONTEXT record field BACKCHAIN-LIMIT|
     (BACKCHAIN-LIMIT)
     (LIST 'LET
           (LIST (LIST 'BACKCHAIN-LIMIT BACKCHAIN-LIMIT))
           '(CAR (CDR (CDR (CDR (CDR (CDR (CDR (CDR BACKCHAIN-LIMIT))))))))))
 (DEFMACRO
  |Access METAFUNCTION-CONTEXT record field SIMPLIFY-CLAUSE-POT-LST|
  (SIMPLIFY-CLAUSE-POT-LST)
  (LIST
   'LET
   (LIST (LIST 'SIMPLIFY-CLAUSE-POT-LST
               SIMPLIFY-CLAUSE-POT-LST))
   '(CAR
     (CDR
        (CDR (CDR (CDR (CDR (CDR (CDR (CDR SIMPLIFY-CLAUSE-POT-LST)))))))))))
 (DEFMACRO
   |Access METAFUNCTION-CONTEXT record field RCNST|
   (RCNST)
   (LIST 'LET
         (LIST (LIST 'RCNST RCNST))
         '(CAR (CDR (CDR (CDR (CDR (CDR (CDR (CDR (CDR (CDR RCNST))))))))))))
 (DEFMACRO
  |Access METAFUNCTION-CONTEXT record field GSTACK|
  (GSTACK)
  (LIST
   'LET
   (LIST (LIST 'GSTACK GSTACK))
   '(CAR
        (CDR (CDR (CDR (CDR (CDR (CDR (CDR (CDR (CDR (CDR GSTACK)))))))))))))
 (DEFMACRO
  |Access METAFUNCTION-CONTEXT record field TTREE|
  (TTREE)
  (LIST
   'LET
   (LIST (LIST 'TTREE TTREE))
   '(CAR
     (CDR
       (CDR (CDR (CDR (CDR (CDR (CDR (CDR (CDR (CDR (CDR TTREE))))))))))))))
; The present PROGN form is the result of executing the following forms in an
; ACL2 built without this form -- but be sure to replace the defrec form below
; with the corresponding defrec that appears later in the sources!

 (DEFMACRO
  |Access METAFUNCTION-CONTEXT record field UNIFY-SUBST|
  (UNIFY-SUBST)
  (LIST
   'LET
   (LIST (LIST 'UNIFY-SUBST UNIFY-SUBST))
   '(CAR
     (CDR
      (CDR
       (CDR (CDR (CDR (CDR (CDR (CDR (CDR (CDR (CDR (CDR UNIFY-SUBST))))))))))))))))

(DEFMACRO |Access REWRITE-CONSTANT record field CURRENT-CLAUSE|
  (CURRENT-CLAUSE)

; WARNING: This  definition must be kept in sync with the defrec for
; rewrite-constant!

; This form comes from the definition of the :current-clause accessor of defrec
; rewrite-constant, by using trans1 to eliminate defabbrev in favor of defmacro.

; (access rewrite-constant
;         (access metafunction-context mfc :rcnst)
;         :current-clause)

  (LIST 'LET
        (LIST (LIST 'CURRENT-CLAUSE CURRENT-CLAUSE))
        '(CDR (CAR (CDR (CDR (CDR (CDR CURRENT-CLAUSE))))))))

(defun record-error (name rec)
  (declare (xargs :guard t))
  (er hard? 'record-error
      "An attempt was made to treat ~x0 as a record of type ~x1."
      rec name))

(defun record-accessor-function-name (name field)
  (declare (xargs :guard (and (symbolp name)
                              (symbolp field))))
  (intern-in-package-of-symbol
   (coerce
    (append (coerce "Access " 'list)
            (coerce (symbol-name name) 'list)
            (coerce " record field " 'list)
            (coerce (symbol-name field) 'list))
    'string)
   name))

(defmacro access (name rec field)
  (cond ((keywordp field)
         (list (record-accessor-function-name name field)
               rec))
        (t (er hard 'record-error
               "Access was given a non-keyword as a field ~
                specifier.  The offending form was ~x0."
               (list 'access name rec field)))))

(defun mfc-clause (mfc)
  (declare (xargs :guard t))

; We protect the access below with a simple guard to make this function
; compliant.  We return nil on the false branch, so in fact the acl2-loop-only
; body is equal to rhs.  We then add a short-circuit in raw lisp that saves us
; from having to run the guard test in the vast majority of cases.  It is
; assumed that *metafunction-context* is either NIL or a proper
; metafunction-context record.

  #-acl2-loop-only
  (cond ((eq mfc *metafunction-context*)
         (return-from mfc-clause
                      (access rewrite-constant
                              (access metafunction-context mfc :rcnst)
                              :current-clause))))

; Note:  We check the pseudo-term-listp condition to ensure that
; pseudo-term-listp-mfc-clause (in axioms.lisp) is a theorem.

  (if (and (true-listp mfc)
           (true-listp (access metafunction-context mfc :rcnst))

; The following case is unfortunate, but necessary for the guard proof.

           (consp (nth 4 (access metafunction-context mfc :rcnst)))
           (pseudo-term-listp (access rewrite-constant
                                      (access metafunction-context mfc :rcnst)
                                      :current-clause)))
      (access rewrite-constant
              (access metafunction-context mfc :rcnst)
              :current-clause)
    nil))

(defun mfc-rdepth (mfc)
  (declare (xargs :guard t))
  #-acl2-loop-only
  (cond ((eq mfc *metafunction-context*)
         (return-from mfc-rdepth
                      (access metafunction-context mfc :rdepth))))
  (if (true-listp mfc)
      (access metafunction-context mfc :rdepth)
    nil))

(defun type-alist-entryp (x)
; (term ts . ttree)
  (declare (xargs :guard t))
  (and (consp x)
       (pseudo-termp (car x))
       (consp (cdr x))
       (integerp (cadr x))

; We check that (cadr x) is between *min-type-set* and *max-type-set*, which
; are checked by check-built-in-constants.

       (<= #-:non-standard-analysis -8192 #+:non-standard-analysis -65536
           (cadr x))
       (<= (cadr x)
           #-:non-standard-analysis 8191 #+:non-standard-analysis 65535)))

(defun type-alistp (x)
  (declare (xargs :guard t))
  (if (consp x)
      (and (type-alist-entryp (car x))
           (type-alistp (cdr x)))
    (eq x nil)))

(defun mfc-type-alist (mfc)

  (declare (xargs :guard t))

; This function is analogous to mfc-clause, above.

  #-acl2-loop-only
  (cond ((eq mfc *metafunction-context*)
         (return-from mfc-type-alist
                      (access metafunction-context mfc :type-alist))))

  (if (and (true-listp mfc)
           (type-alistp (access metafunction-context mfc :type-alist)))
      (access metafunction-context mfc :type-alist)
    nil))

(defun mfc-ancestors (mfc)

  (declare (xargs :guard t))

; This function is analogous to mfc-clause, above.

  #-acl2-loop-only
  (cond ((eq mfc *metafunction-context*)
         (return-from mfc-ancestors
                      (access metafunction-context mfc :ancestors))))

  (if (and (true-listp mfc)
           (true-listp (access metafunction-context mfc :ancestors)))
      (access metafunction-context mfc :ancestors)
    nil))

(defun mfc-unify-subst (mfc)
  (declare (xargs :guard t))
  #-acl2-loop-only
  (cond ((eq mfc *metafunction-context*)
         (return-from mfc-unify-subst
                      (access metafunction-context mfc :unify-subst))))
  (if (true-listp mfc)
      (access metafunction-context mfc :unify-subst)
    nil))

(defun mfc-world (mfc)
  (declare (xargs :guard t))
  #-acl2-loop-only
  (cond ((eq mfc *metafunction-context*)
         (return-from mfc-world
                      (access metafunction-context mfc :wrld))))
  (if (true-listp mfc)
      (access metafunction-context mfc :wrld)
    nil))

; When verifying guards on meta-functions, the following two events are
; handy.

(defthm pseudo-term-listp-mfc-clause
  (pseudo-term-listp (mfc-clause mfc)))

(defthm type-alistp-mfc-type-alist
  (type-alistp (mfc-type-alist mfc)))

; If you add more of these mfc accessor functions, list them in the defrec
; for rewrite-constant.

; See ``Essay on Metafunction Support, Part 2'' for the definitions of the
; uninterpreted mfc functions.

; Essay on a Total Order of the ACL2 Universe

; Pete Manolios has suggested the inclusion a total order of the ACL2 universe.
; He has pointed out that such an order often makes reasoning simpler, in
; particular allowing for sorting of arbitrary lists, canonical forms for sets,
; and nice theorems about records (certain structures sorted by key) that do
; not have hypotheses about the keys.  The lemma immediately preceding the
; theorem in Appendix B of the paper "Structured Theory Development for a
; Mechanized Logic" (Journal of Automated Reasoning, vol. 26, no. 2, (2001),
; 161-203) guarantees that it is conservative to add such an order, in fact an
; order isomorphic to ACL2's natural numbers.  (That argument is flawed, but we
; fix it in documentation topic conservativity-of-defchoose.  But see the
; relevant comment in the acl2-loop-only definition of defchoose for why an
; enumeration is problematic for ACL2(r).)

; Here we add the weakest axiom we can think of that gives a total order of the
; universe, by adding a predicate that orders the non-conses that are not of
; any of the types known to ACL2 (numbers, strings, characters, symbols).  We
; then derive a total order from it, lexorder, which uses function alphorder to
; order atoms.  These functions have been in ACL2 from perhaps the beginning,
; but starting with Version_2.6, they comprehend the notion of bad-atom --
; atoms that satisfy bad-lisp-objectp -- in particular the primitive ordering
; bad-atom<=.  The user is free to develop other total orders besides lexorder.
; We thank Pete Manolios for supplying a version of the events below and Rob
; Sumners for useful discussions and a modification of Pete's events.

(defun bad-atom (x)

; Keep this in sync with good-atom-listp.

  (declare (xargs :guard t))
  (not (or (consp x)
           (acl2-numberp x)
           (symbolp x)
           (characterp x)
           (stringp x))))

(defthm bad-atom-compound-recognizer
  (iff (bad-atom x)
       (not (or (consp x)
                (acl2-numberp x)
                (symbolp x)
                (characterp x)
                (stringp x))))
  :rule-classes :compound-recognizer)

(in-theory (disable bad-atom))

#-acl2-loop-only
(defun-one-output bad-atom<= (x y)
  (error "We have called bad-atom<= on ~s and ~s, but bad-atom<= has no Common ~
Lisp definition."
         x y))

; We now introduce the total ordering on bad-atoms.  We keep most of the
; consequences local, because we are interested in exporting facts only about
; lexorder, which is a total order of the universe.

(defaxiom booleanp-bad-atom<=
  (or (equal (bad-atom<= x y) t)
      (equal (bad-atom<= x y) nil))
  :rule-classes :type-prescription)

(defaxiom bad-atom<=-antisymmetric
  (implies (and (bad-atom x)
                (bad-atom y)
                (bad-atom<= x y)
                (bad-atom<= y x))
           (equal x y))
  :rule-classes nil)

(defaxiom bad-atom<=-transitive
  (implies (and (bad-atom<= x y)
                (bad-atom<= y z)
                (bad-atom x)
                (bad-atom y)
                (bad-atom z))
           (bad-atom<= x z))
  :rule-classes ((:rewrite :match-free :all)))

(defaxiom bad-atom<=-total
  (implies (and (bad-atom x)
                (bad-atom y))
           (or (bad-atom<= x y)
               (bad-atom<= y x)))
  :rule-classes nil)

; Now we can introduce a total order on atoms followed by a total order on all
; ACL2 objects.

(defun alphorder (x y)

  ":Doc-Section ACL2::ACL2-built-ins

  total order on atoms~/

  ~c[Alphorder] is a non-strict total order, a ``less than or equal,'' on
  atoms.  By ``non-strict total order'' we mean a function that always
  returns ~c[t] or ~c[nil] and satisfies the following properties.~bq[]

  o Antisymmetry:  ~c[XrY & YrX -> X=Y]

  o Transitivity:  ~c[XrY & YrZ -> XrZ]

  o Trichotomy:  ~c[XrY v YrX]

  ~eq[]Also ~pl[lexorder], which extends ~c[alphorder] to all objects.

  ~c[(Alphorder x y)] has a guard of ~c[(and (atom x) (atom y))].~/

  Within a single type: rationals are compared arithmetically, complex
  rationals are compared lexicographically, characters are compared
  via their char-codes, and strings and symbols are compared with
  alphabetic ordering.  Across types, rationals come before complexes,
  complexes come before characters, characters before strings, and
  strings before symbols.  We also allow for ``bad atoms,'' i.e.,
  atoms that are not legal Lisp objects but make sense in the ACL2
  logic; these come at the end, after symbols.

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard (and (atom x) (atom y))))
  (cond ((real/rationalp x)
         (cond ((real/rationalp y)
                (<= x y))
               (t t)))
        ((real/rationalp y) nil)
        ((complex/complex-rationalp x)
         (cond ((complex/complex-rationalp y)
                (or (< (realpart x) (realpart y))
                    (and (= (realpart x) (realpart y))
                         (<= (imagpart x) (imagpart y)))))
               (t t)))
        ((complex/complex-rationalp y)
         nil)
        ((characterp x)
         (cond ((characterp y)
                (<= (char-code x)
                    (char-code y)))
               (t t)))
        ((characterp y) nil)
        ((stringp x)
         (cond ((stringp y)
                (and (string<= x y) t))
               (t t)))
        ((stringp y) nil)
        (t

; Since we only execute on good ACL2 objects, we know that x and y are
; symbols.  However, the logic allows for other kinds of atoms as well, as
; recognized by the predicate bad-atom.  The following shortcut avoids any
; potential overhead of accounting for bad atoms.

         #-acl2-loop-only

;  We'd use (symbol-<= x y) if we had it.

         (not (symbol-< y x))
         #+acl2-loop-only
         (cond ((symbolp x)
                (cond ((symbolp y)
                       (not (symbol-< y x)))
                      (t t)))
               ((symbolp y) nil)
               (t (bad-atom<= x y))))))

(defun lexorder (x y)

  ":Doc-Section ACL2::ACL2-built-ins

  total order on ACL2 objects~/

  ~c[Lexorder] is a non-strict total order, a ``less than or equal,'' on
  ACL2 objects.  Also ~pl[alphorder], the restriction of ~c[lexorder] to
  atoms; the notion of ``non-strict total order'' is defined there.

  ~c[Lexorder] has a guard of ~c[t].~/

  For ~c[lexorder], an ~il[atom] and a ~il[cons] are ordered so that
  the ~il[atom] comes first, and two ~il[cons]es are ordered so that
  the one with the recursively smaller ~ilc[car] comes first, with the
  ~ilc[cdr]s being compared only if the ~ilc[car]s are equal.   ~c[Lexorder]
  compares two atoms by using ~ilc[alphorder].

  To see the ACL2 definition of this function, ~pl[pf].~/"

  (declare (xargs :guard t))
  (cond ((atom x)
         (cond ((atom y)

; Historical Plaque:  Here once was found the comment:
;    From the VM one can conclude that ALPHORDER is a
;    total ordering when restricted to ATOMs.
; attesting to the Interlisp ancestry of this theorem prover.

                (alphorder x y))
               (t t)))
        ((atom y) nil)
        ((equal (car x) (car y))
         (lexorder (cdr x) (cdr y)))
        (t (lexorder (car x) (car y)))))

(local
 (defthm bad-atom<=-reflexive
   (implies (bad-atom x)
            (bad-atom<= x x))
   :hints (("Goal"
            :by (:instance bad-atom<=-total (y x))))))

(local
 (defthm bad-atom<=-total-rewrite
   (implies (and (not (bad-atom<= y x))
                 (bad-atom x)
                 (bad-atom y))
            (bad-atom<= x y))
   :hints (("Goal"
            :by (:instance bad-atom<=-total)))
   :rule-classes :forward-chaining))

(local
 (defthm equal-coerce
   (implies (and (stringp x)
                 (stringp y))
            (equal (equal (coerce x 'list)
                          (coerce y 'list))
                   (equal x y)))
   :hints (("Goal" :use
            ((:instance coerce-inverse-2 (x x))
             (:instance coerce-inverse-2 (x y)))
            :in-theory (disable coerce-inverse-2)))))

(defthm alphorder-reflexive
  (implies (not (consp x))
           (alphorder x x)))

(local
 (defthm string<=-l-transitive-at-0
   (implies (and (not (string<-l y x 0))
                 (not (string<-l z y 0))
                 (character-listp x)
                 (character-listp y)
                 (character-listp z))
            (not (string<-l z x 0)))
   :rule-classes ((:rewrite :match-free :all))
   :hints
   (("Goal" :use (:instance string<-l-transitive
                            (i 0) (j 0) (k 0))))))

(defthm alphorder-transitive
  (implies (and (alphorder x y)
                (alphorder y z)
                (not (consp x))
                (not (consp y))
                (not (consp z)))
           (alphorder x z))
  :rule-classes ((:rewrite :match-free :all))
  :hints (("Goal"
           :in-theory (enable string< symbol-<))))

(defthm alphorder-anti-symmetric
  (implies (and (not (consp x))
                (not (consp y))
                (alphorder x y)
                (alphorder y x))
           (equal x y))
  :hints (("Goal"
           :in-theory (union-theories
                       '(string< symbol-<)
                       (disable code-char-char-code-is-identity))
           :use ((:instance symbol-equality (s1 x) (s2 y))
                 (:instance bad-atom<=-antisymmetric)
                 (:instance code-char-char-code-is-identity (c y))
                 (:instance code-char-char-code-is-identity (c x)))))
  :rule-classes
  ((:forward-chaining :corollary
                      (implies (and (alphorder x y)
                                    (not (consp x))
                                    (not (consp y)))
                               (iff (alphorder y x)
                                    (equal x y)))
                      :hints (("Goal" :in-theory
                               (disable alphorder))))))

(defthm alphorder-total
  (implies (and (not (consp x))
                (not (consp y)))
           (or (alphorder x y) (alphorder y x)))
  :hints (("Goal" :use (:instance bad-atom<=-total)
           :in-theory (enable string< symbol-<)))
  :rule-classes
  ((:forward-chaining :corollary
                      (implies (and (not (alphorder x y))
                                    (not (consp x))
                                    (not (consp y)))
                               (alphorder y x)))))

(in-theory (disable alphorder))

(defthm lexorder-reflexive
  (lexorder x x))

(defthm lexorder-anti-symmetric
  (implies (and (lexorder x y) (lexorder y x))
           (equal x y))
  :rule-classes :forward-chaining)

(defthm lexorder-transitive
  (implies (and (lexorder x y) (lexorder y z))
           (lexorder x z))
  :rule-classes ((:rewrite :match-free :all)))

(defthm lexorder-total
  (or (lexorder x y) (lexorder y x))
  :rule-classes
  ((:forward-chaining :corollary
                      (implies (not (lexorder x y))
                               (lexorder y x)))))

; Although there is no known harm in leaving lexorder enabled, it seems likely
; that most reasoning about this function will only need the four properties
; proved above.

(in-theory (disable lexorder))

; We introduce merge-sort-lexorder, which is used in
; show-accumulated-persistence but may be generally useful.

(defun merge-lexorder (l1 l2 acc)
  (declare (xargs :guard (and (true-listp l1)
                              (true-listp l2)
                              (true-listp acc))
                  :measure (+ (len l1) (len l2))))
  (cond ((endp l1) (revappend acc l2))
        ((endp l2) (revappend acc l1))
        ((lexorder (car l1) (car l2))
         (merge-lexorder (cdr l1) l2 (cons (car l1) acc)))
        (t
         (merge-lexorder l1 (cdr l2) (cons (car l2) acc)))))

(local
 (defthm <=-len-evens
   (<= (len (evens l))
       (len l))
   :rule-classes :linear
   :hints (("Goal" :induct (evens l)))))

(local
 (defthm <-len-evens
   (implies (consp (cdr l))
            (< (len (evens l))
               (len l)))
   :rule-classes :linear))

(defthm true-listp-merge-sort-lexorder
  (implies (and (true-listp l1)
                (true-listp l2))
           (true-listp (merge-lexorder l1 l2 acc)))
  :rule-classes :type-prescription)

(defun merge-sort-lexorder (l)
  (declare (xargs :guard (true-listp l)
                  :measure (len l)))
  (cond ((endp (cdr l)) l)
        (t (merge-lexorder (merge-sort-lexorder (evens l))
                           (merge-sort-lexorder (odds l))
                           nil))))

; We move if* to axioms.lisp, so that all :logic mode functions that come with
; the system will be defined in this file.  We do not need this property for
; Version  2.5 or earlier, but we may need it later if we modify the way that
; we define *1* functions.

; Since if* is in :Doc-Section Bdd, we move the :doc for bdd here as well.

(defdoc bdd
  ":Doc-Section Bdd

  ordered binary decision diagrams with rewriting~/

  Ordered binary decision diagrams (OBDDs, often simply called BDDs)
  are a technique, originally published by Randy Bryant, for the
  efficient simplification of Boolean expressions.  In ACL2 we combine
  this technique with rewriting to handle arbitrary ACL2 terms that
  can represent not only Boolean values, but non-Boolean values as
  well.  In particular, we provide a setting for deciding equality of
  bit vectors (lists of Boolean values).~/

  An introduction to BDDs for the automated reasoning community may
  be found in ``Introduction to the OBDD Algorithm for the ATP
  Community'' by J Moore, ~i[Journal of Automated Reasoning] (1994),
  pp. 33-45.  (This paper also appears as Technical Report #84 from
  Computational Logic, Inc.)

  Further information about BDDs in ACL2 can be found in the
  subtopics of this ~il[documentation] section.  In particular,
  ~pl[bdd-introduction] for a good starting place that provides a
  number of examples.

  ~l[hints] for a description of ~c[:bdd] hints.  For quick
  reference, here is an example; but only the ~c[:vars] part of the
  hint is required, as explained in the documentation for ~il[hints].
  The values shown are the defaults.
  ~bv[]
  (:vars nil :bdd-constructors (cons) :prove t :literal :all)
  ~ev[]
  We suggest that you next visit the documentation topic
  ~il[BDD-INTRODUCTION].")

(defun if* (x y z)

  ":Doc-Section Bdd

  for conditional rewriting with BDDs~/

  The function ~c[IF*] is defined to be ~ilc[IF], but it is used in a
  special way by ACL2's ~il[BDD] package.~/

  As explained elsewhere (~pl[bdd-algorithm]), ACL2's ~il[BDD]
  algorithm gives special treatment to ~il[term]s of the form
  ~c[(IF* TEST TBR FBR)].  In such cases, the algorithm simplifies
  ~c[TEST] first, and the result of that simplification must be a
  constant (normally ~c[t] or ~c[nil], but any non-~c[nil] explicit value is
  treated like ~c[t] here).  Otherwise, the algorithm aborts.

  Thus, ~c[IF*] may be used to implement a sort of conditional
  rewriting for ACL2's ~il[BDD] package, even though this package only
  nominally supports unconditional rewriting.  The following contrived
  example should make this point clear.

  Suppose that we want to prove that ~c[(nthcdr (length x) (append x y))]
  is equal to ~c[y], but that we would be happy to prove this only for
  lists having length 4.  We can state such a theorem as follows.
  ~bv[]
  (let ((x (list x0 x1 x2 x3)))
    (equal (nthcdr (length x) (append x y))
           y))
  ~ev[]
  If we want to prove this formula with a ~c[:]~ilc[BDD] hint, then we need to
  have appropriate rewrite rules around.  First, note that ~c[LENGTH] is
  defined as follows (try ~c[:]~ilc[PE] ~ilc[LENGTH]):
  ~bv[]
  (length x)
   =
  (if (stringp x)
      (len (coerce x 'list))
      (len x))
  ~ev[]
  Since ~il[BDD]-based rewriting is merely very simple unconditional
  rewriting (~pl[bdd-algorithm]), we expect to have to prove a
  rule reducing ~ilc[STRINGP] of a ~ilc[CONS]:
  ~bv[]
  (defthm stringp-cons
    (equal (stringp (cons x y))
           nil))
  ~ev[]
  Now we need a rule to compute the ~c[LEN] of ~c[X], because the definition
  of ~c[LEN] is recursive and hence not used by the ~il[BDD] package.
  ~bv[]
  (defthm len-cons
    (equal (len (cons a x))
           (1+ (len x))))
  ~ev[]
  We imagine this rule simplifying ~c[(LEN (LIST X0 X1 X2 X3))] in terms of
  ~c[(LEN (LIST X1 X2 X3))], and so on, and then finally ~c[(LEN nil)] should
  be computed by execution (~pl[bdd-algorithm]).

  We also need to imagine simplifying ~c[(APPEND X Y)], where still ~c[X] is
  bound to ~c[(LIST X0 X1 X2 X3)].  The following two rules suffice for
  this purpose (but are needed, since ~ilc[APPEND], actually ~ilc[BINARY-APPEND],
  is recursive).
  ~bv[]
  (defthm append-cons
    (equal (append (cons a x) y)
           (cons a (append x y))))

  (defthm append-nil
    (equal (append nil x)
           x))
  ~ev[]
  Finally, we imagine needing to simplify calls of ~ilc[NTHCDR], where the
  first argument is a number (initially, the length of
  ~c[(LIST X0 X1 X2 X3)], which is 4).  The second lemma below is the
  traditional way to accomplish that goal (when not using BDDs), by
  proving a conditional rewrite rule.  (The first lemma is only proved
  in order to assist in the proof of the second lemma.)
  ~bv[]
  (defthm fold-constants-in-+
    (implies (and (syntaxp (quotep x))
                  (syntaxp (quotep y)))
             (equal (+ x y z)
                    (+ (+ x y) z))))

  (defthm nthcdr-add1-conditional
    (implies (not (zp (1+ n)))
             (equal (nthcdr (1+ n) x)
                    (nthcdr n (cdr x)))))
  ~ev[]
  The problem with this rule is that its hypothesis makes it a
  conditional ~il[rewrite] rule, and conditional rewrite rules
  are not used by the ~il[BDD] package.  (~l[bdd-algorithm] for a
  discussion of ``BDD rules.'')  (Note that the hypothesis cannot
  simply be removed; the resulting formula would be false for ~c[n = -1]
  and ~c[x = '(a)], for example.)  We can solve this problem by using
  ~c[IF*], as follows; comments follow.
  ~bv[]
  (defthm nthcdr-add1
    (equal (nthcdr (+ 1 n) x)
           (if* (zp (1+ n))
                x
                (nthcdr n (cdr x)))))
  ~ev[]
  How is ~c[nthcdr-add1] applied by the ~il[BDD] package?  Suppose that the ~il[BDD]
  computation encounters a ~il[term] of the form ~c[(NTHCDR (+ 1 N) X)].
  Then the ~il[BDD] package will apply the ~il[rewrite] rule ~c[nthcdr-add1].  The
  first thing it will do when attempting to simplify the right hand
  side of that rule is to attempt to simplify the term ~c[(ZP (1+ N))].
  If ~c[N] is an explicit number (which is the case in the scenario we
  envision), this test will reduce (assuming the executable
  counterparts of ~ilc[ZP] and ~ilc[BINARY-+] are ~il[enable]d) to ~c[t] or
  to ~c[nil].  In fact, the lemmas above (not including the lemma
  ~c[nthcdr-add1-conditional]) suffice to prove our goal:
  ~bv[]
  (thm (let ((x (list x0 x1 x2 x3)))
         (equal (nthcdr (length x) (append x y))
                y))
       :hints ((\"Goal\" :bdd (:vars nil))))
  ~ev[]

  If we execute the following form that disables the definition and
  executable counterpart of the function ~ilc[ZP]
  ~bv[]
  (in-theory (disable zp (zp)))
  ~ev[]
  before attempting the proof of the theorem above, we can see more
  clearly the point of using ~c[IF*].  In this case, the prover makes
  the following report.
  ~bv[]
  ACL2 Error in ( THM ...):  Unable to resolve test of IF* for term

  (IF* (ZP (+ 1 N)) X (NTHCDR N (CDR X)))

  under the bindings

  ((X (CONS X0 (CONS X1 (CONS X2 #)))) (N '3))

  -- use SHOW-BDD to see a backtrace.
  ~ev[]
  If we follow the advice above, we can see rather clearly what
  happened.  ~l[show-bdd].
  ~bv[]
  ACL2 !>(show-bdd)

  BDD computation on Goal yielded 21 nodes.
  ==============================

  BDD computation was aborted on Goal, and hence there is no
  falsifying assignment that can be constructed.  Here is a backtrace
  of calls, starting with the top-level call and ending with the one
  that led to the abort.  See :DOC show-bdd.

  (LET ((X (LIST X0 X1 X2 X3)))
       (EQUAL (NTHCDR (LENGTH X) (APPEND X Y)) Y))
    alist: ((Y Y) (X3 X3) (X2 X2) (X1 X1) (X0 X0))

  (NTHCDR (LENGTH X) (APPEND X Y))
    alist: ((X (LIST X0 X1 X2 X3)) (Y Y))

  (IF* (ZP (+ 1 N)) X (NTHCDR N (CDR X)))
    alist: ((X (LIST* X0 X1 X2 X3 Y)) (N 3))
  ACL2 !>
  ~ev[]
  Each of these term-alist pairs led to the next, and the test of the
  last one, namely ~c[(ZP (+ 1 N))] where ~c[N] is bound to ~c[3], was
  not simplified to ~c[t] or to ~c[nil].

  What would have happened if we had used ~ilc[IF] in place of ~c[IF*] in
  the rule ~c[nthcdr-add1]?  In that case, if ~c[ZP] and its executable
  counterpart were disabled then we would be put into an infinite
  loop!  For, each time a term of the form ~c[(NTHCDR k V)] is
  encountered by the BDD package (where k is an explicit number), it
  will be rewritten in terms of ~c[(NTHCDR k-1 (CDR V))].  We would
  prefer that if for some reason the term ~c[(ZP (+ 1 N))] cannot be
  decided to be ~c[t] or to be ~c[nil], then the BDD computation should
  simply abort.

  Even if there were no infinite loop, this kind of use of ~c[IF*] is
  useful in order to provide feedback of the form shown above whenever
  the test of an ~c[IF] term fails to simplify to ~c[t] or to ~c[nil]."

  (declare (xargs :mode :logic :verify-guards t))
  (if x y z))

(defun resize-list (lst n default-value)

; This function supports stobjs.  The documentation is found later, since
; :Doc-Section stobj is not yet defined.

  (declare (xargs :guard t))
  (if (and (integerp n) (> n 0))
      (cons (if (atom lst) default-value (car lst))
            (resize-list (if (atom lst) lst (cdr lst))
                         (1- n)
                         default-value))
    nil))

; Define e/d, adapted with only minor changes from Bishop Brock's community
; book books/ihs/ihs-init.lisp.

(deflabel theory-functions
  :doc
  ":Doc-Section Theories

  functions for obtaining or producing ~il[theories]~/
  ~bv[]
  Example Calls of Theory Functions:
  (universal-theory :here)
  (union-theories th1 th2)
  (set-difference-theories th1 th2)
  ~ev[]
  The theory functions are documented individually:~/

  The functions (actually, macros) mentioned above are convenient ways
  to produce ~il[theories].  (~l[theories].) Some, like
  ~ilc[universal-theory], take a logical name (~pl[logical-name]) as an
  argument and return the relevant theory as of the time that name was
  introduced.  Others, like ~ilc[union-theories], take two ~il[theories] and
  produce a new one.  ~l[redundant-events] for a caution about
  the use of logical names in theory expressions.

  Theory expressions are generally composed of applications of theory
  functions.  Formally, theory expressions are expressions that
  involve, at most, the free variable ~ilc[world] and that when evaluated
  with ~ilc[world] bound to the current ACL2 world (~pl[world]) return
  ~il[theories].  The ``theory functions'' are actually macros that expand
  into forms that involve the free variable ~ilc[world].  Thus, for example
  ~c[(universal-theory :here)] actually expands to
  ~c[(universal-theory-fn :here world)] and when that form is evaluated
  with ~ilc[world] bound to the current ACL2 ~il[world], ~c[universal-theory-fn]
  scans the ACL2 property lists and computes the current universal
  theory.  Because the theory functions all implicitly use ~ilc[world],
  the variable does not generally appear in anything the user
  types.~/")

(defun e/d-fn (theory e/d-list enable-p)
  "Constructs the theory expression for the E/D macro."
  (declare (xargs :guard (and (true-list-listp e/d-list)
                              (or (eq enable-p t)
                                  (eq enable-p nil)))))
  (cond ((atom e/d-list) theory)
        (enable-p (e/d-fn `(UNION-THEORIES ,theory ',(car e/d-list))
                          (cdr e/d-list) nil))
        (t (e/d-fn `(SET-DIFFERENCE-THEORIES ,theory ',(car e/d-list))
                   (cdr e/d-list) t))))

(defmacro e/d (&rest theories)

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

  ":Doc-Section Theories

  enable/disable rules~/
  The macro ~c[e/d] creates theory expressions for use in ~ilc[in-theory] hints
  and events.  It provides a convenient way to ~ilc[enable] and ~ilc[disable]
  simultaneously, without having to write arcane theory expressions.
  ~bv[]
  Examples:
  (e/d (lemma1 lemma2))          ; equivalent to (enable lemma1 lemma2)
  (e/d () (lemma))               ; equivalent to (disable lemma)
  (e/d (lemma1) (lemma2 lemma3)) ; Enable lemma1 then disable lemma2, lemma3.
  (e/d () (lemma1) (lemma2))     ; Disable lemma1 then enable lemma2.~/

  General Form:
  (e/d enables-0 disables-0 ... enables-n disables-n)
  ~ev[]
  where each ~c[enables-i] and ~c[disables-i] is a list of runic designators;
  ~pl[theories], ~pl[enable], and ~pl[disable].

  The ~c[e/d] macro takes any number of lists suitable for the ~ilc[enable] and
  ~ilc[disable] macros, and creates a theory that is equal to
  ~c[(current-theory :here)] after executing the following commands.

  (in-theory (enable . enables-0))
  (in-theory (disable . disables-0))
  [etc.]
  (in-theory (enable . enables-n))
  (in-theory (disable . disables-n))~/

  :cited-by theory-functions"

  (declare (xargs :guard (true-list-listp theories)))
  (cond
   ((atom theories) '(CURRENT-THEORY :HERE))
   (t (e/d-fn '(CURRENT-THEORY :HERE) theories t))))

; We avoid skipping proofs for the rest of initialization, so that we can do
; the verify-termination-boot-strap proofs below during the first pass.  See
; the comment in the encapsulate that follows.  Note that preceding in-theory
; events are skipped during pass 1 of the boot-strap, since we are only just
; now entering :logic mode and in-theory events are skipped in :program mode.

#+acl2-loop-only
(f-put-global 'ld-skip-proofsp nil state) ; (set-ld-skip-proofsp nil state)

(encapsulate
 ()

 (logic)

; We verify termination (and guards) for the following functions, in order that
; certain macroexpansions avoid stack overflows during boot-strapping or at
; least are sped up.

 (verify-termination-boot-strap alistp)
 (verify-termination-boot-strap symbol-alistp)
 (verify-termination-boot-strap true-listp)
 (verify-termination-boot-strap len)
 (verify-termination-boot-strap length)
 (verify-termination-boot-strap nth)
 (verify-termination-boot-strap char)
 (verify-termination-boot-strap eqlable-alistp)
 (verify-termination-boot-strap assoc-eql-exec)
 (verify-termination-boot-strap assoc-equal)
 (verify-termination-boot-strap sublis)
 (verify-termination-boot-strap nfix)
 (verify-termination-boot-strap ifix)
 (verify-termination-boot-strap integer-abs) ; for acl2-count
 (verify-termination-boot-strap acl2-count) ; for nonnegative-integer-quotient
 (verify-termination-boot-strap nonnegative-integer-quotient)
 (verify-termination-boot-strap floor)
 (verify-termination-boot-strap symbol-listp)

 )

(defun mod-expt (base exp mod)

  ":Doc-Section ACL2::ACL2-built-ins

  exponential function~/

  ~c[(mod-expt r i m)] is the result of raising the number ~c[r] to the
  integer power ~c[i] and then taking the residue mod ~c[m].  That is,
  ~c[(mod-expt r i m)] is equal to ~c[(mod (expt r i) m)].~/

  The ~il[guard] for ~c[(mod-expt r i m)] is that ~c[r] is a rational number
  and ~c[i] is an integer; if ~c[r] is ~c[0] then ~c[i] is nonnegative; and
  ~c[m] is a non-zero rational number.

  In some implementations (GCL Version 2.7.0 as of this writing), this function
  is highly optimized when ~c[r] and ~c[i] are natural numbers, not both zero,
  and ~c[m] is a positive integer.  For other Lisp implementations, consider
  using function ~c[mod-expt-fast], defined in the community book
  ~c[arithmetic-3/floor-mod/mod-expt-fast.lisp], which should still provide
  significantly improved performance over this function.

  To see the ACL2 definition of this function, ~pl[pf].~/"

; This is just an optimized version of (mod (expt base exp) mod).

  (declare (xargs :guard (and (real/rationalp base)
                              (integerp exp)
                              (not (and (eql base 0) (< exp 0)))
                              (real/rationalp mod)
                              (not (eql mod 0)))))
  #+(and (not acl2-loop-only) gcl)
  (when (and (fboundp 'si::powm)
             (natp base)
             (natp exp)
             (not (and (eql base 0) (eql exp 0)))
             (posp mod))

; The restrictions above can be weakened if justified by a clear spec for
; si::powm.  Unfortunately, it's not evident whether any available version of
; GCL defines si::powm.

    (return-from mod-expt (si::powm base exp mod)))
  (mod (expt base exp) mod))

(defmacro fcons-term* (&rest x)

; ; Start experimental code mod, to check that calls of fcons-term are legitimate
; ; shortcuts in place of the corresponding known-correct calls of cons-term.
;   #-acl2-loop-only
;   `(let* ((fn-used-only-in-fcons-term* ,(car x))
;           (args-used-only-in-fcons-term* (list ,@(cdr x)))
;           (result (cons fn-used-only-in-fcons-term*
;                         args-used-only-in-fcons-term*)))
;      (assert$ (equal result (cons-term fn-used-only-in-fcons-term*
;                                        args-used-only-in-fcons-term*))
;               result))
;   #+acl2-loop-only
; ; End experimental code mod.

  (cons 'list x))

(defun conjoin2 (t1 t2)

; This function returns a term representing the logical conjunction of
; t1 and t2.  The term is IFF-equiv to (AND t1 t2).  But, the term is
; not EQUAL to (AND t1 t2) because if t2 is *t* we return t1's value,
; while (AND t1 t2) would return *t* if t1's value were non-NIL.

  (declare (xargs :guard t))
  (cond ((equal t1 *nil*) *nil*)
        ((equal t2 *nil*) *nil*)
        ((equal t1 *t*) t2)
        ((equal t2 *t*) t1)
        (t (fcons-term* 'if t1 t2 *nil*))))

(defun conjoin (l)
  (declare (xargs :guard (true-listp l)))
  (cond ((endp l) *t*)
        ((endp (cdr l)) (car l))
        (t (conjoin2 (car l) (conjoin (cdr l))))))

(defun conjoin2-untranslated-terms (t1 t2)

; See conjoin2.  This function has the analogous spec, but where t1 and t2 need
; not be translated.

  (declare (xargs :guard t))
  (cond ((or (equal t1 *nil*) (eq t1 nil))
         *nil*)
        ((or (equal t2 *nil*) (eq t2 nil))
         *nil*)
        ((or (equal t1 *t*) (eq t1 t))
         t2)
        ((or (equal t2 *t*) (eq t2 t))
         t1)
        (t (fcons-term* 'if t1 t2 *nil*))))

(defun conjoin-untranslated-terms (l)

; This function is analogous to conjoin, but where t1 and t2 need not be
; translated.

  (declare (xargs :guard (true-listp l)))
  (cond ((endp l) *t*)
        ((endp (cdr l)) (car l))
        (t (conjoin2-untranslated-terms
            (car l)
            (conjoin-untranslated-terms (cdr l))))))

(defun disjoin2 (t1 t2)

; We return a term IFF-equiv (but not EQUAL) to (OR t1 t2).  For example,
; if t1 is 'A and t2 is 'T, then we return 'T but (OR t1 t2) is 'A.

  (declare (xargs :guard t))
  (cond ((equal t1 *t*) *t*)
        ((equal t2 *t*) *t*)
        ((equal t1 *nil*) t2)
        ((equal t2 *nil*) t1)
        (t (fcons-term* 'if t1 *t* t2))))

(defun disjoin (lst)
  (declare (xargs :guard (true-listp lst)))
  (cond ((endp lst) *nil*)
        ((endp (cdr lst)) (car lst))
        (t (disjoin2 (car lst) (disjoin (cdr lst))))))

(defun disjoin-lst (clause-list)
  (declare (xargs :guard (true-list-listp clause-list)))
  (cond ((endp clause-list) nil)
        (t (cons (disjoin (car clause-list))
                 (disjoin-lst (cdr clause-list))))))

(defun conjoin-clauses (clause-list)
  (declare (xargs :guard (true-list-listp clause-list)))
  (conjoin (disjoin-lst clause-list)))

(defconst *true-clause* (list *t*))

(defconst *false-clause* nil)

(defun clauses-result (tuple)
  (declare (xargs :guard (true-listp tuple)))
  (cond ((car tuple) (list *false-clause*))
        (t (cadr tuple))))

(defdoc sharp-dot-reader
  ":Doc-Section other

  read-time evaluation of constants~/

  ~bv[]
  Example:

  ACL2 !>(defconst *a* '(a b c))

  Summary
  Form:  ( DEFCONST *A* ...)
  Rules: NIL
  Warnings:  None
  Time:  0.00 seconds (prove: 0.00, print: 0.00, other: 0.00)
   *A*
  ACL2 !>(quote (1 2 #.*a* 3 4))
  (1 2 (A B C) 3 4)
  ACL2 !>
  ~ev[]~/

  The ACL2 reader supports the syntax ~c[#.*a*] where ~c[*a*] was defined by
  ~ilc[defconst].  In this case, the reader treats ~c[#.*a*] as though it were
  reading the value of ~c[*a*].  This feature can be useful in conjunction with
  the use of ~ilc[evisc-table] to abbreviate large constants, so that the
  abbreviation can be read back in; ~pl[evisc-table].

  Remarks.

  (1) The ACL2 reader only supports `~c[#.]' as described above, unlike Common
  Lisp.  Older versions (preceding 3.5) used `~c[#.]' to abort, but that
  functionality is now carried out by ~c[(a!)]; ~pl[a!].  For a related feature
  that only pops up one level, ~pl[p!].

  (2) If you call ~ilc[certify-book] on a book that contains a form
  `~c[#.*foo*]', the ~c[*foo*] must already be defined in the ~il[world] in
  which you issue the ~c[certify-book] command.  The reason is that
  ~c[certify-book] reads the entire book before evaluating its forms.")

(defdoc sharp-comma-reader
  ":Doc-Section other

  DEPRECATED read-time evaluation of constants~/

  The use of `~c[#,]' has been deprecated.  Please use `~c[#.]' instead;
  ~pl[sharp-dot-reader].~/~/")

(defdoc sharp-bang-reader
  ":Doc-Section other

  package prefix that is not restricted to symbols~/

  ~bv[]
  Examples:

  ACL2 !>(defpkg \"FOO\" nil)

  Summary
  Form:  ( DEFPKG \"FOO\" ...)
  Rules: NIL
  Warnings:  None
  Time:  0.00 seconds (prove: 0.00, print: 0.00, other: 0.00)
   \"FOO\"
  ACL2 !>'#!foo(a b)
  (FOO::A FOO::B)
  ACL2 !>'#!foo(a #!acl2 b)
  (FOO::A B)
  ACL2 !>'#!foo(#!acl2 a b)
  (A FOO::B)
  ACL2 !>'#!foo(#!\"ACL2\" a b)
  (A FOO::B)
  ACL2 !>
  ~ev[]~/

  The ACL2 reader supports the syntax ~c[#!pkg-name expr] where ~c[pkg-name] is
  a string or symbol that names a package known to ACL2.  As illustrated above,
  this syntax nests as one might expect.  In the special case that ~c[expr] is
  a symbol, ~c[#!pkg-name expr] is equivalent to ~c[pkg-name::expr].")

(defdoc sharp-u-reader
  ":Doc-Section other

  allow underscore characters in numbers~/

  ~bv[]
  Example:

  ACL2 !>#ub1000_1000_1000_
  2184
  ACL2 !>#b100010001000
  2184
  ACL2 !>#uo1_1
  9
  ACL2 !>#o11
  9
  ACL2 !>#u34_5
  345
  ACL2 !>#u345
  345
  ACL2 !>345
  345
  ACL2 !>#ux12_a
  298
  ACL2 !>#ux12a
  298
  ACL2 !>#u x12a
  298
  ACL2 !>#x12a
  298
  ACL2 !>#u123_456/7_919
  123456/7919
  ACL2 !>
  ~ev[]~/

  The ACL2 reader supports the use of ~c[#ub], ~c[#uo], and ~c[#ux] where one
  would otherwise write ~c[#b], ~c[#o], and ~c[#x], respectively (for binary,
  octal, and hexadecimal numerals), but where underscore characters (`~c[_]')
  are allowed but ignored.  Also supported is the prefix ~c[#u] in front of a
  an expression that is a decimal numeral except that underscore characteres
  are allowed but ignored.

  The precise specification of ~c[#u] is as follows.  The Lisp reader reads one
  expression after the ~c[#u].  If the result is a number, then that number is
  returned by the reader.  Otherwise the result must be a symbol whose name
  begins with one of the characters `~c[B]', `~c[O]', or `~c[X]', or else a
  decimal digit (one of the characters `~c[0], ~c[1], ..., ~c[9]').  All
  underscores are removed from the name of that symbol to obtain a string and
  in the first three cases only, a `~c[#]' character is prepended to that
  string.  The resulting string is then handed to the Lisp reader in order to
  obtain the final result, which must be a number or else an error occurs.")

(defdoc evisc-table
  ":Doc-Section events

  support for abbreviated output~/

  The ~c[evisc-table] is an ACL2 table (~pl[table]) whose purpose is to modify
  the print representations of specified non-~c[nil] objects.  When a key (some
  object) is associated with a string value, then that string is printed
  instead of that key (as an abbreviation).  For example, the following log
  shows how to abbreviate the key ~c[(a b c)] with the token ~c[<my-abc-list>].
  ~bv[]
  ACL2 !>(table evisc-table '(a b c) \"<my-abc-list>\")

  Summary
  Form:  ( TABLE EVISC-TABLE ...)
  Rules: NIL
  Warnings:  None
  Time:  0.00 seconds (prove: 0.00, print: 0.00, other: 0.00)
   EVISC-TABLE
  ACL2 !>'(a b c)
  <my-abc-list>
  ACL2 !>'(4 5 a b c)
  (4 5 . <my-abc-list>)
  ACL2 !>
  ~ev[]~/

  Every value in this ~il[table] must be either a string or ~c[nil], where
  ~c[nil] eliminates any association of the key with an abbreviation.
  Continuing with the log above:
  ~bv[]
  ACL2 !>(table evisc-table '(a b c) nil)

  Summary
  Form:  ( TABLE EVISC-TABLE ...)
  Rules: NIL
  Warnings:  None
  Time:  0.00 seconds (prove: 0.00, print: 0.00, other: 0.00)
   EVISC-TABLE
  ACL2 !>'(a b c)
  (A B C)
  ACL2 !>'(4 5 a b c)
  (4 5 A B C)
  ACL2 !>
  ~ev[]

  It can be particularly helpful to use this table to abbreviate a constant
  introduced by ~ilc[defconst] by prefixing the constant name with ~c[\"#,\"],
  as we now describe.  Consider first the following example.
  ~bv[]
  (defconst *abc* '(1 2 3 4 5 6 7 8))
  (table evisc-table *abc*
    (concatenate 'string \"#,\" (symbol-name '*abc*)))
  ~ev[]
  Then the constant ~c[*abc*] is printed as follows ~-[] very helpful if its
  associated structure is significantly larger than the 8-element list of
  numbers shown above!
  ~bv[]
  ACL2 !>*abc*
  #,*ABC*
  ACL2 !>
  ~ev[]
  What's more, the ACL2 reader will replace ~c[#,*C*], where ~c[*C*] is defined by
  ~ilc[defconst], by its value, regardless of ~c[evisc-table];
  ~pl[sharp-dot-reader].  Continuing with the example above, we have:
  ~bv[]
  ACL2 !>(cdr (quote #,*ABC*))
  (2 3 4 5 6 7 8)
  ACL2 !>
  ~ev[]
  Of course, more care needs to be taken if packages are involved
  (~pl[defpkg]), as we now illustrate.
  ~bv[]
  ACL2 !>(defpkg \"FOO\" nil)

  Summary
  Form:  ( DEFPKG \"FOO\" ...)
  Rules: NIL
  Warnings:  None
  Time:  0.00 seconds (prove: 0.00, print: 0.00, other: 0.00)
   \"FOO\"
  ACL2 !>(defconst foo::*a* '(1 2 3))

  Summary
  Form:  ( DEFCONST FOO::*A* ...)
  Rules: NIL
  Warnings:  None
  Time:  0.00 seconds (prove: 0.00, print: 0.00, other: 0.00)
   FOO::*A*
  ACL2 !>(table evisc-table foo::*a* \"#,foo::*a*\")

  Summary
  Form:  ( TABLE EVISC-TABLE ...)
  Rules: NIL
  Warnings:  None
  Time:  0.00 seconds (prove: 0.00, print: 0.00, other: 0.00)
   EVISC-TABLE
  ACL2 !>foo::*a*
  #,foo::*a*
  ACL2 !>'#,foo::*a*
  #,foo::*a*
  ACL2 !>(cdr '#,foo::*a*)
  (2 3)
  ACL2 !>
  ~ev[]
  We conclude by an example showing some extra care that may be important to
  consider taking.  We start with:
  ~bv[]
  (defconst |*BaR*| '(3 4))
  ~ev[]
  Then the following works just fine; but try it without the extra code for the
  ~c[may-need-slashes] case and you'll see that the sharp-dot printing is
  missing.  First:
  ~bv[]
  (table evisc-table
         |*BaR*|
         (let ((x (symbol-name '|*BaR*|)))
           (if (may-need-slashes x)
               (concatenate 'string \"#.|\" x \"|\")
             (concatenate 'string \"#.\" x))))
  ~ev[]
  Then:
  ~bv[]
  ACL2 !>|*BaR*|
  #,|*BaR*|
  ACL2 !>
  ~ev[]")

 (table evisc-table nil nil
        :guard ; we don't want to abbreviate nil
        (and (not (null key))
             (or (stringp val)
                 (null val))))

; Essay on the Design of Custom Keyword Hints

; A custom keyword hint is installed by adding a pair to the
; custom-keywords-table using one of the two forms:

; (add-custom-keyword-hint :keyi ugtermi)
; or
; (add-custom-keyword-hint :keyi ugtermi :checker uctermi)

; Restrictions are explained below, but both ugtermi and uctermi are
; untranslated terms and VAL is allowed as a free var in them.

; In the event that no :checker is supplied, uctermi defaults to (value t).
; Add-custom-keyword-hint translates the two terms, to get "generator" term
; gtermi and "checker" term ctermi, and then pairs :keyi with the doublet
; (ctermi gtermi) in the custom-keywords-table.  The presence of such a pair
; makes :keyi a custom keyword hint.

; Every custom keyword hint, :keyi, thus has translated checker and generator
; terms and we call them ctermi and gtermi below.

; Here are the restrictions:

; (a) :keyi is not among the primitive hint keywords in *hint-keywords*.

; (b) ctermi is a term involving no free variables other than (VAL WORLD CTX
; STATE) whose output signature is (mv erp val STATE) to be interpreted as a
; standard ACL2 error triple.  Note that ctermi can modify state arbitrarily.
; Its non-erroneous value is irrelevant.  We are just giving it a chance to
; cause an error.

; (c) gtermi is a term involving no free variables other than (VAL
; KEYWORD-ALIST ID CLAUSE WORLD HIST PSPV CTX STATE), along with
; STABLE-UNDER-SIMPLIFICATIONP except in the context of :backtrack hints, in
; which case PROCESSOR and CLAUSE-LIST are the extra variables.  Note that
; these variables, other than VAL, are those for the general case of a computed
; hint.  The output signature of gtermi should be an error triple.  Again,
; gtermi can modify state arbitrarily.  The value component will be treated as
; a normal hint.

; How are custom keyword hints processed?

; Suppose :keyi is such a key, with checker term ctermi and generator term
; gtermi, and suppose the user writes a hint like:

; ("goal-spec" ... :keyi vali ...)

; At hint translate time, ctermi is evaluated, with VAL bound to vali.  and
; WORLD, CTX, and STATE bound in the obvious way.  The value is ignored!  All
; that ctermi does is cause an error if it doesn't like val.  The evaluation is
; conducted in a "protected" way that minimizes effects of ctermi on the state!

; Then, when the clause identified by goal-spec arises, the first custom
; keyword hint, :keyi, with (now translated) value vali and generator term
; gtermi is found.  We first evaluate ctermi ``again'' on vali.  Provided the
; non-erroneous exit is made, we then do a protected evaluation (as above) of
; gtermi with the following bindings:

; val:             vali
; keyword-alist:   (... :keyi vali ...)
; id:              parsed form of goal-spec (see :DOC clause-identifier)
; clause, etc:     as appropriate given clause and context

; The value of gtermi, say new-keyword-alist, is then used to replace the
; original hint

; ("goal-spec" ... :keyi vali ...)

; with:

; ("goal-spec" . new-keyword-alist)

; Note carefully: the value returned by a single custom keyword hint replaces
; the ENTIRE list of keywords and values in which it appears.  Practically
; speaking, custom keywords should be sensitive to the input keyword-alist and
; return a modified version of it.  This can easily be done by using the
; primitive function splice-keyword-alist or more sophisticated functions that
; attempt to merge new hints into old ones.

; Note that the new keyword-alist might contain more custom keyword hints and
; their checkers will not have been run.

; This process is repeated until there are no custom keywords in the list.
; This iteration is limited by a counter that is initially set to
; *custom-keyword-max-iterations*.

; When all custom keywords are eliminated, the hint is translated
; conventionally and applied to the subgoal.

; Thus, if the hint attached to a goal-spec contains any custom keyword, it
; cannot be fully translated until the goal arises.  (Typically, custom hints,
; like computed hints, look at the clause itself.)  For that reason, if a
; user-supplied hint,

; ("goal-spec" . keyword-alist)

; contains a custom keyword among the keys in the keyword-alist, we translate
; it to a full-fledged computed hint:

; (custom-keyword-hint-interpreter
;   'keyword-alist
;   'parsed-goal-spec
;    ID CLAUSE WORLD STABLE-UNDER-SIMPLIFICATIONP HIST PSPV CTX STATE)

; and further evaluation and translation happens when the subgoal arises.  (We
; do eagerly evaluate custom keyword hints if their associated gtermi do not
; involve any of the dynamically determined variables, like CLAUSE.)

; Note that gtermi is free to add as many :NO-OP T entries as it wants to
; insure the result is non-empty, if that's a problem.

(defconst *top-hint-keywords*

; WARNING: :use must precede :cases in this list, because
; of its use in the call of first-assoc-eq in apply-top-hints-clause.
; Specifically, if both :use and :cases are present in the hint-settings, then
; apply-top-hints-clause1 expects that call of first-assoc-eq to return the
; :use hint.  See apply-top-hints-clause1.

  '(:use :cases :by :bdd :clause-processor :or))

(defconst *hint-keywords*

; This constant contains all the legal hint keywords as well as
; :computed-hints-replacement.

  (append *top-hint-keywords*
          '(:computed-hints-replacement
            :error
            :no-op
            :no-thanks
            :expand
            :case-split-limitations
            :restrict
            :do-not
            :do-not-induct
            :hands-off
            :in-theory
            :nonlinearp
            :backchain-limit-rw
            :reorder
            :backtrack
            :induct
            :rw-cache-state)))

(table custom-keywords-table nil nil
       :guard

; Val must be of the form (uterm1 uterm2), where uterm1 and uterm2 are
; untranslated terms with certain syntactic properties, including being
; single-threaded in state and with output signatures (mv erp val state).  But
; we cannot check that without access to state.  So we actually don't check
; those key properties until we use them and we employ trans-eval at that
; point.

; #+ACL2-PAR note: it may be the case that, with waterfall parallelism enabled,
; both uterm1 and uterm2 must not return state.

; As a matter of interest, uterm1 is the untranslated generator term for the
; key and uterm2 is the untranslated checker term.

       (and (not (member-eq key *hint-keywords*))
            (true-listp val)
            (equal (length val) 2)))

#+acl2-loop-only
(defmacro add-custom-keyword-hint (key uterm1 &key (checker '(value t)))

  ":Doc-Section Events

  add a new custom keyword hint~/
  ~bv[]
  Examples:
  (add-custom-keyword-hint :my-hint (my-hint-fn val ...))

  (add-custom-keyword-hint :my-hint
                           (my-hint-fn val ...)
                           :checker (my-hint-checker-fn val ...))
  ~ev[]
  ~/
  ~bv[]
  General Form:
  (add-custom-keyword-hint :key term1 :checker term2)
  ~ev[]
  where ~c[:key] is a ~ilc[keywordp] not among the primitive keyword hints
  listed in ~c[*hint-keywords*], the ~c[:checker] argument is optional, and
  ~c[term1] and (if supplied) ~c[term2] are terms with certain free-variable
  and signature restrictions described below.  Henceforth, ~c[:key] is
  treated as a custom keyword hint, e.g., the user can employ ~c[:key] in hints
  to ~ilc[defthm], such as:
  ~bv[]
  (defthm name ...
    :hints ((\"Subgoal *1/1'\" ... :key val ...))).
  ~ev[]

  Custom keyword hints are complicated.  To use them you must understand
  ~ilc[state], multiple values (e.g., ~ilc[mv] and ~ilc[mv-let]), ACL2's notion
  of error triples (~pl[programming-with-state]), how to generate ``soft''
  errors with ~ilc[er], how to use ~ilc[fmt]-strings to control output, how to
  use computed hints (~pl[computed-hints]) and some aspects of ACL2's internal
  event processing.  Furthermore, it is possible to implement a custom keyword
  hint that can make an event non-reproducible!  So we recommend that these
  hints be developed by ACL2 experts.  Basically the custom keyword feature
  allows the implementors and other experts to extend the hint facility without
  modifying the ACL2 sources.

  ~c[Term1] is called the ``generator'' term and ~c[term2] is called the
  ``checker'' term of the custom keyword hint ~c[:key].  Together they specify
  the semantics of the new custom keyword hint ~c[:key].  Roughly speaking,
  when a custom keyword hint is supplied by the user, as in
  ~bv[]
  (defthm name ...
    :hints ((\"Subgoal *1/1'\" ... :my-hint val ...))).
  ~ev[]
  the checker term is evaluated on ~c[val] to check that ~c[val] is of the
  expected shape.  Provided ~c[val] passes the check, the generator term is
  used to compute a standard hint.  Like computed hints, the generator of a
  custom keyword hint is allowed to inspect the actual clause on which it is
  being fired.  Indeed, it is allowed to inspect the entire list of hints
  (standard and custom) supplied for that clause.  Thus, in the most general
  case, a custom keyword hint is just a very special kind of computed hint.

  The generator, ~c[term1], must have no free variables other than:
  ~bv[]
  (val keyword-alist
   id clause world stable-under-simplificationp
   hist pspv ctx state).
  ~ev[]
  Moreover, either ~c[term1] must evaluate to a single non-~il[stobj] value, or
  else it must be single-threaded in ~c[state] and have the standard
  error-triple output signature, ~c[(mv * * state)].

  The restrictions on the checker, ~c[term2], are that it be single-threaded in
  ~c[state], have the standard error-triple output signature,
  ~c[(mv * * state)], and have no free variables other than:
  ~bv[]
  (val world ctx state).
  ~ev[]

  For examples, see the community books directory ~c[books/hints/], in
  particular ~c[basic-tests.lisp].

  To delete a previously added custom keyword hint,
  ~pl[remove-custom-keyword-hint].

  The community book ~c[hints/merge-hint.lisp] can be useful in writing
  custom keyword hints.  See the examples near the of the file.

  Note: This is an event!  It does not print the usual event summary but
  nevertheless changes the ACL2 logical ~il[world] and is so recorded.~/"

    `(add-custom-keyword-hint-fn ',key ',uterm1 ',checker state))

#-acl2-loop-only
(defmacro add-custom-keyword-hint (&rest args)
  (declare (ignore args))
  nil)

(defmacro remove-custom-keyword-hint (keyword)

  ":Doc-Section Events

  remove a custom keyword hint~/
  ~bv[]
  Example Forms:
  (remove-custom-keyword-hint :my-hint)
  ~/

  General Form:
  (remove-custom-keyword-hint keyword)
  ~ev[]
  where ~c[keyword] is a ~ilc[keywordp].

  For an explanation of how custom keyword hints are processed,
  ~pl[custom-keyword-hints]; also ~pl[add-custom-keyword-hint].

  Note: This is an event!  It does not print the usual event summary
  but nevertheless changes the ACL2 logical ~il[world] and is so recorded.~/"

  `(table custom-keywords-table nil
          (let ((tbl (table-alist 'custom-keywords-table world)))
            (if (assoc-eq ',keyword tbl)
                (delete-assoc-eq-exec ',keyword tbl)
              (prog2$ (cw "~%NOTE:  the name ~x0 did not appear as a key in ~
                           custom-keywords-table.  Consider using :u or :ubt to ~
                           undo this event, which is harmless but does not ~
                           change custom-keywords-table.~%"
                          ',keyword)
                      tbl)))
          :clear))

(defun splice-keyword-alist (key new-segment keyword-alist)
  (declare (xargs :guard (and (keywordp key)
                              (keyword-value-listp keyword-alist)
                              (true-listp new-segment))))
  (cond
   ((endp keyword-alist) nil)
   ((eq key (car keyword-alist))
    (append new-segment (cddr keyword-alist)))
   (t (cons (car keyword-alist)
            (cons (cadr keyword-alist)
                  (splice-keyword-alist key new-segment
                                        (cddr keyword-alist)))))))

(deflabel custom-keyword-hints
  :doc
  ":Doc-Section Miscellaneous

  user-defined hints~/

  ~l[add-custom-keyword-hint] for a discussion of how advanced users can define
  their own hint keywords.  For examples, see the community books directory
  ~c[books/hints/], in particular ~c[basic-tests.lisp].~/~/")

(defmacro show-custom-keyword-hint-expansion (flg)
  ":Doc-Section custom-keyword-hints

   print out custom keyword hints when they are expanded~/
  ~bv[]
  Examples:
  (show-custom-keyword-hint-expansion t)
  (show-custom-keyword-hint-expansion nil)
  ~ev[]
  ~/
  ~bv[]
  General Form:
  (show-custom-keyword-hint-expansion flg)
  ~ev[]

  If the value of ~c[flg] is non-~c[nil], then when custom keyword hints are
  expanded, the system prints the results of each expansion.  This is sometimes
  useful for debugging custom keyword hints and, from time to time, may be
  useful in understanding how a custom hint affects some proof attempt.

  The default setting is ~c[nil].

  For an explanation of how custom keyword hints are processed,
  ~pl[custom-keyword-hints].~/"

  `(f-put-global 'show-custom-keyword-hint-expansion ,flg state))

; Start implementation of search.

(defun search-fn-guard (seq1 seq2 from-end test start1 start2 end1 end2
                             end1p end2p)
  (declare (xargs :guard t)
           (ignore from-end))
  (and (cond ((not (member-eq test '(equal char-equal)))
              (er hard? 'search
                  "For the macro ~x0, only the :test values ~x1 and ~x2 are ~
                   supported; ~x3 is not.  If you need other tests supported, ~
                   please contact the ACL2 implementors."
                  'search 'equal 'char-equal test))
             ((and (stringp seq1)
                   (stringp seq2))
              (or (eq test 'equal)
                  (and (standard-char-listp (coerce seq1 'list))
                       (standard-char-listp (coerce seq2 'list)))
                  (er hard? 'search
                      "When ~x0 is called on two strings, they must both ~
                       consist of standard characters.  However, this is not ~
                       the case for ~x1."
                      'search
                      (if (standard-char-listp (coerce seq1 'list))
                          seq2
                        seq1))))
             ((eq test 'char-equal)
              (er hard? 'search
                  "For the macro ~x0, the :test ~x1 is only supported for ~
                   string arguments.  If you need this test supported for ~
                   true lists, please contact the ACL2 implementors."
                  'search 'char-equal))
             ((and (true-listp seq1)
                   (true-listp seq2))
              t)
             (t
              (er hard? 'search
                  "The first two arguments of ~x0 must both evaluate to true ~
                   lists or must both evaluate to strings."
                  'search)))
       (let ((end1 (if end1p end1 (length seq1)))
             (end2 (if end2p end2 (length seq2))))
         (and (natp start1)
              (natp start2)
              (natp end1)
              (natp end2)
              (<= start1 end1)
              (<= start2 end2)
              (<= end1 (length seq1))
              (<= end2 (length seq2))))))

(defun search-from-start (seq1 seq2 start2 end2)
  (declare (xargs :measure (nfix (1+ (- end2 start2)))
                  :guard (and (or (true-listp seq1)
                                  (stringp seq1))
                              (or (true-listp seq2)
                                  (stringp seq2))
                              (integerp start2)
                              (<= 0 start2)
                              (integerp end2)
                              (<= end2 (length seq2))
                              (<= (+ start2 (length seq1)) end2))))
  (let ((bound2 (+ start2 (length seq1))))
    (cond
     ((or (not (integerp end2))
          (not (integerp start2)))
      nil)
     ((equal seq1 (subseq seq2 start2 bound2))
      start2)
     ((>= bound2 end2)
      nil)
     (t
      (search-from-start seq1 seq2 (1+ start2) end2)))))

(defun search-from-end (seq1 seq2 start2 end2 acc)
  (declare (xargs :measure (nfix (1+ (- end2 start2)))
                  :guard (and (or (true-listp seq1)
                                  (stringp seq1))
                              (or (true-listp seq2)
                                  (stringp seq2))
                              (integerp start2)
                              (<= 0 start2)
                              (integerp end2)
                              (<= end2 (length seq2))
                              (<= (+ start2 (length seq1)) end2))))
  (cond
   ((or (not (integerp end2))
        (not (integerp start2)))
    nil)
   (t
    (let* ((bound2 (+ start2 (length seq1)))
           (matchp (equal seq1 (subseq seq2 start2 bound2)))
           (new-acc (if matchp start2 acc)))
      (cond
       ((>= bound2 end2)
        new-acc)
       (t
        (search-from-end seq1 seq2 (1+ start2) end2 new-acc)))))))

; The following lemmas are needed for guard verification of search-fn.

(encapsulate
 ()

 (local
  (defthm len-string-downcase1
    (equal (len (string-downcase1 x))
           (len x))))

 (local
  (defthm stringp-subseq
    (implies (stringp str)
             (stringp (subseq str start end)))))

 (local
  (defthm standard-char-listp-nthcdr
    (implies (standard-char-listp x)
             (standard-char-listp (nthcdr n x)))
    :hints (("Goal" :in-theory (enable standard-char-listp)))))

 (local
  (defthm standard-char-listp-revappend
    (implies (and (standard-char-listp x)
                  (standard-char-listp ac))
             (standard-char-listp (revappend x ac)))
    :hints (("Goal" :in-theory (enable standard-char-listp)))))

 (local
  (defthm standard-char-listp-first-n-ac
    (implies (and (standard-char-listp x)
                  (standard-char-listp ac)
                  (<= n (len x)))
             (standard-char-listp (first-n-ac n x ac)))
    :hints (("Goal" :in-theory (enable standard-char-listp)))))

 (local
  (defthm character-listp-first-n-ac
    (implies (and (character-listp x)
                  (character-listp ac)
                  (<= n (len x)))
             (character-listp (first-n-ac n x ac)))))

 (local
  (defthm character-listp-nthcdr
    (implies (character-listp x)
             (character-listp (nthcdr n x)))))

 (local
  (defthm nthcdr-nil
    (equal (nthcdr n nil)
           nil)))

 (local
  (defthm len-nthcdr
    (equal (len (nthcdr n x))
           (nfix (- (len x) (nfix n))))))

 (local
  (defthm subseq-preserves-standard-char-listp
    (implies (and (stringp seq)
                  (natp start)
                  (natp end)
                  (<= start end)
                  (<= end (length seq))
                  (standard-char-listp (coerce seq 'list)))
             (standard-char-listp (coerce (subseq seq start end)
                                          'list)))))

 (local
  (defthm true-listp-revappend
    (equal (true-listp (revappend x y))
           (true-listp y))))

 (local
  (defthm true-listp-first-n-ac
    (implies (and (true-listp acc)
                  (true-listp lst))
             (true-listp (first-n-ac n lst acc)))))

 (local
  (defthm true-listp-nthcdr
    (implies (true-listp x)
             (true-listp (nthcdr n x)))))

 (local
  (defthm true-listp-subseq
    (implies (true-listp seq)
             (true-listp (subseq seq start end)))
    :rule-classes (:rewrite :type-prescription)))

 (local
  (defthm len-revappend
    (equal (len (revappend x y))
           (+ (len x) (len y)))))

 (local
  (defthm len-first-n-ac
    (implies (true-listp ac)
             (equal (len (first-n-ac n lst ac))
                    (+ (nfix n) (len ac))))))

 (local
  (defthm len-subseq
    (implies (and (true-listp seq)
                  (natp start)
                  (natp end)
                  (<= start end))
             (equal (len (subseq seq start end))
                    (- end start)))))

 (local
  (defthm len-subseq-string
    (implies (and (stringp seq)
                  (natp start)
                  (natp end)
                  (<= start end)
                  (<= end (len (coerce seq 'list))))
             (equal (len (coerce (subseq seq start end)
                                 'list))
                    (- end start)))
    :hints (("Goal" :in-theory (enable subseq)))))

 (defun search-fn (seq1 seq2 from-end test start1 start2 end1 end2 end1p end2p)
   (declare (xargs
             :guard
             (search-fn-guard seq1 seq2 from-end test start1 start2 end1 end2
                              end1p end2p)
             :guard-hints (("Goal" :in-theory (disable subseq)))))
   #-acl2-loop-only ; only called when the guard is true
   (if (or end1p end2p)
       (search seq1 seq2
               :from-end from-end :test test
               :start1 start1 :start2 start2
               :end1 (if end1p end1 (length seq1))
               :end2 (if end2p end2 (length seq2)))
     (search seq1 seq2
             :from-end from-end :test test
             :start1 start1 :start2 start2))
   #+acl2-loop-only
   (let* ((end1 (if end1p end1 (length seq1)))
          (end2 (if end2p end2 (length seq2)))
          (seq1 (subseq seq1 start1 end1)))
     (mv-let
      (seq1 seq2)
      (cond ((eq test 'char-equal) ; hence, both are strings, by the guard
             (mv (string-downcase seq1) (string-downcase seq2)))
            (t (mv seq1 seq2)))
      (and (<= (- end1 start1) (- end2 start2))
           (cond (from-end
                  (search-from-end seq1 seq2 start2 end2 nil))
                 (t
                  (search-from-start seq1 seq2 start2 end2)))))))
 )

#+acl2-loop-only
(defmacro search (seq1 seq2
                       &key
                       from-end (test ''equal)
                       (start1 '0) (start2 '0)
                       (end1 'nil end1p) (end2 'nil end2p))

  ":Doc-Section ACL2::ACL2-built-ins

  search for a string or list in another string or list~/

  ~bv[]
  Example Forms:
  (search \"cd\" \"Cdabcdefcde\")                   ; = 4, index of first match
  (search \"cd\" \"Cdabcdefcde\" :test 'equal)      ; same as above
  (search \"cd\" \"Cdabcdefcde\" :from-end t)       ; = 8, index of last match
  (search \"cd\" \"Cdabcdefcde\" :start1 1)         ; = 1
  (search \"cd\" \"Cdabcdefcde\" :start2 5)         ; = 8
  (search \"cd\" \"Cdabcdefcde\" :test 'char-equal) ; = 0 (case-insensitive)
  (search \"ac\" \"Cdabcdefcde\")                   ; = nil
  (search '(a b) '(9 8 a b 7 6))                    ; = 2~/

  General Form:
  (search seq1 seq2 &key from-end test start1 start2 end1 end2)
  ~ev[]

  ~c[Search] indicates whether one string or list occurs as a (contiguous)
  subsequence of another string or list, respectively.  It returns ~c[nil] if
  no such match is found; otherwise it returns the (zero-based) index of the
  first match by default, but a non-~c[nil] value of keyword argument
  ~c[:from-end] causes it to return the last match.  The ~c[:test] is ~c[equal]
  by default.  The other legal value for ~c[:test] is ~c[char-equal], which can
  be given only for two strings, in which case the match is case-insensitive.
  Finally, values of ~c[:start1] and ~c[:end1] for the first sequence, and of
  ~c[:start2] and ~c[:end2] for the second sequence, bound the portion of the
  respective sequence used for deciding on a match, though the index returned
  is always an index into the second sequence as a whole.

  The ~il[guard] for calls of ~c[search] is given by a function,
  ~c[search-fn-guard], which has the following requirements.~bq[]

  o The two arguments much both satisfy ~ilc[true-listp] or else must both be
  strings, which must consist of standard characters (~pl[standard-char-p]) if
  the ~c[:test] is ~ilc[char-equal].

  o The ~c[:test] must evaluate to one of the symbols ~ilc[equal] or
  ~ilc[char-equal], where the latter is only allowed if the (first) two
  arguments are strings.

  o The values of ~c[:start1], ~c[:start2], ~c[:end1], and ~c[:end2] must all
  be natural numbers, where if omitted they default to 0, 0, the length
  ~c[len1] of the first argument, and the length ~c[len2] of the second
  argument, respectively.

  o If ~c[start1] is the value of ~c[:start1], defaulting as described just
  above, and similarly for the other start and end keywords and for lengths
  ~c[len1] and ~c[len2] as described just above, then:
  ~c[start1 <= end1 <= len1] and ~c[start2 <= end2 <= len2].

  ~eq[]~c[Search] is a Common Lisp function (actually, a macro in ACL2).  See
  any Common Lisp documentation for more information.~/"

  `(search-fn ,seq1 ,seq2 ,from-end ,test ,start1 ,start2 ,end1 ,end2
              ,end1p ,end2p))

(defthm eqlablep-nth
  (implies (eqlable-listp x)
           (eqlablep (nth n x)))
  :hints (("Goal" :in-theory (enable nth))))

(defun count-stringp (item x start end)
  (declare (xargs :guard (and (stringp x)
                              (natp start)
                              (natp end)
                              (<= end (length x)))
                  :measure (nfix (- (1+ end) start))))
  (cond ((or (not (integerp start))
             (not (integerp end))
             (<= end start))
         0)
        ((eql item (char x start))
         (1+ (count-stringp item x (1+ start) end)))
        (t
         (count-stringp item x (1+ start) end))))

(defun count-listp (item x end)
  (declare (xargs :guard (and (true-listp x)
                              (natp end))))
  (cond ((or (endp x)
             (zp end))
         0)
        ((equal item (car x))
         (1+ (count-listp item (cdr x) (1- end))))
        (t
         (count-listp item (cdr x) (1- end)))))

(encapsulate
 ()

 (local (defthm true-listp-nthcdr
          (implies (true-listp x)
                   (true-listp (nthcdr n x)))))

 (defun count-fn (item sequence start end)
   (declare (xargs :guard (and (if (true-listp sequence)
                                   t
                                 (stringp sequence))
                               (natp start)
                               (or (null end)
                                   (and (natp end)
                                        (<= end (length sequence)))))))
   (let ((end (or end (length sequence))))
     (cond ((<= end start)
            0)
           ((stringp sequence)
            (count-stringp item sequence start end))
           (t
            (count-listp item (nthcdr start sequence) (- end start)))))))

#+acl2-loop-only
(defmacro count (item sequence &key (start '0) end)

  ":Doc-Section ACL2::ACL2-built-ins

  count the number of occurrences of an item in a string or true-list~/

  ~bv[]
  Example Forms:
  (count #\\D \"DabcDefcDe\")                 ; = 3
  (count #\\D \"DabcDefcDe\" :start 1)        ; = 2
  (count #\\D \"DabcDefcDe\" :start 1 :end 5) ; = 1
  (count #\\D \"DabcDefcDe\" :start 1 :end 4) ; = 0
  (count #\\z \"DabcDefcDe\")                 ; = 0
  (count '(a b) '(17 (a b) 23 (a b) (c d)))   ; = 2

  General Form:
  (count item sequence &key start end)
  ~ev[]

  ~c[(Count item sequence)] returns the number of times ~c[item] occurs in
  ~c[sequence].  The ~il[guard] for calls of ~c[count] (which is actually a
  macro in ACL2) specifies that ~c[sequence] is a string or a true-list, and
  that ~c[start], which defaults to 0, and ~c[end], which defaults to the
  length of ~c[sequence], are valid indices into sequence.

  See any Common Lisp documentation for more information about ~c[count], which
  is a Common Lisp utility.  At this time ACL2 does not support keyword
  arguments for ~c[count] other than ~c[:start] and ~c[:end]; we may add
  support for the ~c[:from-end] keyword upon request.~/~/"

  `(count-fn ,item ,sequence ,start ,end))

; Skipped on first (:program mode) pass:
(verify-termination-boot-strap cpu-core-count)

; We need for sharp-atsign-alist to be compiled before it is called in
; *sharp-atsign-ar*, file basis.lisp.  So we put its definition here, along
; with its callee make-sharp-atsign.  A nice exercise is to put these functions
; in :logic mode.

(defun make-sharp-atsign (i)
  (declare (xargs :guard (natp i) :mode :program))
  (concatenate 'string
               "#@"
               (coerce (explode-nonnegative-integer i 10 nil) 'string)
               "#"))

(defun sharp-atsign-alist (i acc)
  (declare (xargs :guard (natp i) :mode :program))
  (cond ((zp i) acc)
        (t (sharp-atsign-alist (1- i) (acons i (make-sharp-atsign i) acc)))))

; Essay on the Implementation of Time$

; It is tempting to define (time$ x ...) to be a macro expanding to x in the
; logic.  But then translate will eliminate time$; yet some version of time$
; needs to be a function, so that it is still around for ev-rec to see.  If it
; weren't for ev-rec, time$ could be a macro as long as it were left alone by
; oneify, i.e., on the list *macros-for-nonexpansion-in-raw-lisp*.

; So, we need some way to represent time$ as a function in the logic.  On the
; other hand, we cannot define time$ as a function in raw Lisp, because then
; its arguments will be evaluated before there is any opportunity to set things
; up to get timing information.

; Consider also the issue of keyword arguments.  We want time$ to take keyword
; arguments, but on the other hand, we do not allow functions with keyword
; arguments.  So again we see that time$ needs to be a macro.

; Thus, we define time$ to be a macro that expands to a corresponding call of
; time$1, which in turn expands to a call (return-last 'time$1-raw & &).
; Return-last is a function in the logic but is a macro in raw Lisp.  Since
; return-last is a function in the logic, it does not take keyword arguments;
; for convenience we define a macro our-time to be the keyword version of the
; raw Lisp macro time$1-raw.

; The following examples make a nice little test suite.  Run each form and
; observe whether the output is consistent with the comments attached to the
; form.

; (defun f (n)
;   (declare (xargs :guard (natp n) :verify-guards nil))
;   (make-list n))
; (time$ (length (f 100))) ; times an ev-rec call
; (time$ (length (f 100)) :mintime 0) ; same as above
; (time$ (length (f 100)) :mintime nil) ; native time output
; (defun g (x native-p)
;   (declare (xargs :guard (natp x) :verify-guards nil))
;   (if native-p
;       (len (time$ (f x) :mintime nil))
;     (len (time$ (f x)))))
; (g 100 nil) ; time a *1*f call
; (g 100 t) ; time a *1*f call
; (verify-guards f)
; (g 100 nil) ; still times a *1*f call, since g's guards aren't verified
; (g 100 t) ; still times a *1*f call, since g's guards aren't verified
; (verify-guards g)
; (g 100 nil) ; times a call of f
; (g 100 t) ; times a call of f
; ; Check unnormalized and normalized bodies:
; (assert-event (equal (body 'g nil (w state))
;                      '(IF NATIVE-P
;                           (LEN (RETURN-LAST
;                                 'TIME$1-RAW
;                                 (CONS 'NIL
;                                       (CONS 'NIL
;                                             (CONS 'NIL
;                                                   (CONS 'NIL
;                                                         (CONS 'NIL 'NIL)))))
;                                 (F X)))
;                           (LEN (RETURN-LAST
;                                 'TIME$1-RAW
;                                 (CONS '0
;                                       (CONS 'NIL
;                                             (CONS 'NIL
;                                                   (CONS 'NIL
;                                                         (CONS 'NIL 'NIL)))))
;                                 (F X))))))
; (assert-event (equal (body 'g t (w state))
;                      '(LEN (F X))))
; (time$ 3 :mintime nil) ; prints verbose, native timing message
; (time$ 3 :minalloc 0) ; prints usual timing message
; (time$ 3 :mintime 0 :real-mintime 0) ; error
; (time$ 3 :mintime 0 :run-mintime 0) ; prints usual timing message
; (time$ 3 :real-mintime 1) ; no timing output
; (time$ 3 :run-mintime 1) ; no timing output
; (time$ 3 :minalloc 10000) ; no timing output if :minalloc is supported
; (time$ (length (f 100)) ; prints "Howdy"
;        :msg "Howdy~%")
; (let ((bar (+ 3 4)))
;   (time$ (length (f 100000)) ; prints indicated timing message
;          :msg "The execution of ~xf took ~st seconds (in real time; ~sc sec. ~
;                run time), and allocated ~sa bytes.  In an unrelated note, bar ~
;                currently has the value ~x0.~%"
;          :args (list bar)))
; (defun h (x real-min run-min alloc msg args)
;   (declare (xargs :guard (natp x)))
;   (len (time$ (f x)
;               :mintime real-min
;               :run-mintime run-min
;               :minalloc alloc
;               :msg msg
;               :args args)))
; (h 1000000 nil nil nil nil nil) ; native time msg
; (h 1000000 0 nil nil nil nil) ; usual time msg
; (h 1000000 nil nil nil ; custom time msg, as indicated
;    "The execution of ~xf took ~st seconds (in real time; ~sc sec. run time), ~
;     and allocated ~sa bytes.  In an unrelated note, bar currently has the ~
;     value ~x0.~%"
;    (list (+ 4 5)))

; End of Essay on the Implementation of Time$

#-acl2-loop-only
(defmacro time$1-raw (val x)
  (let ((val-var (gensym))
        (real-mintime-var (gensym))
        (run-mintime-var (gensym))
        (minalloc-var (gensym))
        (msg-var (gensym))
        (args-var (gensym)))
    `(let* ((,val-var ,val)
            (,real-mintime-var (pop ,val-var))
            (,run-mintime-var (pop ,val-var))
            (,minalloc-var (pop ,val-var))
            (,msg-var (pop ,val-var))
            (,args-var (pop ,val-var)))
       (our-time ,x
                 :real-mintime ,real-mintime-var
                 :run-mintime ,run-mintime-var
                 :minalloc ,minalloc-var
                 :msg ,msg-var
                 :args ,args-var))))

(defmacro time$1 (val form)
  `(return-last 'time$1-raw ,val ,form))

(defmacro time$ (x &key
                   (mintime '0 mintime-p)
                   (real-mintime 'nil real-mintime-p)
                   run-mintime minalloc msg args)

  ":Doc-Section ACL2::ACL2-built-ins

  time an evaluation~/

  Semantically, ~c[(time$ x ...)] equals ~c[x].  However, its evaluation may
  write timing output to the trace output (which is usually the terminal), as
  explained further below.

  ~bv[]
  Examples:

  ; Basic examples:

  (time$ (foo 3 4))
  (time$ (mini-proveall))
  (defun bar (x) (time$ (f x)))

  ; Custom examples, which use a custom timing message rather than a built-in
  ; message from Lisp:

  ; Report only if real time is at least 1/2 second (two equivalent forms).
  (time$ (foo) :mintime 1/2)
  (time$ (foo) :real-mintime 1/2)

  ; Report only if allocation is at least 1000 bytes (and if the Lisp supports
  ; :minalloc).
  (time$ (foo) :minalloc 1000)

  ; Report only if real time is at least 1/2 second and (if the Lisp supports
  ; :minalloc) allocation is at least 931 bytes.
  (time$ (foo) :real-mintime 1/2 :minalloc 931)

  ; Print \"Hello Moon, Goodbye World\" instead of any timing data.
  (time$ (foo)
         :msg \"Hello ~~s0, ~~s1 World.\"
         :args (list \"Moon\" \"Goodbye\"))

  ; Print default custom timing message (same as omitting :mintime 0):
  (time$ (foo)
         :mintime 0)

  ; Print supplied custom timing message.
  (let ((bar ...))
    (time$ (foo)
           :msg \"The execution of ~~xf took ~~st seconds of real ~~
                 time and ~~sc seconds of run time (cpu time), and ~~
                 allocated ~~sa bytes.  In an unrelated note, bar ~~
                 currently has the value ~~x0.~~%\"
           :args (list bar)))~/

  General Forms:
  (time$ form)
  (time$ form ; arguments below are optional
         :real-mintime  <rational number of seconds>
         :run-mintime   <rational number of seconds>
         :minalloc      <number of bytes>
         :msg           <fmt string>
         :args          <list of arguments for msg>
         )
  ; Note: :real-mintime can be replaced by :mintime
  ~ev[]
  where ~c[form] is processed as usual except that the host Common Lisp times
  its evaluation.

  The simplest form is ~c[(time$ x)], which will call the ~c[time] utility in
  the underlying Lisp, and will print a small default message.  If you want to
  see a message printed by the host Lisp, use ~c[(time$ x :mintime nil)]
  instead, which may provide detailed, implementation-specific data such as the
  amounts of time spent in user and system mode, the gc time, the number of
  page faults encountered, and so on.  Of you can create a custom message,
  configured using the ~c[:msg] and ~c[:args] parameters.  ~c[Time$] can also
  be made to report timing information only conditionally: the
  ~c[:real-mintime] (or equivalently, ~c[:mintime]), ~c[:run-mintime], and
  ~c[:minalloc] arguments can be used to avoid reporting timing information for
  computations that take a small amount of time (perhaps as might be expected
  in ordinary cases), but to draw the user's attention to computations that
  take longer or allocate more memory than expected.

  We next document the keyword arguments in some detail.

  ~bq[]
  Keyword arguments ~c[:real-mintime] (or ~c[:mintime]) and ~c[:run-mintime]
  can be used to specify a minimum time threshold for time reporting.  That is,
  no timing information will be printed if the execution of ~c[form] takes less
  than the specified number of seconds of real (total) time or run (cpu) time,
  respectively.  Note that rational numbers like 1/2 may be used to specify a
  fractional amount of seconds.  It is an error to specify both
  ~c[:real-mintime] and its synonym, ~c[:mintime].

  Keyword argument ~c[:minalloc] is not supported on all Lisps.  When it is not
  supported, it is ignored.  But on supported Lisps, ~c[:minalloc] can be used
  to specify a minimum memory allocation threshold.  If ~c[form] results in
  fewer than this many bytes being allocated, then no timing information will
  be reported.

  Keyword argument ~c[:msg], when provided, should be a string accepted by the
  ~c[fmt] family of functions (~pl[fmt]), and it may refer to the elements of
  ~c[:args] by their positions, just as for ~c[cw] (~pl[cw]).~eq[]

  The following directives allow you to report timing information using the
  ~c[:msg] string.  The examples at the top of this documentation topic
  illustrate the use of these directives.
  ~bq[]
  ~c[~~xf] ~-[] the form that was executed

  ~c[~~sa] ~-[] the amount of memory allocated, in bytes (in supported Lisps)

  ~c[~~st] ~-[] the real time taken, in seconds

  ~c[~~sc] ~-[] the run time (cpu time) taken, in seconds
  ~eq[]

  We turn now to an example that illustrates how ~c[time$] can be called in
  function bodies.  Consider the following definition of the Fibonacci
  function, followed by the definition of a function that times ~c[k] calls of
  this function.
  ~bv[]
  (defun fib (n)
    (if (zp n)
        1
      (if (= n 1)
          1
        (+ (fib (- n 1))
           (fib (- n 2))))))

  (defun time-fib (k)
    (if (zp k)
        nil
      (prog2$
       (time$ (fib k)
              :mintime 1/2
              :msg \"(fib ~~x0) took ~~st seconds, ~~sa bytes allocated.~~%\"
              :args (list k))
       (time-fib (1- k)))))
  ~ev[]
  The following log shows a sample execution of the function defined just
  above.
  ~bv[]
  ACL2 !>(time-fib 36)
  (fib 36) took 3.19 seconds, 1280 bytes allocated.
  (fib 35) took 1.97 seconds, 1280 bytes allocated.
  (fib 34) took 1.21 seconds, 1280 bytes allocated.
  (fib 33) took 0.75 seconds, 1280 bytes allocated.
  NIL
  ACL2 !>
  ~ev[]

  Notes:

  (1) Common Lisp specifies that the ~c[time] utility prints to ``trace
  output'', and ~c[time$] follows this convention.  Thus, if you have opened a
  ~il[trace] file (~pl[open-trace-file]), then you can expect to find the
  ~c[time$] output there.

  (2) Unless the ~c[:msg] argument is supplied, an explicit call of ~c[time$]
  in the top-level loop will show that the form being timed is a call of the
  ACL2 evaluator function ~c[ev-rec].  This is normal; the curious are invited,
  at their own risk, to ~pl[return-last] for an explanation.~/

  :cited-by ACL2::Programming
  :cited-by other"

  (declare (xargs :guard t))
  (cond
   ((and real-mintime-p mintime-p)
    (er hard 'time$
        "It is illegal for a ~x0 form to specify both :real-mintime and ~
         :mintime."
        'time$))
   (t
    (let ((real-mintime (or real-mintime mintime)))
      `(time$1 (list ,real-mintime ,run-mintime ,minalloc ,msg ,args)
               ,x)))))

#-acl2-loop-only
(progn

(defmacro our-multiple-value-prog1 (form &rest other-forms)

; WARNING: If other-forms causes any calls to mv, then use protect-mv so that
; when #-acl2-mv-as-values, the multiple values returned by evaluation of form
; are those returned by the call of our-multiple-value-prog1.

  `(#+acl2-mv-as-values
    multiple-value-prog1
    #-acl2-mv-as-values
    prog1
    ,form
    ,@other-forms))

(eval `(mv ,@(make-list *number-of-return-values* :initial-element 0)))

#-acl2-mv-as-values
(defconst *mv-vars*
  (let ((ans nil))
    (dotimes (i (1- *number-of-return-values*))
      (push (gensym) ans))
    ans))

#-acl2-mv-as-values
(defconst *mv-var-values*
  (mv-refs-fn (1- *number-of-return-values*)))

#-acl2-mv-as-values
(defconst *mv-extra-var* (gensym))

(defun protect-mv (form &optional multiplicity)

; We assume here that form is evaluated only for side effect and that we don't
; care what is returned by protect-mv.  All we care about is that form is
; evaluated and that all values stored by mv will be restored after the
; evaluation of form.

  #+acl2-mv-as-values
  (declare (ignore multiplicity))
  #-acl2-mv-as-values
  (when (and multiplicity
             (not (and (integerp multiplicity)
                       (< 0 multiplicity))))
    (error "PROTECT-MV must be called with an explicit multiplicity, when ~
            supplied, unlike ~s"
           multiplicity))
  `(progn
     #+acl2-mv-as-values
     ,form
     #-acl2-mv-as-values
     ,(cond
       ((eql multiplicity 1)
        form)
       ((eql multiplicity 2)
        `(let ((,(car *mv-vars*)
                ,(car *mv-var-values*)))
           ,form
           (mv 0 ,(car *mv-vars*))))
       (t (mv-let (mv-vars mv-var-values)
                  (cond (multiplicity
                         (mv (nreverse
                              (let ((ans nil)
                                    (tail *mv-vars*))
                                (dotimes (i (1- multiplicity))
                                  (push (car tail) ans)
                                  (setq tail (cdr tail)))
                                ans))
                             (mv-refs-fn (1- multiplicity))))
                        (t (mv *mv-vars* *mv-var-values*)))
                  `(mv-let ,(cons *mv-extra-var* mv-vars)
                           (mv 0 ,@mv-var-values)
                           (declare (ignore ,*mv-extra-var*))
                           (progn ,form
                                  (mv 0 ,@mv-vars))))))
     nil))
)

#-acl2-loop-only
(defmacro our-time (x &key real-mintime run-mintime minalloc msg args)
  (let ((g-real-mintime (gensym))
        (g-run-mintime (gensym))
        (g-minalloc (gensym))
        (g-msg (gensym))
        (g-args (gensym))
        (g-start-real-time (gensym))
        (g-start-run-time (gensym))
        #+ccl
        (g-start-alloc (gensym)))
    `(let ((,g-real-mintime ,real-mintime)
           (,g-run-mintime ,run-mintime)
           (,g-minalloc ,minalloc)
           (,g-msg ,msg)
           (,g-args ,args))
       (cond
        ((not (or ,g-real-mintime ,g-run-mintime ,g-minalloc ,g-msg ,g-args))
         #+(or allegro clisp)

; For Allegro and CLISP, the time utilities are such that it can be useful to
; print a newline before printing a top-level result.  Note that we can use
; prog1 for these Lisps today (Sept. 2009), but we consider the possibility of
; #+acl2-mv-as-values for these lisps in the future.

         (our-multiple-value-prog1
          (time ,x)
          (when (eq *trace-output* *terminal-io*)
            (newline *standard-co* *the-live-state*)))
         #-(or allegro clisp)
         (time ,x))
        ((and ,g-real-mintime (not (rationalp ,g-real-mintime)))
         (interface-er
          "Illegal call of ~x0: :real-mintime must be nil or a rational, but ~
           ~x1 is neither."
          'time$ ,g-real-mintime))
        ((and ,g-run-mintime (not (rationalp ,g-run-mintime)))
         (interface-er
          "Illegal call of ~x0: :run-mintime must be nil or a rational, but ~
           ~x1 is neither."
          'time$ ,g-run-mintime))
        ((and ,g-minalloc (not (rationalp ,g-minalloc)))
         (interface-er
          "Illegal call of ~x0: :alloc must be nil or a rational, but ~x1 is ~
           neither."
          'time$ ,g-minalloc))
        ((and ,g-msg (not (stringp ,g-msg)))
         (interface-er
          "Illegal call of ~x0: :msg must be nil or a string, but ~x1 is ~
           neither."
          'time$ ,g-msg))
        ((not (true-listp ,g-args))
         (interface-er
          "Illegal call of ~x0: :args must be a true list, but ~x1 is not."
          'time$ ,g-args))
        (t
         (let* ((,g-start-real-time (get-internal-real-time))
                (,g-start-run-time (get-internal-run-time))
                #+ccl
                (,g-start-alloc (CCL::total-bytes-allocated)))
           (our-multiple-value-prog1
            ,x
            ,(protect-mv
              `(let* ((end-run-time (get-internal-run-time))
                      (end-real-time (get-internal-real-time))
                      (real-elapsed (/ (- end-real-time ,g-start-real-time)
                                       internal-time-units-per-second))
                      (run-elapsed (/ (- end-run-time ,g-start-run-time)
                                      internal-time-units-per-second))
                      (real-elapsed-str (format nil "~,2F" real-elapsed))
                      (run-elapsed-str (format nil "~,2F" run-elapsed))
                      #+ccl
                      (allocated (- (ccl::total-bytes-allocated)
                                    ,g-start-alloc)))
                 (when
                     (not (or (and ,g-real-mintime
                                   (< real-elapsed ,g-real-mintime))
                              (and ,g-run-mintime
                                   (< run-elapsed ,g-run-mintime))
                              #+ccl
                              (and ,g-minalloc
                                   (< allocated ,g-minalloc))))
                   (let* ((alist (list* (cons #\t real-elapsed-str)
                                        (cons #\c run-elapsed-str)
                                        (cons #\a
                                              #+ccl
                                              (format nil "~:D" allocated)
                                              #-ccl
                                              "[unknown]")
                                        (cons #\f ',x)
                                        (cons #\e (evisc-tuple
                                                   3 2
                                                   (world-evisceration-alist
                                                    *the-live-state* nil)
                                                   nil))
                                        (and ,g-msg
                                             (pairlis$ '(#\0 #\1 #\2 #\3 #\4
                                                         #\5 #\6 #\7 #\8 #\9)
                                                       ,g-args))))
                          (,g-msg (or ,g-msg
                                      #+ccl
                                      "; ~Xfe took ~|; ~st seconds realtime, ~
                                       ~sc seconds runtime~|; (~sa bytes ~
                                       allocated).~%"
                                      #-ccl
                                      "; ~Xfe took~|; ~st seconds realtime, ~
                                       ~sc seconds runtime.~%")))
                     (fmt-to-comment-window
                      ,g-msg alist 0
                      (abbrev-evisc-tuple *the-live-state*)))))))))))))

(encapsulate
 ()

 (local
  (defthm true-listp-revappend
    (equal (true-listp (revappend x y))
           (true-listp y))))

 (local
  (defthm true-listp-first-n-ac
    (implies (and (true-listp acc)
                  (true-listp lst))
             (true-listp (first-n-ac n lst acc)))))

 (verify-guards throw-nonexec-error)
 (verify-guards defun-nx-fn)
 (verify-guards update-mutual-recursion-for-defun-nx-1)
 (verify-guards update-mutual-recursion-for-defun-nx)
 )

; For some reason, MCL didn't like it when there was a single definition of
; gc$-fn with acl2-loop-only directives in the body.  So we define the two
; versions separately.

#-acl2-loop-only
(defun-one-output gc$-fn (args)

; Warning: Keep this in sync with :doc gc$.

; We will add some checks on the arguments as a courtesy, but really, it is up
; to the user to pass in the right arguments.

  #+allegro (apply `excl:gc args)
  #+ccl (apply 'ccl::gc args) ; no args as per Gary Byers 12/08
  #+clisp (apply 'ext:gc args)
  #+cmu (apply 'system::gc args)
  #+gcl
  (if (eql (length args) 1)
      (apply 'si::gbc args)
    (er hard 'gc$
        "In GCL, gc$ requires exactly one argument, typically T."))
  #+lispworks (apply 'hcl::gc-generation (or args (list #+lispworks-64bit 7
                                                        #-lispworks-64bit 3)))
  #+sbcl (apply 'sb-ext:gc args)
  #-(or allegro gcl clisp cmu sbcl ccl lispworks)
  (illegal 'gc$ "GC$ is not supported in this Common Lisp." nil)
  nil)

#+acl2-loop-only
(defun gc$-fn (args)
  (declare (ignore args)
           (xargs :guard t))
  nil)

(defmacro gc$ (&rest args)
  ":Doc-Section Miscellaneous

  invoke the garbage collector~/

  This function is provided so that the user can call the garbage collector of
  the host Lisp from inside the ACL2 loop.  Specifically, a call of ~c[gc$] is
  translated into a call of a function below on the same arguments.
  ~bv[]
  Allegro CL:            excl:gc
  CCL                    ccl::gc
  CLISP                  ext:gc
  CMU Common Lisp        system::gc
  GCL                    si::gbc
  LispWorks              hcl::gc-generation [default argument list:
                                             (7) for 64-bit OS, else (3)]
  SBCL                   sb-ext:gc
  ~ev[]
  The arguments, if any, are as documented in the underlying Common Lisp.  It
  is up to the user to pass in the right arguments, although we may do some
  rudimentary checks.

  Also ~pl[gc-verbose].

  Evaluation of a call of this macro always returns ~c[nil].~/~/"

  `(gc$-fn ',args))

#-acl2-loop-only
(defun-one-output gc-verbose-fn (arg)

; For a related function, see gc$-fn.

  (let ((arg (and arg t))) ; coerce to Boolean
    (declare (ignorable arg))
    #+ccl (ccl::gc-verbose arg arg)
    #+cmu (setq ext:*gc-verbose* arg)
    #+gcl (si:*notify-gbc* arg)
    #-(or ccl cmu gcl)
    (format t "GC-VERBOSE is not supported in this Common Lisp.~%Contact the ~
               ACL2 developers if you would like to help add such support.")
    nil))

#+acl2-loop-only
(defun gc-verbose-fn (arg)
  (declare (ignore arg)
           (xargs :guard t))
  nil)

(defmacro gc-verbose (arg)
  ":Doc-Section Miscellaneous

  control printing from the garbage collector~/

  ~bv[]
  General Form:
  (gc-verbose arg)
  ~ev[]

  Garbage collection (gc) is performed by every Lisp implementation; ~pl[gc$].
  However, different ACL2 builds might see more or fewer messages.  This macro
  is intended to provide an interface for controlling the verbosity, which is
  off if the argument evaluates to ~c[nil] and otherwise is on.

  The above functionality is only supported for the following host Common Lisp
  implementations: CCL, CMUCL, and GCL.  Otherwise, the only effect of this
  macro is to print a notice that it is not supported.  You are welcome to
  contact the ACL2 developers if you would like to help in adding such support
  for another host Common Lisp.

  Evaluation of a call of this macro always returns ~c[nil].~/~/"

  `(gc-verbose-fn ,arg))

(defun get-wormhole-status (name state)

  ":Doc-Section Miscellaneous

   make a wormhole's status visible outside the wormhole~/

   General Form:
   (get-wormhole-status name state)

   ~c[Name] should be the name of a wormhole (~pl[wormhole]).  This function
   returns an error triple (~pl[error-triples]) of the form
   ~c[(mv nil s state)], where ~c[s] is the status of the named wormhole.  The
   status is obtained by reading the oracle in the ACL2 ~ilc[state].~/

   This function makes the status of a wormhole visible outside the wormhole.
   But since this function takes ~ilc[state] and modifies it, the function may
   only be used in contexts in which you may change ~ilc[state].  Otherwise,
   the wormhole status may stay in the wormhole.  See ~ilc[wormhole-eval] and
   ~ilc[wormhole].~/"

   #+acl2-loop-only
   (declare (xargs :guard (state-p state))
            (ignore name))
   #-acl2-loop-only
   (when (live-state-p state)
     (return-from get-wormhole-status
                  (value (cdr (assoc-equal name *wormhole-status-alist*)))))
   (read-acl2-oracle state))

(defun file-write-date$ (file state)
  (declare (xargs :guard (stringp file)
                  :stobjs state))
  #+acl2-loop-only
  (declare (ignore file))
  #+(not acl2-loop-only)
  (when (live-state-p state)
    (return-from file-write-date$
                 (mv (our-ignore-errors (file-write-date file)) state)))
  (mv-let (erp val state)
          (read-acl2-oracle state)
          (mv (and (null erp)
                   (posp val)
                   val)
              state)))

; Next: debugger control

(defun debugger-enable (state)
  (declare (xargs :guard (and (state-p state)
                              (boundp-global 'debugger-enable state))))
  (f-get-global 'debugger-enable state))

(defun break$ ()

; This function gets around a bug in Allegro CL (at least in Versions 7.0 and
; 8.0), as admitted by Franz support, and in and CMU CL.  These Lisps pay
; attention to *debugger-hook* even when (break) is invoked, but they
; shouldn't.

; Keep this in sync with break-on-error-fn.

  ":Doc-Section ACL2::ACL2-built-ins

  cause an immediate Lisp break~/

  ACL2 users are generally advised to avoid breaking into raw Lisp.  Advanced
  users may, on occasion, see the need to do so.  Evaluating ~c[(break$)] will
  have that effect.  (Exception: ~c[break$] is disabled after evaluation of
  ~c[(set-debugger-enable :never)]; ~pl[set-debugger-enable].)  ~c[Break$]
  returns ~c[nil].~/~/

  :cited-by other"

  (declare (xargs :guard t))
  #-acl2-loop-only
  (and (not (eq (debugger-enable *the-live-state*) :never))
       #+(and gcl (not cltl2))
       (break)
       #-(and gcl (not cltl2))
       (let ((*debugger-hook* nil)
             #+ccl ; useful for CCL revision 12090 and beyond
             (ccl::*break-hook* nil))
         #+ccl ; for CCL revisions before 12090
         (declare (ignorable ccl::*break-hook*))
         (break)))
  nil)

#-acl2-loop-only
(defvar *ccl-print-call-history-count*

; This variable is only used by CCL, but we define it for all Lisps so that
; this name is equally unavailable as a name for defconst in all host Lisps.

; The user is welcome to change this in raw Lisp.  Perhaps we should advertise
; it and use a state global.  We have attempted to choose a value sufficiently
; large to get well into the stack, but not so large as to swamp the system.
; Even with the default for CCL (as of mid-2013) of -Z 2M, the stack without
; this restriction could be much larger.  For example, in the ACL2 loop we
; made the definition

;   (defun foo (x) (if (atom x) nil (cons (car x) (foo (cdr x)))))

; and then ran (foo (make-list 1000000)), and after 65713 abbreviated stack
; frames CCL just hung.  But with this restriction, it took less than 6 seconds
; to evaluate the following in raw Lisp, including printing the stack to the
; terminal (presumably it would be much faster to print to a file):

;   (time$ (ignore-errors (ld '((foo (make-list 1000000))))))

  10000)

(defun print-call-history ()

; We welcome suggestions from users or Lisp-specific experts for how to improve
; this function, which is intended to give a brief but useful look at the debug
; stack.

  (declare (xargs :guard t))
  #-acl2-loop-only
  (when (global-val 'boot-strap-flg (w *the-live-state*))

; We don't know why SBCL 1.0.37 hung during guard verification of
; maybe-print-call-history during the boot-strap.  But we sidestep that issue
; here.

    (return-from print-call-history nil))
  #+(and ccl (not acl2-loop-only))
  (when (fboundp 'ccl::print-call-history)
; See CCL file lib/backtrace.lisp for more options
    (eval '(ccl::print-call-history :detailed-p nil
                                    :count *ccl-print-call-history-count*)))

; It seems awkward to deal with GCL, both because of differences in debugger
; handling and because we haven't found documentation on how to get a
; backtrace.  For example, (system::ihs-backtrace) seems to give a much smaller
; answer when it's invoked during (our-abort) than when it is invoked directly
; in the debugger.

; #+(and gcl (not acl2-loop-only))
; (when (fboundp 'system::ihs-backtrace)
;    (eval '(system::ihs-backtrace)))

  #+(and allegro (not acl2-loop-only))
  (when (fboundp 'tpl::do-command)
    (eval '(tpl:do-command "zoom"
                           :from-read-eval-print-loop nil
                           :count t :all t)))
  #+(and sbcl (not acl2-loop-only))
  (when (fboundp 'sb-debug::backtrace)
    (eval '(sb-debug::backtrace)))
  #+(and cmucl (not acl2-loop-only))
  (when (fboundp 'debug::backtrace)
    (eval '(debug::backtrace)))
  #+(and clisp (not acl2-loop-only))
  (when (fboundp 'system::print-backtrace)
    (eval '(catch 'system::debug
             (system::print-backtrace))))
  #+(and lispworks (not acl2-loop-only))
  (when (fboundp 'dbg::output-backtrace)
    (eval '(dbg::output-backtrace :verbose)))
  nil)

(defun debugger-enabledp (state)
  (declare (xargs :guard (and (state-p state)
                              (boundp-global 'debugger-enable state))))
  (let ((val (f-get-global 'debugger-enable state)))
    (and (member-eq val '(t :break :break-bt :bt-break))
         t)))

(defun maybe-print-call-history (state)
  (declare (xargs :guard (and (state-p state)
                              (boundp-global 'debugger-enable state))))
  (and (member-eq (f-get-global 'debugger-enable state)
                  '(:bt :break-bt :bt-break))
       (print-call-history)))

(defmacro with-reckless-readtable (form)

; This macro creates a context in which reading takes place without usual
; checks that #n# is only used after #n= and without the usual restrictions on
; characters (specifically, *old-character-reader* is used rather than the ACL2
; character reader, #'acl2-character-reader).  See *reckless-acl2-readtable*.

  #+acl2-loop-only
  form
  #-acl2-loop-only
  `(let ((*readtable* *reckless-acl2-readtable*)

; Since print-object$ binds *readtable* to *acl2-readtable*, we bind the latter
; here:

         (*acl2-readtable* *reckless-acl2-readtable*))
     ,form))

(defmacro set-debugger-enable (val)

; WARNING: Keep this documentation in sync with the initial setting of
; 'debugger-enable in *initial-global-table* and with our-abort.

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

  control whether Lisp errors and breaks invoke the Lisp debugger~/

  ~bv[]
  Forms (see below for explanations and GCL exceptions):

  (set-debugger-enable t)         ; enable breaks into the raw Lisp debugger
  (set-debugger-enable :break)    ; same as above
  :set-debugger-enable t          ; same as above
  (set-debugger-enable :break-bt) ; as above, but print a backtrace first
  (set-debugger-enable :bt-break) ; as above, but print a backtrace first
  (set-debugger-enable :bt)       ; print a backtrace but do not enter debugger
  (set-debugger-enable :never)    ; disable all breaks into the debugger
  (set-debugger-enable nil)       ; disable debugger except when calling break$
  ~ev[]

  ~em[Introduction.]  Suppose we define ~c[foo] in ~c[:]~ilc[program] mode to
  take the ~ilc[car] of its argument.  This can cause a raw Lisp error.  ACL2
  will then return control to its top-level loop unless you enable the Lisp
  debugger, as shown below (except: the error message can take quite a
  different form in non-ANSI GCL).

  ~bv[]
    ACL2 !>(defun foo (x) (declare (xargs :mode :program)) (car x))

    Summary
    Form:  ( DEFUN FOO ...)
    Rules: NIL
    Warnings:  None
    Time:  0.00 seconds (prove: 0.00, print: 0.00, other: 0.00)
     FOO
    ACL2 !>(foo 3)
    ***********************************************
    ************ ABORTING from raw Lisp ***********
    Error:  Attempt to take the car of 3 which is not listp.
    ***********************************************

    If you didn't cause an explicit interrupt (Control-C),
    then the root cause may be call of a :program mode
    function that has the wrong guard specified, or even no
    guard specified (i.e., an implicit guard of t).
    See :DOC guards.

    To enable breaks into the debugger (also see :DOC acl2-customization):
    (SET-DEBUGGER-ENABLE T)
    ACL2 !>(SET-DEBUGGER-ENABLE T)
    <state>
    ACL2 !>(foo 3)
    Error: Attempt to take the car of 3 which is not listp.
      [condition type: TYPE-ERROR]

    Restart actions (select using :continue):
     0: Abort entirely from this (lisp) process.
    [Current process: Initial Lisp Listener]
    [1] ACL2(1): [RAW LISP]
  ~ev[]~/

  ~em[Details.]  ACL2 usage is intended to take place inside the ACL2
  read-eval-print loop (~pl[lp]).  Indeed, in most Lisp implementations ACL2
  comes up inside that loop, as evidenced by the prompt:
  ~bv[]
  ACL2 !>
  ~ev[]
  However, one can occasionally hit a raw Lisp error.  Here is the above
  example again, this time for a GCL implementation, which unfortunately gives
  a slightly less aesthetic report.
  ~bv[]
    ACL2 !>(foo 3)

    Error: 3 is not of type LIST.
    Fast links are on: do (si::use-fast-links nil) for debugging
    Error signalled by CAR.
    Backtrace: funcall > system:top-level > lisp:lambda-closure > lp > acl2_*1*_acl2::foo > foo > car > system:universal-error-handler > system::break-level-for-acl2 > let* > UNLESS
    ACL2 !>
  ~ev[]

  Here, the user has defined ~c[foo] in ~c[:]~ilc[program] mode, with an
  implicit ~il[guard] of ~c[t].  The ACL2 evaluator therefore called the Lisp
  evaluator, which expected ~c[nil] or a ~ilc[consp] argument to ~ilc[car].

  By default, ACL2 will return to its top-level loop (at the same level of
  ~ilc[LD]) when there is a raw Lisp error, as though a call of ~ilc[ER] with
  flag ~c[HARD] has been evaluated.  If instead you want to enter the raw Lisp
  debugger in such cases, evaluate the following form.
  ~bv[]
  (set-debugger-enable t)
  ~ev[]
  You can subsequently return to the default behavior with:
  ~bv[]
  (set-debugger-enable nil)
  ~ev[]
  Either way, you can enter the Lisp debugger from within the ACL2 loop by
  evaluating ~c[(]~ilc[break$]~c[)].  If you want ~c[break$] disabled, then
  evaluate the following, which disables entry to the Lisp debugger not only
  for Lisp errors but also when executing ~c[(break$)].
  ~bv[]
  (set-debugger-enable :never)
  ~ev[]

  The discussion above also applies to interrupts (from ~c[Control-C]) in some,
  but not all, host Common Lisps.

  It remains to discuss options ~c[:break], ~c[:bt], ~c[:break-bt], and
  ~c[:bt-break].  Option ~c[:break] is synonymous with option ~c[t], while
  option ~c[:bt] prints a backtrace.  Options ~c[:break-bt] and ~c[:bt-break]
  are equivalent, and each has the combined effect of ~c[:bt] and ~c[:break]: a
  backtrace is printed and then the debugger is entered.

  Note that ~c[set-debugger-enable] applies not only to raw Lisp errors, but
  also to ACL2 errors: those affected by ~ilc[break-on-error].  However, for
  ACL2 errors, entering the debugger is controlled only by ~c[break-on-error],
  not by ~c[set-debugger-enable].  For ACL2 errors encountered after evaluating
  ~c[(break-on-error t)], the ~c[set-debugger-enable] values of ~c[:bt],
  ~c[:break-bt], and ~c[:bt-break] will result in the same effect: in many host
  LIsps, this effect will be to cause a backtrace to be printed.

  Remark for Common Lisp hackers (except for the case that the host Lisp is
  non-ANSI GCL).  You can customize the form of the backtrace printed by
  entering raw Lisp (with ~c[:q]) and then redefining function
  ~c[print-call-history], whose definition immediately precedes that of
  ~c[break-on-error] in ACL2 source file ~c[ld.lisp].  Of course, all bets are
  off when defining any function in raw Lisp, but as a practical matter you are
  probably fine as long as your books are ultimately certified with an
  unmodified copy of ACL2.  If you come up with improvements to
  ~c[print-call-history], please pass them along to the ACL2 implementors."

  `(set-debugger-enable-fn ,val state))

(defun set-debugger-enable-fn (val state)
  (declare (xargs :guard (and (state-p state)
                              (member-eq val '(t nil :never :break :bt
                                                 :break-bt :bt-break)))
                  :guard-hints (("Goal" :in-theory (enable state-p1)))))
  #+(and (not acl2-loop-only)
         (and gcl (not cltl2)))
  (when (live-state-p state)
    (setq lisp::*break-enable* (debugger-enabledp state)))
  (pprogn
   (f-put-global 'debugger-enable val state)
   (if (consp (f-get-global 'dmrp state))

; Then user invoked this function, so avoid having a later stop-dmr change the
; value of 'debugger-enable.

       (f-put-global 'dmrp t state)
     state)))

; See comment in true-listp-cadr-assoc-eq-for-open-channels-p.
(in-theory (disable true-listp-cadr-assoc-eq-for-open-channels-p))

; See comment in consp-assoc-equal.
(in-theory (disable (:type-prescription consp-assoc-equal)))

; See comment in true-list-listp-forward-to-true-listp-assoc-equal.
(in-theory (disable (:type-prescription
                     true-list-listp-forward-to-true-listp-assoc-equal)))

; The definitions that follow provide support for the experimental parallelism
; extension, ACL2(p), of ACL2.  Also see the Essay on Parallelism, Parallelism
; Warts, Parallelism Blemishes, Parallelism No-fixes, and Parallelism Hazards.

(defun add-@par-suffix (symbol)
  (declare (xargs :guard (symbolp symbol)))
  (intern (string-append (symbol-name symbol)
                         "@PAR")
          "ACL2"))

(defun generate-@par-mappings (symbols)
  (declare (xargs :guard (symbol-listp symbols)))
  (cond ((endp symbols)
         nil)
        (t (cons (cons (add-@par-suffix (car symbols))
                       (car symbols))
                 (generate-@par-mappings (cdr symbols))))))

; Parallelism blemish: consider adding a doc topic explaining that if a user
; finds the #+acl2-par version of an "@par" function to be useful, that they
; should contact the authors of ACL2.  The authors should then create a version
; of the desired "@par" function, perhaps suffixing it with "@ns" (for "no
; state").  And then the "@par" function could simply call the "@ns" version.
; A good example candidate for this is simple-translate-and-eval@par, which
; could be used inside Sol Swords's GL system to produce computed hints that
; don't modify state.

(defconst *@par-mappings*

; For each symbol SYM in the quoted list below, the #-acl2-par call below of
; define-@par-macros will automatically define a macro SYM@par that expands to
; the corresponding call of SYM.  For #+acl2-par, however, SYM@par must be
; defined explicitly.  For example, in #-acl2-par, waterfall1-lst@par is
; automatically defined to call waterfall1-lst, but in #+acl2-par we explicitly
; define waterfall1-lst@par.

; Next we consider the role played by the list below in expanding calls of the
; macro defun@par.  In #-acl2-par, there actually is no role: a call of
; defun@par simply expands to a call of defun on the same arguments, i.e.,
; defun@par is simply replaced by defun.

; Consider then the #+acl2-par case for a call (defun@par FN . rest).  This
; call expands to a progn of two defuns, which we refer to as the "parallel"
; (or "@par") and "serial" (or "non-@par") versions of (the definition on) FN.
; For the parallel version we obtain (defun FN@par . rest).  For the serial
; version we obtain (defun FN . rest'), where rest' is the result of replacing
; SYM@par by SYM in rest for each symbol SYM in the list below.  Consider for
; example the definition (defun@par waterfall-step formals body); note that we
; are still considering only the #+acl2-par case.  This call expands to a progn
; of parallel and serial versions.  The parallel version is (defun
; waterfall-step@par formals body), i.e., with no change to the body of the
; given defun@par.  The serial version is of the form (defun waterfall-step
; formals body'), where for example the call of waterfall-step1@par in body is
; replaced by a corresponding call of waterfall-step1 in body'.

; Suppose that F is a function that has both a parallel definition (defining
; F@par) and serial definition (defining F), such that F@par is called in the
; body of (defun@par G ...).  Then it is useful to include F in the list below.
; To see why, consider the #-acl2-par expansion of (defun@par G ...), which
; still has a call of F@par.  By including F in the list below, we ensure that
; F@par is automatically defined as a macro that replaces F@par by F.

; Note that this list does not contain all symbols defined with an @par
; counterpart.  For example, the symbol mutual-recursion is omitted from this
; list, and mutual-recursion@par must be defined explicitly in both #+acl2-par
; and #-acl2-par.  This works because mutual-recursion@par does not need to be
; called from inside any functions defined with defun@par.

; Also, sometimes we need to create a non-@par version of a macro that is the
; identity macro, just so that we can have an @par version that does something
; important for the parallel case inside a call of defun@par.
; Waterfall1-wrapper is an example of such a macro (and it may be the only
; example).  Since waterfall1-wrapper@par is called within functions defined
; with defun@par, waterfall1-wrapper must be included in this list, as
; explained above.

; This list is split into two groups: (1) symbols that have an explicit
; #+acl2-par definition for the parallel (@par) version, and (2) symbols for
; which defun@par is used for defining both the symbol and its @par version.
; Group (1) is further divided into (1a) utilities that are "primitive" in
; nature and (1b) higher-level functions and macros.

  (generate-@par-mappings
   '(

; Group 1a (see above):

     catch-time-limit5
     cmp-and-value-to-error-quadruple
     cmp-to-error-triple
     er
     er-let*
     er-progn
     error-fms
     error-in-parallelism-mode
     error1
     f-put-global
     io?
     io?-prove
     mv
     mv-let
     parallel-only
     pprogn
     serial-first-form-parallel-second-form
     serial-only
     sl-let
     state-mac
     value
     warning$

; Group 1b (see above):

     add-custom-keyword-hint
     eval-clause-processor
     eval-theory-expr
     formal-value-triple
     increment-timer
     simple-translate-and-eval
     translate-in-theory-hint
     waterfall-print-clause-id
     waterfall-print-clause-id-fmt1-call
     waterfall-update-gag-state
     waterfall1-lst
     waterfall1-wrapper
     xtrans-eval

; Group 2 (see above):

     accumulate-ttree-and-step-limit-into-state
     add-custom-keyword-hint-fn
     apply-override-hint
     apply-override-hint1
     apply-override-hints
     apply-reorder-hint
     apply-top-hints-clause
     check-translated-override-hint
     chk-arglist
     chk-do-not-expr-value
     chk-equal-arities
     chk-equiv-classicalp
     chk-theory-expr-value
     chk-theory-expr-value1
     chk-theory-invariant
     chk-theory-invariant1
     custom-keyword-hint-interpreter
     custom-keyword-hint-interpreter1
     eval-and-translate-hint-expression
     find-applicable-hint-settings
     find-applicable-hint-settings1
     gag-state-exiting-cl-id
     load-hint-settings-into-pspv
     load-hint-settings-into-rcnst
     load-theory-into-enabled-structure
     maybe-warn-about-theory
     maybe-warn-about-theory-from-rcnsts
     maybe-warn-about-theory-simple
     maybe-warn-for-use-hint
     pair-cl-id-with-hint-setting
     process-backtrack-hint
     push-clause
     put-cl-id-of-custom-keyword-hint-in-computed-hint-form
     record-gag-state
     thanks-for-the-hint
     translate
     translate1
     translate-backchain-limit-rw-hint
     translate-backtrack-hint
     translate-bdd-hint
     translate-bdd-hint1
     translate-by-hint
     translate-case-split-limitations-hint
     translate-cases-hint
     translate-clause-processor-hint
     translate-custom-keyword-hint
     translate-do-not-hint
     translate-do-not-induct-hint
     translate-error-hint
     translate-expand-hint
     translate-expand-hint1
     translate-expand-term
     translate-expand-term1
     translate-functional-substitution
     translate-hands-off-hint
     translate-hands-off-hint1
     translate-hint
     translate-hints
     translate-hints1
     translate-hints2
     translate-hints+1
     translate-hint-expression
     translate-hint-expressions
     translate-hint-settings
     translate-induct-hint
     translate-lmi
     translate-lmi/functional-instance
     translate-lmi/instance
     translate-no-op-hint
     translate-no-thanks-hint
     translate-nonlinearp-hint
     translate-or-hint
     translate-reorder-hint
     translate-restrict-hint
     translate-rw-cache-state-hint
     translate-simple-or-error-triple
     translate-substitution
     translate-substitution-lst
     translate-term-lst
     translate-use-hint
     translate-use-hint1
     translate-x-hint-value
     warn-on-duplicate-hint-goal-specs
     waterfall-msg
     waterfall-print-clause
     waterfall-step
     waterfall-step1
     waterfall-step-cleanup
     waterfall0
     waterfall0-or-hit
     waterfall0-with-hint-settings
     waterfall1)))

(defun make-identity-for-@par-mappings (mappings)

; Although this is only used for #-acl2-par, we define it unconditionally so
; that its rune is available in both ACL2 and ACL2(p).  Robert Krug used
; arithmetic-5, which employs deftheory-static, and hence was bitten when this
; rune was missing.

  (declare (xargs :guard (alistp mappings)))
  (cond ((endp mappings) nil)
        (t (cons `(defmacro ,(caar mappings) (&rest rst)
                    (cons ',(cdar mappings) rst))
                 (make-identity-for-@par-mappings (cdr mappings))))))

#-acl2-par
(defmacro define-@par-macros ()

; This macro defines the #-acl2-par version of the @par functions and macros.

  `(progn ,@(make-identity-for-@par-mappings *@par-mappings*)))

#-acl2-par
(define-@par-macros)

; To find places where we issue definitions both without the "@par" suffix and
; with the "@par" suffix, one can run the following.  (For example, there might
; be a defun@par of foo, but there might instead be both a defun of foo and a
; defun of foo@par.  The first line below can catch either of these.)

; grep "@par" *.lisp | grep "defun "
; grep "@par" *.lisp | grep "defmacro "

(defun replace-defun@par-with-defun (forms)
  (declare (xargs :guard (alistp forms)))
  (cond ((endp forms)
         nil)
        ((eq (caar forms) 'defun@par)
         (cons (cons 'defun (cdar forms))
               (replace-defun@par-with-defun (cdr forms))))
        (t (cons (car forms)
                 (replace-defun@par-with-defun (cdr forms))))))

#-acl2-par
(defmacro mutual-recursion@par (&rest forms)
  `(mutual-recursion ,@(replace-defun@par-with-defun forms)))

#+acl2-par
(defun defun@par-fn (name parallel-version rst)
  (declare (xargs :guard (and (symbolp name)
                              (booleanp parallel-version)
                              (true-listp rst))))
  (let ((serial-function-symbol
         (intern (symbol-name name)
                 "ACL2"))
        (parallel-function-symbol
         (intern (string-append (symbol-name name)
                                "@PAR")
                 "ACL2"))
        (serial-definition-args (sublis *@par-mappings* rst))
        (parallel-definition-args rst))
    (if parallel-version
        `(defun ,parallel-function-symbol
           ,@parallel-definition-args)
      `(defun ,serial-function-symbol
         ,@serial-definition-args))))

#+acl2-par
(defun mutual-recursion@par-guardp (rst)
  (declare (xargs :guard t))
  (cond ((atom rst) (equal rst nil))
        (t (and (consp (car rst))
                (true-listp (car rst))
                (true-listp (caddr (car rst))) ; formals
                (symbolp (cadar rst))
                (member-eq (car (car rst)) '(defun defund defun-nx defund-nx
                                              defun@par))
                (mutual-recursion@par-guardp (cdr rst))))))

#+acl2-par
(defun mutual-recursion@par-fn (forms serial-and-par)
  (declare (xargs :guard (and (mutual-recursion@par-guardp forms)
                              (booleanp serial-and-par))))
  (cond ((endp forms)
         nil)
        ((equal (caar forms) 'defun@par)
         (let* ((curr (car forms))
                (name (cadr curr))
                (rst (cddr curr)))
           (cond (serial-and-par
                  (cons (defun@par-fn name t rst)
                        (cons (defun@par-fn name nil rst)
                              (mutual-recursion@par-fn (cdr forms)
                                                       serial-and-par))))
                 (t
                  (cons (defun@par-fn name nil rst)
                        (mutual-recursion@par-fn (cdr forms)
                                                 serial-and-par))))))
        (t (cons (car forms)
                 (mutual-recursion@par-fn (cdr forms) serial-and-par)))))

#+acl2-par
(defmacro mutual-recursion@par (&rest forms)
  (declare (xargs :guard (mutual-recursion@par-guardp forms)))
  `(mutual-recursion ,@(mutual-recursion@par-fn forms t)))

(defmacro defun@par (name &rest args)

; See *@par-mappings* for a discussion of this macro.  In brief: for
; #-acl2-par, defun@par is just defun.  But for #+acl2-par, defun@par defines
; two functions, a "parallel" and a "serial" version.  The serial version
; defines the given symbol, but the parallel version defines a corresponding
; symbol with suffix "@PAR".

  #+acl2-par
  `(progn ,(defun@par-fn name t args)
          ,(defun@par-fn name nil args))
  #-acl2-par
  `(defun ,name ,@args))

(defmacro serial-first-form-parallel-second-form (x y)

; Keep in sync with serial-first-form-parallel-second-form@par.

  (declare (ignore y))
  x)

#+acl2-par
(defmacro serial-first-form-parallel-second-form@par (x y)

; Keep in sync with serial-first-form-parallel-second-form.

  (declare (ignore x))
  y)

(defmacro serial-only (x)

; Keep in sync with serial-only@par.

  x)

#+acl2-par
(defmacro serial-only@par (x)

; Keep in sync with serial-only.

  (declare (ignore x))
  nil)

(defmacro parallel-only (x)

; Keep in sync with parallel-only@par.

  (declare (ignore x))
  nil)

#+acl2-par
(defmacro parallel-only@par (x)

; Keep in sync with parallel-only.

  x)

#+acl2-par
(defmacro mv@par (&rest rst)
  (declare (xargs :guard ; sanity check
                  (member-eq 'state rst)))
  `(mv? ,@(remove1-eq 'state rst)))

#+acl2-par
(defmacro value@par (val)

; Keep in sync with value.

  `(mv nil ,val))

(defmacro state-mac ()

; Keep in sync with state-mac@par.

  'state)

#+acl2-par
(defmacro state-mac@par ()

; Keep in sync with state-mac.

  nil)

#+acl2-par
(defmacro mv-let@par (vars call &rest rst)
  (declare (xargs :guard ; sanity check
                  (member-eq 'state vars)))
  `(mv?-let ,(remove1-eq 'state vars) ,call ,@rst))

#+acl2-par
(defmacro warning$@par (&rest rst)

; We do not simply just call warning$-cw, because we actually have state
; available when we use warning$@par.

  `(let ((state-vars (default-state-vars t))
         (wrld (w state)))
     (warning$-cw1 ,@rst)))

(defmacro error-in-parallelism-mode (fake-return-value form)
  (declare (ignore fake-return-value))
  form)

#+acl2-par
(defmacro error-in-parallelism-mode@par (return-value form)

; We avoid even trying to evaluate form, instead returning a hard error with a
; useful message.  Return-value must have the same output signature as that of
; form.

; Any form enwrapped with error-in-parallelism-mode@par is essentially
; disabled.  To restore the code to its original form, just remove the wrapper
; error-in-parallelism-mode@par.

  `(prog2$
    (er hard 'error-in-parallelism-mode@par
        "There has been an attempt to evaluate a form that is disallowed in ~
         the parallelized evaluation of the waterfall.  See :doc ~
         set-waterfall-parallelism for how to disable such parallel ~
         evaluation.  Please let the ACL2 authors know if you see this ~
         message, as our intent is that its occurence should be rare.  The ~
         offending form is: ~x0"
        ',form)
    ,return-value))

#+acl2-par
(defun increment-timer@par (name state)
  (declare (xargs :guard t)
           (ignore name state))
  (state-mac@par))

; These constants are needed both in parallel.lisp and boot-strap-pass-2.lisp,
; so we define them here.

(defconst *waterfall-printing-values*
  '(:full :limited :very-limited))

(defconst *waterfall-parallelism-values*
  '(nil t :full :top-level :resource-based :resource-and-timing-based
        :pseudo-parallel))

; This is needed in both boot-strap-pass-2.lisp and parallel.lisp, so we put it
; here.

(defun symbol-constant-fn (prefix sym)
  (declare (xargs :guard (and (symbolp prefix)
                              (symbolp sym))))
  (intern (concatenate 'string
                       (symbol-name prefix)
                       "-"
                       (symbol-name sym))
          "ACL2"))

; Oracle-funcall, oracle-apply, and oracle-apply-ttag:

(defun stobjs-in (fn w)

; Fn must be a function symbol, not a lambda expression and not an
; undefined symbol.  See the Essay on STOBJS-IN and STOBJS-OUT.

  (declare (xargs :guard (and (symbolp fn)
                              (plist-worldp w))))
  (if (eq fn 'cons)

; We call this function on cons so often we optimize it.

      '(nil nil)

    (getprop fn 'stobjs-in nil 'current-acl2-world w)))

(defmacro oracle-funcall (fn &rest args)

  ":Doc-Section ACL2::ACL2-built-ins

  call a function argument on the remaining arguments~/

  ~c[Oracle-funcall] evaluates its first argument to produce an ACL2 function
  symbol, and then applies that function symbol to the values of the rest of
  the arguments.  The return value is of the form ~c[(mv call-result state)].

  ~bv[]
  Examples:
  (oracle-funcall 'cons 3 4) ==> (mv '(3 . 4) <state>)
  (oracle-funcall (car '(floor foo bar)) (+ 6 7) 5) ==> (mv 2 <state>)
  ~ev[]

  ~c[Oracle-funcall] is a macro; each of its calls macroexpands to a call of
  the related utility ~c[oracle-apply] that takes the ACL2 ~ilc[state] as an
  argument, as follows:
  ~bv[]
  (oracle-funcall fn x1 x2 .. xk)
  ~ev[]
  macroexpands to
  ~bv[]
  (oracle-apply fn (list x1 x2 .. xk) state)
  ~ev[]

  Note that calls of ~c[oracle-funcall] and ~c[oracle-apply] return two values:
  the result of the function application, and a modified ~ilc[state].

  ~l[oracle-apply] for details, including information about ~il[guard]s.~/~/"

  `(oracle-apply ,fn (list ,@args) state))

(defun all-nils (lst)
  (declare (xargs :guard (true-listp lst)))
  (cond ((endp lst) t)
        (t (and (eq (car lst) nil)
                (all-nils (cdr lst))))))

(defun oracle-apply-guard (fn args state)
  (declare (xargs :stobjs state))
  (and (symbolp fn)
       (not (eq fn 'return-last))
       (true-listp args)
       (let* ((wrld (w state))
              (formals (getprop fn 'formals t 'current-acl2-world wrld))
              (stobjs-in (stobjs-in fn wrld)))
         (and (not (eq formals t))
              (eql (len formals) (len args))
              (true-listp stobjs-in) ; needed for guard of all-nils
              (all-nils stobjs-in)))))

(defun oracle-apply (fn args state)

; The use of an oracle is important for the logical story.  For example, we can
; imagine the following sort of situation without an oracle.

;   (encapsulate
;    ()
;    (local (defun f (x)
;             1))
;    (defthm prop-1
;      (equal (oracle-funcall 'f) 1)
;      :rule-classes nil))
;
;   (encapsulate
;    ()
;    (local (defun f ()
;             2))
;    (defthm prop-2
;      (equal (oracle-funcall 'f) 2)
;      :rule-classes nil))
;
;   (defthm contradiction
;     nil
;     :hints (("Goal" :use (prop-1 prop-2))))

  ":Doc-Section ACL2::ACL2-built-ins

  call a function argument on the given list of arguments~/

  ~c[Oracle-apply] evaluates its first argument to produce an ACL2 function
  symbol, ~c[FN], and then applies ~c[FN] to the value of the second argument,
  which should be a true list whose length is the number of inputs for ~c[FN].
  The return value is of the form ~c[(mv call-result state)].

  ~bv[]
  Examples:
  (oracle-apply 'cons '(3 4) state) = (mv '(3 . 4) <state>)
  (oracle-apply (car '(floor foo)) (list (+ 6 7) 5) state) = (mv 2 <state>)
  ~ev[]

  Also ~pl[oracle-funcall] for a related utility.

  Note that calls of ~c[oracle-funcall] and ~c[oracle-apply] return two values:
  the result of the function application, and a modified ~ilc[state].

  ~c[Oracle-apply] is defined in ~c[:]~ilc[logic] mode, and in fact is
  ~il[guard]-verified.  However, you will not be able to prove much about this
  function, because it is defined in the logic using the ~c[acl2-oracle] field
  of the ACL2 ~il[state].  The behavior described above ~-[] i.e., making a
  function call ~-[] takes place when the third argument is the ACL2
  ~ilc[state], so during proofs (when that can never happen), a term
  ~c[(oracle-apply 'fn '...)] will not simplify using a call of ~c[fn].

  The guard for ~c[(oracle-apply fn args state)] is the term
  ~c[(oracle-apply-guard fn args state)], which says the following: ~c[fn] and
  ~c[args] must satisfy ~ilc[symbolp] and ~ilc[true-listp], respectively;
  ~c[fn] must be a known function symbol other than ~ilc[return-last] that is
  not untouchable (~pl[push-untouchable]) and has no ~il[stobj] arguments (not
  even ~ilc[state]); and the ~il[length] of ~c[args] must equal the arity of
  ~c[fn] (~pl[signature]).  The requirement that ~c[fn] be a known function
  symbol may be a bit onerous for guard verification, but this is easily
  overcome by using ec-call, for example as follows.
  ~bv[]
  (defun f (x state)
    (declare (xargs :stobjs state))
    (ec-call (oracle-apply 'car (list x) state)))
  ~ev[]
  This use of ~ilc[ec-call] will, however, cause the ~il[guard] of
  ~c[oracle-apply] to be checked at runtime.

  If the ~il[guard] for ~c[oracle-apply] fails to hold but there is no guard
  violation because guard-checking is suppressed (~pl[set-guard-checking]),
  then the value returned is computed using its logical definition ~-[] which,
  as mentioned above, uses the ACL2 oracle ~-[] and hence the value computed is
  unpredictable (indeed, the function argument will not actually be called).

  The value returned by ~c[oracle-apply] is always a single value obtained by
  calling the executable counterpart of its function argument, as we now
  explain.  Consider a form ~c[(oracle-apply fn args state)] that evaluates to
  ~c[(mv VAL state')], where ~c[fn] evaluates to the function symbol ~c[F].  If
  ~c[F] returns multiple values, then ~c[VAL] is the first value computed by
  the call of ~c[F] on the value of ~c[args].  More precisely, ~c[oracle-apply]
  actually invokes the executable counterpart of ~c[F]; thus, if ~c[args] is
  the expression ~c[(list x1 ... xk)], then ~c[VAL] is the same as (first)
  value returned by evaluating ~c[(ec-call (F x1 x2 ... xk))].  ~l[ec-call].

  (Remark.  If you identify a need for a version of ~c[oracle-apply] to return
  multiple values, we can perhaps provide such a utility; feel free to contact
  the ACL2 implementors to request it.)

  A subtlety is that the evaluation takes place in so-called ``safe mode'',
  which avoids raw Lisp errors due to calls of ~c[:]~ilc[program] mode
  functions.  The use of safe mode is unlikely to be noticed if the value of
  the first argument of ~c[oracle-apply] is a ~c[:]~ilc[logic] mode function
  symbol.  However, for ~c[:program] mode functions with side effects due to
  special raw Lisp code, as may be the case for built-in functions or for
  custom functions defined with active trust tags (~pl[defttag]), use of the
  following function may be preferable:

  ~l[oracle-apply-raw] for a much less restrictive version of ~c[oracle-apply],
  which avoids safe mode and (for example) can apply a function that has a
  definition in the host Lisp but not in the ACL2 ~il[world].~/~/"

  (declare (xargs :stobjs state
                  :guard (oracle-apply-guard fn args state)))
  #-acl2-loop-only
  (when (live-state-p state)
    (return-from oracle-apply
                 (mv (state-free-global-let* ((safe-mode t))
                                             (apply (*1*-symbol fn) args))
                     state)))
  #+acl2-loop-only
  (mv-let (erp val state)
          (read-acl2-oracle state)
          (declare (ignore erp))

; We arrange for the result to depend logically on fn and args.  This is
; probably not important to do, but it seems potentially weird for the result
; ot have nothing to do with fn or with args.

          (mv (and (true-listp val)
                   (eq (car val) fn)
                   (equal (cadr val) args)
                   (caddr val))
              state)))

(defun oracle-apply-raw (fn args state)

  ":Doc-Section ACL2::ACL2-built-ins

  call a function argument on the given list of arguments, no restrictions~/

  ~l[oracle-apply], as we assume familiarity with that function.
  ~c[Oracle-apply-raw] is a variant of ~c[oracle-apply] that is untouchable,
  and hence requires a trust tag to remove the untouchability (~pl[defttag] and
  ~pl[remove-untouchable]).  Unlike ~c[oracle-apply], ~c[oracle-apply-raw]
  simply calls the raw Lisp function ~c[funcall] to compute the result, without
  restriction: the specified ~c[:]~ilc[guard] is ~c[t], the function itself is
  applied (not its executable counterpart), there is no restriction for
  untouchable functions or ~ilc[return-last], and safe mode is not used.  Thus,
  in general, ~c[oracle-apply-raw] can be dangerous to use: any manner of error
  can occur!

  As is the case for ~ilc[oracle-apply], the function symbol
  ~ilc[oracle-apply-raw] is defined in ~c[:]~ilc[logic] mode and is
  ~il[guard]-verified.  ~c[Oracle-apply-raw] is logically defined to be
  ~ilc[oracle-apply]; more precisely:
  ~bv[]
  (oracle-apply-raw fn args state)
  = {logical definition}
  (ec-call (oracle-apply fn args state))
  ~ev[]~/~/"

  (declare (xargs :stobjs state :guard t))
  #-acl2-loop-only
  (when (live-state-p state)
    (return-from oracle-apply-raw
                 (mv (funcall fn args) state)))
  #+acl2-loop-only
  (ec-call (oracle-apply fn args state)))

(defun time-tracker-fn (tag kwd kwdp times interval min-time msg)

; Do not conditionalize this function on #-acl2-par, even though its only
; intended use is on behalf of the #-acl2-par definition of time-tracker,
; because otherwise theories computed for ACL2 and ACL2(p) may differ, for
; example when including community books under arithmetic-5/.

  (declare (xargs :guard t))
  (cond
   ((and (booleanp tag) kwdp)
    (er hard? 'time-tracker
        "It is illegal to call ~x0 with a Boolean tag and more than one ~
         argument.  See :DOC time-tracker."
        'time-tracker))
   ((booleanp tag)
    #-acl2-loop-only
    (setf (symbol-value '*time-tracker-disabled-p*) ; setq gives compiler warning
          (not tag))
    nil)
   #-acl2-loop-only
   ((symbol-value '*time-tracker-disabled-p*)
    nil)
   ((not (symbolp tag))
    (er hard? 'time-tracker
        "Illegal first argument for ~x0 (should be a symbol): ~x1.  See :DOC ~
         time-tracker."
        'time-tracker))
   ((and (not (booleanp tag))
         (not (member-eq kwd
                         '(:init :end :print? :stop :start))))
    (er hard? 'time-tracker
        "Illegal second argument for ~x0: ~x1.  See :DOC time-tracker."
        'time-tracker
        kwd))
   ((or (and times
             (not (eq kwd :init)))
        (and interval
             (not (eq kwd :init)))
        (and min-time
             (not (eq kwd :print?)))
        (and msg
             (not (or (eq kwd :init)
                      (eq kwd :print?)))))
    (er hard? 'time-tracker
        "Illegal call of ~x0: a non-nil keyword argument of ~x1 is illegal ~
         for a second argument of ~x2.  See :DOC time-tracker."
        'time-tracker
        (cond ((and times
                    (not (eq kwd :init)))
               :times)
              ((and interval
                    (not (eq kwd :init)))
               :interval)
              ((and min-time
                    (not (eq kwd :print?)))
               :min-time)
              (t
               :msg))
        kwd))
   (t #-acl2-loop-only
      (case kwd
        (:init   (tt-init tag times interval msg))
        (:end    (tt-end tag))
        (:print? (tt-print? tag min-time msg))
        (:stop   (tt-stop tag))
        (:start  (tt-start tag)))
      nil)))

#-acl2-par
(defmacro time-tracker (tag &optional (kwd 'nil kwdp)
                            &key times interval min-time msg)
  `(time-tracker-fn ,tag ,kwd ,kwdp ,times ,interval ,min-time ,msg))

#+acl2-par
(defmacro time-tracker (&rest args)
  (declare (ignore args))
  nil)

(defdoc time-tracker

; This documentation is separated from the defmacro for time-tracker because
; that defmacro has two definitions, one for #-acl2-par and one for
; #+acl2-par.  We need this :doc topic present in both kinds of builds, because
; of the :cite of it in :doc trace.

  ":Doc-Section programming

  display time spent during specified evaluation~/

  The ~c[time-tracker] macro is a utility for displaying time spent during
  specified evaluation.  In general, the user provides this specification.
  However, ACL2 itself uses this utility for tracking uses of its
  ~il[tau-system] reasoning utility (~pl[time-tracker-tau]).  We discuss that
  use as an example before discussing the general form for calls of
  ~c[time-tracker].

  Note that by default, the time being tracked is runtime (cpu time); to switch
  to realtime (elapsed time), ~pl[get-internal-time].

  Remark for ACL2(p) users (~pl[parallelism]): ~c[time-tracker] is merely a
  no-op in ACL2(p).

  During the development of the ~il[tau-system], we were concerned about the
  possibility that it would slow down proofs without any indication of how one
  might avoid the problem.  We wanted a utility that would alert the user in
  such situations.  However, the tau-system code does not return ~il[state], so
  we could not track time spent in the state.  We developed the
  ~c[time-tracker] utility to track time and print messages, and we did it in a
  general way so that others can use it in their own code.  Here is an example
  of such a message that could be printed during a proof.
  ~bv[]
  TIME-TRACKER-NOTE [:TAU]: Elapsed runtime in tau is 2.58 secs; see
  :DOC time-tracker-tau.
  ~ev[]
  And here is an example of such a message that could be printed at the end of
  the proof.
  ~bv[]
  TIME-TRACKER-NOTE [:TAU]: For the proof above, the total time spent
  in the tau system was 20.29 seconds.  See :DOC time-tracker-tau.
  ~ev[]

  The ~c[time-tracker] utility tracks computation time spent on behalf of a
  user-specified ``tag''.  In the case of the tau-system, we chose the tag,
  ~c[:tau].  The first argument of ~c[time-tracker] is the tag, which in our
  running example is always ~c[:tau].  Note that although all arguments of
  ~c[time-tracker] are evaluated, the first argument is typically a keyword and
  the second is always a keyword, and such arguments evaluate to themselves.

  An ACL2 function invoked at the start of a proof includes approximately the
  following code.
  ~bv[]
  (progn$
   (time-tracker :tau :end)
   (time-tracker :tau :init
                 :times '(1 2 3 4 5)
                 :interval 5
                 :msg \"Elapsed runtime in tau is ~~st secs; see :DOC ~~
                       time-tracker-tau.~~|~~%\")
   ...)
  ~ev[]

  The first ~c[time-tracker] call (above) ends any existing time-tracking for
  tag ~c[:tau].  One might have expected it be put into code managing the proof
  summary, but we decided not to rely on that code being executed, say, in case
  of an interrupt.  When a given tag is not already being time-tracked, then
  ~c[:end] is a no-op (rather than an error).

  The second ~c[time-tracker] call (above) initiates time-tracking for the tag,
  ~c[:tau].  Moreover, it specifies the effect of the ~c[:print?] keyword.
  Consider the following abbreviated definition from the ACL2 source code.
  ~bv[]
  (defun tau-clausep-lst-rec (clauses ens wrld ans ttree state calist)
    (cond
     ((endp clauses)
      (mv (revappend ans nil) ttree calist))
     (t (mv-let
         (flg1 ttree1 calist)
         (tau-clausep (car clauses) ens wrld state calist)
         (prog2$ (time-tracker :tau :print?)
                 (tau-clausep-lst-rec (cdr clauses) ...))))))
  ~ev[]
  Notice that ~c[(time-tracker :tau :print?)] is executed immediately after
  ~c[tau-clausep] is called.  The idea is to check whether the total time
  elapsed inside the tau-system justifies printing a message to the user.  The
  specification of ~c[:times '(1 2 3 4 5)] in the ~c[:init] form above says
  that a message should be printed after 1 second, after 2 seconds, ..., and
  after 5 seconds.  Thereafter, the specification of ~c[:interval 5] in the
  ~c[:init] form above says that each time we print, at least 5 additional
  seconds should have been tracked before ~c[(time-tracker :tau :print?)]
  prints again.  Finally, the ~c[:msg] keyword above specifies just what should
  be printed.  If it is omitted, then a reasonable default message is
  printed (as discussed below), but in this case we wanted to print a custom
  message.  The ~c[:msg] string above is what is printed using formatted
  printing (~pl[fmt]), where the character ~c[#\\t] is bound to a string giving
  a decimal representation with two decimal points of the time tracked so far
  for tag ~c[:tau].  (As our general description below points out, ~c[:msg] can
  also be a ``message'' list rather than a string.)

  But when is time actually tracked for ~c[:tau]?  Consider the following
  definition from the ACL2 source code.
  ~bv[]
  (defun tau-clausep-lst (clauses ens wrld ans ttree state calist)
    (prog2$ (time-tracker :tau :start)
            (mv-let
             (clauses ttree calist)
             (tau-clausep-lst-rec clauses ens wrld ans ttree state calist)
             (prog2$ (time-tracker :tau :stop)
                     (mv clauses ttree calist)))))
  ~ev[]
  The two calls of ~c[time-tracker] above first start, and then stop,
  time-tracking for the tag, ~c[:tau].  Thus, time is tracked during evaluation
  of the call of ~c[tau-clausep-lst-rec], which is the function (discussed above)
  that does the ~il[tau-system]'s work.

  Finally, as noted earlier above, ACL2 may print a time-tracking message for
  tag ~c[:tau] at the end of a proof.  The ACL2 function ~c[print-summary]
  contains essentially the following code.
  ~bv[]
  (time-tracker :tau :print?
                :min-time 1
                :msg \"For the proof above, the total runtime ~~
                      spent in the tau system was ~~st seconds.  ~~
                      See :DOC time-tracker-tau.~~|~~%\")
  ~ev[]
  The use of ~c[:min-time] says that we are to ignore the ~c[:times] and
  ~c[:interval] established by the ~c[:init] call described above, and instead,
  print a message if and only if at least 1 second (since 1 is the value of
  keyword ~c[:min-time]) has been tracked for tag ~c[:tau].  Formatted printing
  (~pl[fmt]) is used for the value of ~c[:msg], where the character ~c[#\\t] is
  bound to a decimal string representation of the time in seconds, as described
  above.

  The example above covers all legal values for the second argument of
  ~c[time-tracker] and discusses all the additional legal keyword arguments.
  We conclude with a precise discussion of all arguments.  Note that all
  arguments are evaluated; thus when we refer to an argument, we are discussing
  the value of that argument.  All times discussed are runtimes, i.e., cpu
  times, unless that default is changed; ~pl[get-internal-time].

  ~bv[]
  General forms:

  (time-tracker t)        ; enable time-tracking (default)

  (time-tracker nil)      ; disable time-tracking

  (time-tracker tag       ; a symbol other than t or nil
                option    ; :init, :end, :start, :stop, or :print?
                ;; keyword arguments:
                :times    ; non-nil if and only if option is :init
                :interval ; may only be non-nil with :init option
                :min-time ; may only be non-nil with :print? option
                :msg      ; may only be non-nil with :init and :print? options
  ~ev[]

  Time-tracking is enabled by default.  If the first argument is ~c[t] or
  ~c[nil], then no other arguments are permitted and time-tracking is enabled
  or disabled, respectively.  When time-tracking is disabled, nothing below
  takes place.  Thus we assume time-tracking is enabled for the remainder of
  this discussion.  We also assume below that the first argument is neither
  ~c[t] nor ~c[nil].

  We introduce some basic notions about time-tracking.  A given tag, such as
  ~c[:tau] in the example above, might or might not currently be ``tracked'':
  ~c[:init] causes the specified tag to be tracked, while ~c[:end] causes the
  specified tag not to be tracked.  If the tag is being tracked, the tag might
  or might not be ``active'': ~c[:start] causes the tag to be in an active
  state, whie ~c[:stop] causes the tag not to be active.  Note that only
  tracked tags can be in an active or inactive state.  For a tag that is being
  tracked, the ``accumulated time'' is the total time spent in an active state
  since the time that the tag most recently started being tracked, and the
  ``checkpoint list'' is a non-empty list of rational numbers specifying when
  printing may take place, as described below.

  We now consider each legal value for the second argument, or ``option'', for
  a call of ~c[time-tracker] on a given tag.

  ~c[:Init] specifies that the tag is to be tracked.  It also establishes
  defaults for the operation of ~c[:print?], as described below, using the
  ~c[:times], ~c[:interval], and ~c[:msg] keywords.  Of these three, only
  ~c[:times] is required, and its value must be a non-empty list of rational
  numbers specifying the initial checkpoint list for the tag.  It is an error
  to specify ~c[:init] if the tag is already being tracked.  (So if you don't
  care whether or not the tag is already being tracked and you want to initiate
  tracking for that tag, use ~c[:end] first.)

  ~c[:End] specifies that if the tag is being tracked, then it should nstop
  being tracked.  If the tag is not being tracked, then ~c[:end] has no effect.

  ~c[:Start] specifies that the tag is to be active.  It is an error to specify
  ~c[:start] if the tag is not being tracked or is already active.

  ~c[:Stop] specifies that the tag is to stop being active.  It is an error to
  specify ~c[:stop] if the tag is not being tracked or is not active.

  ~c[:Print?] specifies that if the tag is being tracked (not necessarily
  active), then a message should be printed if a suitable condition is met.
  The nature of that message and that condition depend on the keyword options
  supplied with ~c[:print?] as well as those supplied with the ~c[:init] option
  that most recently initiated tracking.  ~c[:Print?] has no effect if the tag
  is not being tracked, except that if certain keyword values are checked if
  supplied with ~c[:print?]: ~c[:min-time] must be a rational number or
  ~c[nil], and ~c[:msg] must be either a string, a true-list whose ~c[car] is a
  string, or ~c[nil].  The remainder of this documentation describes the
  ~c[:print?] option in detail under the assumption that the tag is being
  tracked: first, giving the conditions under which it causes a message to be
  printed, and second, explaining what is printed.

  When ~c[:print?] is supplied a non-~c[nil] value of ~c[:min-time], that value
  must be a rational number, in which case a message is printed if the
  accumulated time for the tag is at least that value.  Otherwise a message is
  printed if the accumulated time is greater than or equal to the ~c[car] of
  the checkpoint list for the tag.  In that case, the tracking state for the
  tag is updated in the following two ways.  First, the checkpoint list is
  scanned from the front and as long as the accumulated time is greater than or
  equal to the ~c[car] of the remaining checkpoint list, that ~c[car] is popped
  off the checkpoint list.  Second, if the checkpoint list has been completely
  emptied and a non-~c[nil] ~c[:interval] was supplied when tracking was most
  recently initiated with the ~c[:init] option, then the checkpoint list is set
  to contain a single element, namely the sum of the accumulated time with that
  value of ~c[:interval].

  Finally, suppose the above criteria are met, so that ~c[:print?] results in
  printing of a message.  We describe below the message, ~c[msg], that is
  printed.  Here is how it is printed (~pl[fmt]), where
  ~c[seconds-as-decimal-string] is a string denoting the number of seconds of
  accumulated time for the tag, with two digits after the decimal point.
  ~bv[]
  (fms \"TIME-TRACKER-NOTE [~~x0]: ~~@1~~|\"
       (list (cons #\0 tag)
             (cons #\1 msg)
             (cons #\t seconds-as-decimal-string))
       (proofs-co state) state nil)
  ~ev[]
  The value of ~c[msg] is the value of the ~c[:msg] keyword supplied with
  ~c[:print?], if non-~c[nil]; else, the value of ~c[:msg] supplied when most
  recently initialization with the ~c[:init] option, if non-~c[nil]; and
  otherwise, the string ~c[\"~~st s\"] (the final ``s'' abbreviating the word
  ``seconds'').  It is convenient to supply ~c[:msg] as a call
  ~c[(msg str arg-0 arg-1 ... arg-k)], where ~c[str] is a string and each
  ~c[arg-i] is the value to be associated with ~c[#\\i] upon formatted
  printing (as with ~ilc[fmt]) of the string ~c[str].~/~/")

(defdoc time-tracker-tau

  ":Doc-Section miscellaneous

  messages about expensive use of the ~il[tau-system]~/

  This ~il[documentation] topic explains messages printing by the theorem
  prover about the ~il[tau-system], as follows.

  During a proof you may see a message such as the following.
  ~bv[]
  TIME-TRACKER-NOTE [:TAU]: Elapsed runtime in tau is 4.95 secs; see
  :DOC time-tracker-tau.
  ~ev[]

  Just below a proof summary you may see a message such as the following.

  ~bv[]
  TIME-TRACKER-NOTE [:TAU]: For the proof above, the total runtime spent
  in the tau system was 30.01 seconds.  See :DOC time-tracker-tau.
  ~ev[]

  Both of these messages are intended to let you know that certain prover
  heuristics (~pl[tau-system]) may be slowing proofs down more than they are
  helping.  If you are satisfied with the prover's performance, you may ignore
  these messages or even turn them off by disabling time-tracking
  entirely (~pl[time-tracker]).  Otherwise, here are some actions that you can
  take to solve such a performance problem.

  The simplest solution is to disable the tau-system, in either of the
  following equivalent ways.
  ~bv[]
  (in-theory (disable (:executable-counterpart tau-system)))
  (in-theory (disable (tau-system)))
  ~ev[]

  But if you want to leave the tau-system enabled, you could investigate the
  possibility is that the tau-system is causing an expensive
  ~c[:]~ilc[logic]-mode function to be executed.  You can diagnose that problem
  by observing the rewriter ~-[] ~pl[dmr] ~-[] or by interrupting the system
  and getting a backtrace (~pl[set-debugger-enable]).  A solution in that case
  is to disable the executable-counterpart of that function, for example in
  either of these equivalent ways.
  ~bv[]
  (in-theory (disable (:executable-counterpart foo)))
  (in-theory (disable (foo)))
  ~ev[]
  As a result, the tau-system will be weakened, but perhaps only negligibly.

  In either case above, you may prefer to provide ~c[:]~ilc[in-theory] hints
  rather than ~c[:in-theory] ~il[events]; ~pl[hints].

  A more sophisticated solution is to record values of the
  ~c[:]~ilc[logic]-mode function in question, so that the tau-system will look
  up the necessary values rather than calling the function, whether or not the
  executable-counterpart of that function is enabled.  Here is an example of a
  lemma that can provide such a solution.  ~l[tau-system].
  ~bv[]
  (defthm lemma
    (and (foo 0)
         (foo 17)
         (foo t)
         (not (foo '(a b c))))
    :rule-classes :tau-system)
  ~ev[]~/~/")

#-acl2-loop-only
(defg *inside-absstobj-update* #(0))

(defun set-absstobj-debug-fn (val always)
  (declare (xargs :guard t))
  #+acl2-loop-only
  (declare (ignore always))
  #-acl2-loop-only
  (let ((temp (svref *inside-absstobj-update* 0)))
    (cond ((or (null temp)
               (eql temp 0)
               (and always
                    (or (ttag (w *the-live-state*))
                        (er hard 'set-absstobj-debug
                            "It is illegal to supply a non-nil value for ~
                             keyword :always, for set-absstobj-debug, unless ~
                             there is an active trust tag."))))
           (setf (aref *inside-absstobj-update* 0)
                 (cond ((eq val :reset)
                        (if (natp temp) 0 nil))
                       (val nil)
                       (t 0))))
          (t (er hard 'set-absstobj-debug
                 "It is illegal to call set-absstobj-debug in a context where ~
                  an abstract stobj invariance violation has already occurred ~
                  but not yet been processed.  You can overcome this ~
                  restriction either by waiting for the top-level prompt, or ~
                  by evaluating the following form: ~x0."
                 `(set-abbstobj-debug ,(if (member-eq val '(nil :reset))
                                           nil
                                         t)
                                      :always t)))))
  val)

(defmacro set-absstobj-debug (val &key (event-p 't) always on-skip-proofs)

; Here is a book that was certifiable in ACL2 Version_5.0, obtained from Sol
; Swords (shown here with only very trivial changes).  It explains why we need
; the :protect keyword for defabsstobj, as explained in :doc note-6-0.
; Community book books/misc/defabsstobj-example-4.lisp is based on this
; example, but focuses on invariance violation and avoids the work Sol did to
; get a proof of nil.

;   (in-package "ACL2")
;
;   (defstobj const-stobj$c (const-fld$c :type bit :initially 0))
;
;   (defstub stop () nil)
;
;   ;; Logically preserves the field value as 0, but actually leaves it as 1
;   (defun change-fld$c (const-stobj$c)
;      (declare (xargs :stobjs const-stobj$c))
;      (let ((const-stobj$c (update-const-fld$c 1 const-stobj$c)))
;        (prog2$ (stop)
;                (update-const-fld$c 0 const-stobj$c))))
;
;   (defun get-fld$c (const-stobj$c)
;      (declare (xargs :stobjs const-stobj$c))
;      (const-fld$c const-stobj$c))
;
;   (defun const-stobj$ap (const-stobj$a)
;      (declare (xargs :guard t))
;      (equal const-stobj$a 0))
;
;   (defun change-fld$a (const-stobj$a)
;      (declare (xargs :guard t)
;               (ignore const-stobj$a))
;      0)
;
;   ;; Logically returns 0, exec version returns the field value which should
;   ;; always be 0...
;   (defun get-fld$a (const-stobj$a)
;      (declare (xargs :guard t)
;               (ignore const-stobj$a))
;      0)
;
;   (defun create-const-stobj$a ()
;      (declare (xargs :guard t))
;      0)
;
;   (defun-nx const-stobj-corr (const-stobj$c const-stobj$a)
;      (and (equal const-stobj$a 0) (equal const-stobj$c '(0))))
;
;   (in-theory (disable (const-stobj-corr)
;                        (change-fld$c)))
;
;   (DEFTHM CREATE-CONST-STOBJ{CORRESPONDENCE}
;            (CONST-STOBJ-CORR (CREATE-CONST-STOBJ$C)
;                              (CREATE-CONST-STOBJ$A))
;            :RULE-CLASSES NIL)
;
;   (DEFTHM CREATE-CONST-STOBJ{PRESERVED}
;            (CONST-STOBJ$AP (CREATE-CONST-STOBJ$A))
;            :RULE-CLASSES NIL)
;
;   (DEFTHM GET-FLD{CORRESPONDENCE}
;            (IMPLIES (CONST-STOBJ-CORR CONST-STOBJ$C CONST-STOBJ)
;                     (EQUAL (GET-FLD$C CONST-STOBJ$C)
;                            (GET-FLD$A CONST-STOBJ)))
;            :RULE-CLASSES NIL)
;
;   (DEFTHM CHANGE-FLD{CORRESPONDENCE}
;            (IMPLIES (CONST-STOBJ-CORR CONST-STOBJ$C CONST-STOBJ)
;                     (CONST-STOBJ-CORR (CHANGE-FLD$C CONST-STOBJ$C)
;                                       (CHANGE-FLD$A CONST-STOBJ)))
;            :RULE-CLASSES NIL)
;
;   (DEFTHM CHANGE-FLD{PRESERVED}
;            (IMPLIES (CONST-STOBJ$AP CONST-STOBJ)
;                     (CONST-STOBJ$AP (CHANGE-FLD$A CONST-STOBJ)))
;            :RULE-CLASSES NIL)
;
;   (defabsstobj const-stobj
;      :concrete const-stobj$c
;      :recognizer (const-stobjp :logic const-stobj$ap :exec const-stobj$cp)
;      :creator (create-const-stobj :logic create-const-stobj$a :exec
;                                   create-const-stobj$c)
;      :corr-fn const-stobj-corr
;      :exports ((get-fld :logic get-fld$a :exec get-fld$c)
;                (change-fld :logic change-fld$a :exec change-fld$c
;                            ;; new
;                            ;; :protect t
;                            )))
;
;   ;; Causes an error and leaves the stobj in an inconsistent state (field
;   ;; is 1)
;   (make-event
;    (mv-let
;     (erp val state)
;     (trans-eval '(change-fld const-stobj) 'top state t)
;     (declare (ignore erp val))
;     (value '(value-triple nil))))
;
;   (defevaluator my-ev my-ev-lst ((if a b c)))
;
;   (defun my-clause-proc (clause hint const-stobj)
;      (declare (xargs :stobjs const-stobj
;                      :guard t)
;               (ignore hint))
;      (if (= 0 (get-fld const-stobj)) ;; always true by defn. of get-fld
;          (mv nil (list clause))
;        (mv nil nil))) ;; unsound if this branch is taken
;
;   (defthm my-clause-proc-correct
;      (implies (and (pseudo-term-listp clause)
;                    (alistp a)
;                    (my-ev (conjoin-clauses
;                            (clauses-result
;                             (my-clause-proc clause hint const-stobj)))
;                           a))
;               (my-ev (disjoin clause) a))
;      :rule-classes :clause-processor)
;
;   (defthm foo nil :hints (("goal" :clause-processor
;                             (my-clause-proc clause nil const-stobj)))
;      :rule-classes nil)

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

  obtain debugging information upon atomicity violation for an abstract stobj~/

  This ~il[documentation] topic assumes familiarity with abstract stobjs.
  ~l[defabsstobj].

  Below we explain what is meant by an error message such as the following.

  ~bv[]
  ACL2 Error in CHK-ABSSTOBJ-INVARIANTS:  Possible invariance violation
  for an abstract stobj!  See :DOC set-absstobj-debug, and PROCEED AT
  YOUR OWN RISK.
  ~ev[]

  The use of ~c[(set-absstobj-debug t)] will make this error message more
  informative, as follows, at the cost of slower execution ~-[] but in
  practice, the slowdown may be negligible (more on that below).

  ~bv[]
  ACL2 Error in CHK-ABSSTOBJ-INVARIANTS:  Possible invariance violation
  for an abstract stobj!  See :DOC set-absstobj-debug, and PROCEED AT
  YOUR OWN RISK.  Evaluation was aborted under a call of abstract stobj
  export UPDATE-FLD-NIL-BAD.
  ~ev[]

  You may be best off starting a new ACL2 session if you see one of the errors
  above.  But you can continue at your own risk.  With a trust tag
  (~pl[defttag]), you can even fool ACL2 into thinking nothing is wrong, and
  perhaps you can fix up the abstract stobj so that indeed, nothing really is
  wrong.  See the community book ~c[books/misc/defabsstobj-example-4.lisp] for
  how to do that.  That book also documents the ~c[:always] keyword and a
  special value for the first argument, ~c[:RESET].

  ~bv[]
  Examples:
  (set-absstobj-debug t)                 ; obtain extra debug info, as above
  (set-absstobj-debug t :event-p t)      ; same as above
  (set-absstobj-debug t
                      :on-skip-proofs t) ; as above, but even in include-book
  (set-absstobj-debug t :event-p nil)    ; returns one value, not error triple
  (set-absstobj-debug nil)               ; avoid extra debug info (default)~/

  General Form:
  (set-absstobj-debug val
                      :event-p        event-p        ; default t
                      :always         always         ; default nil
                      :on-skip-proofs on-skip-proofs ; default nil
                      )
  ~ev[]
  where the keyword arguments are optional with defaults as indicated above,
  and all supplied arguments are evaluated except for ~c[on-skip-proofsp],
  which must be Boolean (if supplied).  Keyword arguments are discussed at the
  end of this topic.

  Recall (~pl[defabsstobj]) that for any exported function whose ~c[:EXEC]
  function might (according to ACL2's heuristics) modify the concrete stobj
  non-atomically, one must specify ~c[:PROTECT t].  This results in extra code
  generated for the exported function, which provides a check that atomicity
  was not actually violated by a call of the exported function.  The extra code
  might slow down execution, but perhaps only negligibly in typical cases.  If
  you can tolerate a bit extra slow-down, then evaluate the form
  ~c[(set-absstobj-debug t)].  Subsequent such errors will provide additional
  information, as in the example displayed earlier in this documentation topic.

  Finally we document the keyword arguments, other than ~c[:ALWAYS], which is
  discussed in a book as mentioned above.  When the value of ~c[:EVENT-P] is
  true, which it is by default, the call of ~c[set-absstobj-debug] will expand
  to an event.  That event is a call of ~ilc[value-triple].  In that case,
  ~c[:ON-SKIP-PROOFS] is passed to that call so that ~c[set-absstobj-debug] has
  an effect even when proofs are being skipped, as during ~ilc[include-book].
  That behavior is the default; that is, ~c[:ON-SKIP-PROOFS] is ~c[nil] by
  default.  Also ~pl[value-triple].  The value of keyword ~c[:ON-SKIP-PROOFS]
  must always be either ~c[t] or ~c[nil], but other than that, it is ignored
  when ~c[EVENT-P] is ~c[nil].~/"

  (declare (xargs :guard

; We provide this guard as a courtesy: since on-skip-proofs is not evaluated, a
; non-nil form that evaluates to nil (such as 'nil) would otherwise be passed
; without evaluation and hence treated as being true.

                  (booleanp on-skip-proofs)))
  (let ((form `(set-absstobj-debug-fn ,val ,always)))
    (cond (event-p `(value-triple ,form :on-skip-proofs ,on-skip-proofs))
          (t form))))

; The following functions are defined in logic mode because they will be
; used in tau bounder correctness theorems.  We basically define two functions,
; intervalp and in-intervalp, but we also define various subroutines needed to
; make those functions manageable.  In tau.lisp we define the record structure:

; (defrec tau-interval (domain (lo-rel . lo) . (hi-rel . hi)) t)

; and this is precisely the structure recognized by intervalp and given meaning
; by in-intervalp.  We therefore achieve the goal that the user can prove
; theorems about bounder functions defined in terms of the concepts named here
; and we can run those functions on the actual tau-intervals constructed by the
; tau system.  (Of course, those actual intervals could have been constructed
; and accessed by these functions rather than the more efficient record
; expressions, but efficiency matters.)

; In the guard below, we know when both x and y are non-nil then (at least) one
; is a rational.  Under that guard, the body below is actually equivalent to the
; more elegant:

;  (if (or (null x)
;          (null y))
;      t
;      (if rel (< x y) (<= x y)))

; except the body is guard-verifiable while the elegant one is not, since the
; guard for < (and <=) requires that both arguments be rationals.  This is
; proved by the thm following the definition.

(defun <? (rel x y)
  (declare (xargs :guard
                  (implies (and x y)
                           (or (real/rationalp x)
                               (real/rationalp y)))))
  (if (or (null x) (null y))
      t
      (let ((x (fix x))
            (y (fix y)))
        (if (real/rationalp x)
            (if (real/rationalp y)
                (if rel
                    (< x y)
                    (<= x y))
                (or (< x (realpart y))
                    (and (= x (realpart y))
                         (< 0 (imagpart y)))))
            (or (< (realpart x) y)
                (and (= (realpart x) y)
                     (< (imagpart x) 0)))))))

;   (thm (implies (implies (and x y)
;                          (or (real/rationalp x)
;                              (real/rationalp y)))
;                 (iff (<? rel x y)
;                      (if (or (null x)
;                              (null y))
;                          t
;                          (if rel (< x y) (<= x y)))))
;        :hints
;        (("Goal"
;          :use ((:instance completion-of-< (x x) (y y))
;                (:instance completion-of-< (x y) (y x))))))

(defun tau-interval-domainp (dom x)
  (declare (xargs :guard t))
  (cond ((eq dom 'integerp) (integerp x))
        ((eq dom 'rationalp) (rationalp x))
        ((eq dom 'acl2-numberp) (acl2-numberp x))
; Domain = nil means no restrictions.
        (t t)))

(defun tau-interval-dom (x)
  (declare (xargs :guard (consp x)))

  ":Doc-Section tau-system

  access the domain of a tau interval~/

  It is the case that
  ~bv[]
  (tau-interval-dom (make-tau-interval dom lo-rel lo hi-rel hi)) = dom
  ~ev[]
  ~/
  For a well-formed interval, ~c[dom] is one of the symbols ~c[INTEGERP],
  ~c[RATIONALP], ~c[ACL2-NUMBERP], or ~c[NIL].  When the domain is ~c[NIL]
  there is no domain restriction.

  When the domain is ~c[INTEGERP], there are additional constraints on the
  other components.  ~l[make-tau-interval].~/"

  (car x))

(defun tau-interval-lo-rel (x)
  (declare (xargs :guard (and (consp x) (consp (cdr x)) (consp (cadr x)))))

  ":Doc-Section tau-system

  access the lower bound relation of a tau interval~/

  It is the case that
  ~bv[]
  (tau-interval-lo-rel (make-tau-interval dom lo-rel lo hi-rel hi)) = lo-rel
  ~ev[]
  ~/
  For a well-formed interval, ~c[lo-rel] is a Boolean, where ~c[t]
  denotes the ~ilc[<] (strong inequality or ``less-than'') relation and
  ~c[nil] denotes ~ilc[<=] (weak inequality or ``less-than-or-equal'') relation
  between the lower bound and the elements of the interval.

  When the domain of an interval is ~c[INTEGERP], there are additional
  constraints on the other components.  ~l[make-tau-interval].~/"

  (car (cadr x)))

(defun tau-interval-lo (x)
  (declare (xargs :guard (and (consp x) (consp (cdr x)) (consp (cadr x)))))

  ":Doc-Section tau-system

  access the lower bound of a tau interval~/

  It is the case that
  ~bv[]
  (tau-interval-lo (make-tau-interval dom lo-rel lo hi-rel hi)) = lo
  ~ev[]
  ~/
  For a well-formed interval, ~c[lo] is either ~c[nil], denoting negative
  infinity, or a rational number giving the lower bound of the interval.
  It must be the case that the lower bound is weakly below the upper bound
  of a well-formed interval.

  When the domain of an interval is ~c[INTEGERP], there are additional
  constraints on the other components.  ~l[make-tau-interval].~/"

  (cdr (cadr x)))

(defun tau-interval-hi-rel (x)
  (declare (xargs :guard (and (consp x) (consp (cdr x)) (consp (cddr x)))))
  ":Doc-Section tau-system

  access the upper bound relation of a tau interval~/

  It is the case that
  ~bv[]
  (tau-interval-hi-rel (make-tau-interval dom lo-rel lo hi-rel hi)) = hi-rel
  ~ev[]
  ~/
  For a well-formed interval, ~c[hi-rel] is a Boolean, where ~c[t]
  denotes the ~ilc[<] (strong inequality or ``less-than'') relation and
  ~c[nil] denotes ~ilc[<=] (weak inequality or ``less-than-or-equal'') relation
  between the elements of the interval and the upper bound.

  When the domain of an interval is ~c[INTEGERP], there are additional
  constraints on the other components.  ~l[make-tau-interval].~/"

  (car (cddr x)))

(defun tau-interval-hi (x)
  (declare (xargs :guard (and (consp x) (consp (cdr x)) (consp (cddr x)))))

  ":Doc-Section tau-system

  access the upper bound of a tau interval~/

  It is the case that
  ~bv[]
  (tau-interval-hi (make-tau-interval dom lo-rel lo hi-rel hi)) = hi
  ~ev[]
  ~/
  For a well-formed interval, ~c[hi] is either ~c[nil], denoting positive
  infinity, or a rational number giving the upper bound of the interval.
  It must be the case that the upper bound is weakly above the lower bound
  of a well-formed interval.

  When the domain of an interval is ~c[INTEGERP], there are additional
  constraints on the other components.  ~l[make-tau-interval].~/"

  (cdr (cddr x)))

(defun make-tau-interval (dom lo-rel lo hi-rel hi)
  (declare (xargs :guard (and (or (null lo) (rationalp lo))
                              (or (null hi) (rationalp hi)))))
  ":Doc-Section tau-system

  make a tau interval~/

  ~bv[]
  General Form:
  (make-tau-interval doc lo-rel lo hi-rel hi)
  ~ev[]

  An interval is a structure of the form: ~c[(]~i[dom] ~c[(]~i[lo-rel] ~c[.]
  ~i[lo]~c[)] ~c[.]  ~c[(]~i[hi-rel] ~c[.] ~i[hi]~c[))].  Every tau contains an
  interval used to represent the domain, the upper, and the lower bounds of the
  objects recognized by the tau.~/

  ~c[make-tau-interval] constructs well-formed intervals only if its five arguments
  satisfy certain restrictions given below.  When these restrictions are
  violated ~c[make-tau-interval] can construct objects that are not intervals!
  ~c[make-tau-interval] does not attempt to coerce or adjust its arguments to make
  well-formed intervals.

  For examples of intervals (and non-intervals!) constructed by
  ~c[make-tau-interval] see ~ilc[tau-intervalp].  For examples of what objects are
  contained in certain intervals, see ~ilc[in-tau-intervalp].

  The components of an interval are as follows:

  ~i[dom] (``domain'') -- must be one of four symbols: ~c[INTEGERP],
  ~c[RATIONALP], ~c[ACL2-NUMBERP], or ~c[NIL] denoting no restriction
  on the domain.

  The two ``relations,'' ~i[lo-rel] and ~i[hi-rel] are Booleans, where ~c[t]
  denotes less-than inequality (~ilc[<]) and ~c[nil] represents
  less-than-or-equal inequality (~ilc[<=]).  Think of ~c[t] meaning ``strong''
  and ~c[nil] meaning ``weak'' inequality.

  ~i[Lo] and ~i[hi] must be either ~c[nil] or explicit rational numbers.  If
  ~i[lo] is ~c[nil] it denotes negative infinity; if ~i[hi] is ~c[nil] it
  denotes positive infinity.  ~i[Lo] must be no greater than ~i[hi].
  ~i[Note]:  Even though ~c[ACL2-NUMBERP] intervals may contain complex
  rationals, the ~i[lo] and ~i[hi] bounds must be rational.  This is an
  arbitrary decision made by the implementors to simplify coding.

  Finally, if the ~i[dom] is ~c[INTEGERP], then both relations should be weak
  and ~i[lo] and ~i[hi] must be integers when they are non-~c[nil].

  For ~i[x] to be ``in'' an interval it must be of the type described
  by the domain predicate ~i[dom], ~i[lo] must be smaller than ~i[x] in the
  strong or weak sense denoted by ~i[lo-rel], and ~i[x] must be smaller than
  ~i[hi] in the strong or weak sense denoted by ~i[hi-rel].

  The components of an interval may be accessed with the functions
  ~ilc[tau-interval-dom], ~ilc[tau-interval-lo-rel], ~ilc[tau-interval-lo],
  ~ilc[tau-interval-hi-rel], and ~ilc[tau-interval-hi].~/"

  (cons dom (cons (cons lo-rel lo)
                  (cons hi-rel hi))))

(defun tau-intervalp (int)
  (declare (xargs :guard t))

  ":Doc-Section tau-system

  Boolean recognizer for tau intervals~/

  ~bv[]
  General Form:
  (tau-intervalp x)
  ~ev[]
  ~/
  An interval is a structure of the form: ~c[(]~i[dom] ~c[(]~i[lo-rel] ~c[.]
  ~i[lo]~c[)] ~c[.]  ~c[(]~i[hi-rel] ~c[.] ~i[hi]~c[))].  Every tau contains an
  interval used to represent the domain and the upper and lower bounds of the
  objects recognized by the tau.

  Restrictions on the components of an interval are as follows.  For an
  interpretation of the meaning of the components, see ~ilc[in-tau-intervalp] or
  ~ilc[make-tau-interval].

  ~i[dom] (``domain'') -- must be one of four symbols: ~c[INTEGERP],
  ~c[RATIONALP], ~c[ACL2-NUMBERP], or ~c[NIL].

  The two ``relations,'' ~i[lo-rel] and ~i[hi-rel], must be Booleans.

  ~i[Lo] and ~i[hi] must be either ~c[nil] or explicit rational numbers.
  ~i[Lo] must be no greater than ~i[hi] (where ~c[nil]s represent negative or
  positive infinity for ~i[lo] and ~i[hi] respectively.

  Finally, if the ~i[dom] is ~c[INTEGERP], then both relations must ~c[nil]
  and ~i[lo] and ~i[hi] must be integers when they are non-~c[nil].

  Recall that ~ilc[make-tau-interval] constructs intervals.  The intervals it
  constructs are well-formed only if the arguments to ~c[make-tau-interval] satisfy
  the rules above; ~c[make-tau-interval] does not coerce or adjust its
  arguments in any way.  Thus, it can be (mis-)used to create non-intervals.
  Here are examples of ~c[tau-intervalp] using ~c[make-tau-interval].

  ~bv[]
  ; integers: 0 <= x <= 10:
  (tau-intervalp (make-tau-interval 'INTEGERP nil 0 nil 10))      = t

  ; integers: 0 <= x (i.e., the natural numbers):
  (tau-intervalp (make-tau-interval 'INTEGERP nil 0 nil nil))     = t

  ; violations of domain rules:
  (tau-intervalp (make-tau-interval 'INTEGERP t 0 t 10))          = nil
  (tau-intervalp (make-tau-interval 'INTEGERP nil 0 nil 10/11))   = nil

  ; violation of rule that bounds must be rational if non-nil:
  (tau-intervalp (make-tau-interval 'ACL2-NUMBERP t 0 t #c(3 5))) = nil

  ; violation of rule that lo <= hi:
  (tau-intervalp (make-tau-interval 'ACL2-NUMBERP t 0 t -10))     = nil

  ; rationals: 0 < x <= 22/7:
  (tau-intervalp (make-tau-interval 'RATIONALP t 0 nil 22/7))     = t

  ; numbers: -10 < x < 10:
  (tau-intervalp (make-tau-interval 'ACL2-NUMBERP t -10 t 10))    = t

  ; any: -10 < x < 10:
  (tau-intervalp (make-tau-interval nil t -10 t 10))              = t

  : any:
  (tau-intervalp (make-tau-interval nil nil nil nil nil))         = t
  ~ev[]
  Note that the second-to-last interval, with domain ~c[nil] contains all
  non-numbers as well as numbers strictly between -10 and 10.  The reason is
  that the interval contains ~c[0] and all non-numbers are coerced to ~c[0] by
  the inequality functions.

  Note that the last interval contains all ACL2 objects.  It is called the
  ``universal interval.''~/"

  (if (and (consp int)
           (consp (cdr int))
           (consp (cadr int))
           (consp (cddr int)))
      (let ((dom (tau-interval-dom int))
            (lo-rel (tau-interval-lo-rel int))
            (lo (tau-interval-lo int))
            (hi-rel (tau-interval-hi-rel int))
            (hi (tau-interval-hi int)))
        (cond
         ((eq dom 'integerp)
          (and (null lo-rel)
               (null hi-rel)
               (if lo
                   (and (integerp lo)
                        (if hi
                            (and (integerp hi)
                                 (<= lo hi))
                            t))
                   (if hi
                       (integerp hi)
                       t))))
         (t (and (member dom '(rationalp acl2-numberp nil))
                 (booleanp lo-rel)
                 (booleanp hi-rel)
                 (if lo
                     (and (rationalp lo)
                          (if hi
                              (and (rationalp hi)
                                   (<= lo hi))
                              t))
                     (if hi
                         (rationalp hi)
                         t))))))
      nil))

(defun in-tau-intervalp (x int)
  (declare (xargs :guard (tau-intervalp int)))

  ":Doc-Section tau-system

  Boolean membership in a tau interval~/

  ~bv[]
  General Form:
  (in-tau-intervalp e x)
  ~ev[]

  Here, ~c[x] should be an interval (see ~ilc[tau-intervalp]).  This function
  returns ~c[t] or ~c[nil] indicating whether ~c[e], which is generally but not
  necessarily a number, is an element of interval ~c[x].  By that is meant that
  ~c[e] satisfies the domain predicate of the interval and lies between the two
  bounds.~/

  Suppose ~c[x] is an interval with the components ~i[dom], ~i[lo-rel], ~i[lo],
  ~i[hi-rel] and ~i[hi].  Suppose ~c[(<? ]~i[rel u v]~c[)] means ~c[(< ]~i[u v]~c[)]
  when ~i[rel] is true and ~c[(<= ]~i[u v]~c[)] otherwise, with appropriate
  treatment of infinities.

  Then for ~c[e] to be in interval ~c[x], it must be the case that ~c[e]
  satisfies the domain predicate ~i[dom] (where where ~i[dom]=~c[nil] means
  there is no restriction on the domain) and ~c[(<? ]~i[lo-rel lo]~c[ e)] and
  ~c[(<? ]~i[hi-rel]~c[ e ]~i[hi]~c[)].  [Note:  ``Appropriate treatment of
  infinities'' is slightly awkward if both infinities are represented by the
  same object, ~c[nil].  However, this is handled by coercing ~c[e] to a
  number ~i[after] checking that it is in the domain.  By this trick, ``~c[<?]''
  is presented with at most one ``infinity'' and it is always negative
  when in the first argument and positive when in the second.]

  Note that every element in an ~c[INTEGERP] interval is contained in the
  analogous ~c[RATIONALP] interval (i.e., the interval obtained by just
  replacing the domain ~c[INTEGERP] by ~c[RATIONALP]).  That is because every
  integer is a rational.  Similarly, every rational is an ACL2 number.

  Note that an interval in which the relations are weak and the bounds are
  equal rationals is the ``unit'' or ``identity'' interval containing exactly
  that rational.

  Note that an interval in which the relations are strong and the bounds are
  equal rationals is empty:  it contains no objects.

  Note that the interval ~c[(make-tau-interval nil nil nil nil nil)] is the
  ``universal interval:'' it contains all ACL2 objects.  It contains all
  numbers because they statisfy the non-existent domain restriction and lie
  between minus infinity and plus infinity.  It contains all non-numbers
  because the interval contains ~c[0] and ACL2's inequalities coerce
  non-numbers to ~c[0].  The universal interval is useful if you are defining a
  bounder (~pl[bounders]) for a function and do not wish to address a certain
  case: return the universal interval.

  Recall that ~ilc[make-tau-interval] constructs intervals.  Using ~c[make-tau-interval]
  we give several self-explanatory examples of ~c[in-tau-intervalp]:

  ~bv[]
  (in-tau-intervalp 3 (make-tau-interval 'INTEGERP nil 0 nil 10))           = t
  (in-tau-intervalp 3 (make-tau-interval 'RATIONALP nil 0 nil 10))          = t
  (in-tau-intervalp 3 (make-tau-interval NIL nil 0 nil 10))                 = t

  (in-tau-intervalp -3 (make-tau-interval 'INTEGERP nil 0 nil 10))          = nil
  (in-tau-intervalp 30 (make-tau-interval 'INTEGERP nil 0 nil 10))          = nil

  (in-tau-intervalp 3/5 (make-tau-interval 'INTEGERP nil 0 nil 10))         = nil
  (in-tau-intervalp 3/5 (make-tau-interval 'RATIONALP nil 0 nil 10))        = t

  (in-tau-intervalp #c(3 5) (make-tau-interval 'RATIONALP nil 0 nil 10))    = nil
  (in-tau-intervalp #c(3 5) (make-tau-interval 'ACL2-NUMBERP nil 0 nil 10)) = t

  (in-tau-intervalp 'ABC (make-tau-interval NIL nil 0 nil 10))              = t
  ~ev[]
  ~/"

  (and (tau-interval-domainp (tau-interval-dom int) x)
       (<? (tau-interval-lo-rel int)
           (tau-interval-lo int)
           (fix x))
       (<? (tau-interval-hi-rel int)
           (fix x)
           (tau-interval-hi int))))