acl2-source 8.0dfsg-1 / usr / share / acl2-8.0dfsg / axioms.lisp

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

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

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

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

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

; 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 decidedly ``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 perfectly 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)))

(defmacro getpropc (symb key &optional default (world-alist '(w state)))

; The "c" in "getpropc" suggests "current-acl2-world".

  `(getprop ,symb ,key ,default 'current-acl2-world ,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)))))

#-acl2-loop-only
(progn

; The following are valid exactly when *wormhole-iprint-ar* is not nil.

(defvar *wormhole-iprint-ar* nil)
(defvar *wormhole-iprint-hard-bound* nil)
(defvar *wormhole-iprint-fal* nil)
(defvar *wormhole-iprint-soft-bound* nil)
)

#-acl2-loop-only
(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))
                               ((member arg1
                                        '(iprint-ar
                                          iprint-hard-bound
                                          iprint-fal
                                          iprint-soft-bound)
                                        :test 'eq)

; The variables above store the iprinting data structures.  In the interests of
; somehow keeping them in sync, we set the values of all three if any has
; changed.

                                `(progn
                                   (when (null *wormhole-iprint-ar*)
                                     (setq *wormhole-iprint-hard-bound*
                                           (f-get-global
                                            'iprint-hard-bound
                                            *the-live-state*))
                                     (setq *wormhole-iprint-fal*
                                           (f-get-global
                                            'iprint-fal
                                            *the-live-state*))
                                     (setq *wormhole-iprint-soft-bound*
                                           (f-get-global
                                            'iprint-soft-bound
                                            *the-live-state*))
                                     (setq *wormhole-iprint-ar*
                                           (f-get-global
                                            'iprint-ar
                                            *the-live-state*)))
                                   ,@(when (eq arg1 'iprint-ar)
                                       `((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-msg*
  "~%The message above might explain the error.  If not, and~%~
   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 raw-lisp-error and see :DOC guards.~&")

(defvar *acl2-error-msg-certify-book-step1*
  "~%The message above might explain the error.  If it mentions packages,
it is probably because Step 1 is performed before any form in the book is
evaluated.  See :DOC certify-book, in particular, the discussion about ``Step
1'' and portcullis commands.~&")

(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-msg* (if (eq *acl2-error-msg*
                                      *acl2-error-msg-certify-book-step1*)
                                  *acl2-error-msg*
                                nil)))
        (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))))

(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
           bitp
           booleanp
           complex-rationalp
           cons-with-hint
           eqlablep
           fix
           fn-symb
           iff
           ifix
           implies
           integer-abs
           integer-range-p
           len
           logicp ; formerly macro logicalp; preserving efficiency
           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*

; Warning: This needs to be a defparameter, not a defvar, since it is
; introduced (temporarily) in acl2-fns.lisp.

  (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 defines the function symbol, name, in raw Lisp.  Name should have a
; guard of t and should have *unknown-constraints*.  We push name onto
; *defun-overrides* so that add-trip knows to leave the *1* definition in
; place.

; Warning: The generated definitions will replace both the raw Lisp and *1*
; definitions of name.  We must ensure that these definitions can't be
; evaluated when proving theorems unless each has unknown-constraints and never
; returns two values for the same input.  The latter condition may be taken
; care of by passing in live states with different, or unknown, oracles.  If
; state is not a formal (or even if it is), this latter condition -- i.e.,
; being a function, must be true in order for the use of defun-overrides to be
; sound!

  (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 deftheory (&rest args)
  (declare (ignore args))
  nil)

(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 (car (cddddr d))))
    (assert ans)
    ans))

(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)
  (declare (ignore uncertified-okp defaxioms-okp skip-proofs-okp ttags))
  `(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))))
)

;                          STANDARD CHANNELS

(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)
  (declare (xargs :guard t))
  (if p (if q t nil) (if q nil t)))

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

#+acl2-loop-only
(defun eq (x y)
  (declare (xargs :guard (if (symbolp x)
                             t
                           (symbolp y))
                  :mode :logic :verify-guards t))
  (equal x y))

(defun booleanp (x)
  (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)
  (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)
 (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)
  (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)
  #+:non-standard-analysis
  `(realp ,x)
  #-:non-standard-analysis
  `(rationalp ,x))

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

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

(defun true-listp (x)
  (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)
  (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)
 (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)
   (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)
  (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)
  (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)

; 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)
  (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)
  (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)
  (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))))
  (equal x y))

#+acl2-loop-only
(defun atom (x)
 (declare (xargs :mode :logic :guard t))
 (not (consp x)))

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

(defun make-character-list (x)
  (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)
  (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)
  (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)
  (declare (xargs :guard (alistp alist)))
  (cons (cons key datum) alist))

#+acl2-loop-only
(defun endp (x)
  (declare (xargs :mode :logic
                  :guard (or (consp x) (eq x nil))))
  (atom x))

#+acl2-loop-only
(defmacro caar (x)
  (list 'car (list 'car x)))

#+acl2-loop-only
(defmacro cadr (x)
  (list 'car (list 'cdr x)))

#+acl2-loop-only
(defmacro cdar (x)
  (list 'cdr (list 'car x)))

#+acl2-loop-only
(defmacro cddr (x)
  (list 'cdr (list 'cdr x)))

#+acl2-loop-only
(defmacro caaar (x)
  (list 'car (list 'caar x)))

#+acl2-loop-only
(defmacro caadr (x)
  (list 'car (list 'cadr x)))

#+acl2-loop-only
(defmacro cadar (x)
  (list 'car (list 'cdar x)))

#+acl2-loop-only
(defmacro caddr (x)
  (list 'car (list 'cddr x)))

#+acl2-loop-only
(defmacro cdaar (x)
  (list 'cdr (list 'caar x)))

#+acl2-loop-only
(defmacro cdadr (x)
  (list 'cdr (list 'cadr x)))

#+acl2-loop-only
(defmacro cddar (x)
  (list 'cdr (list 'cdar x)))

#+acl2-loop-only
(defmacro cdddr (x)
  (list 'cdr (list 'cddr x)))

#+acl2-loop-only
(defmacro caaaar (x)
  (list 'car (list 'caaar x)))

#+acl2-loop-only
(defmacro caaadr (x)
  (list 'car (list 'caadr x)))

#+acl2-loop-only
(defmacro caadar (x)
  (list 'car (list 'cadar x)))

#+acl2-loop-only
(defmacro caaddr (x)
  (list 'car (list 'caddr x)))

#+acl2-loop-only
(defmacro cadaar (x)
  (list 'car (list 'cdaar x)))

#+acl2-loop-only
(defmacro cadadr (x)
  (list 'car (list 'cdadr x)))

#+acl2-loop-only
(defmacro caddar (x)
  (list 'car (list 'cddar x)))

#+acl2-loop-only
(defmacro cadddr (x)
  (list 'car (list 'cdddr x)))

#+acl2-loop-only
(defmacro cdaaar (x)
  (list 'cdr (list 'caaar x)))

#+acl2-loop-only
(defmacro cdaadr (x)
  (list 'cdr (list 'caadr x)))

#+acl2-loop-only
(defmacro cdadar (x)
  (list 'cdr (list 'cadar x)))

#+acl2-loop-only
(defmacro cdaddr (x)
  (list 'cdr (list 'caddr x)))

#+acl2-loop-only
(defmacro cddaar (x)
  (list 'cdr (list 'cdaar x)))

#+acl2-loop-only
(defmacro cddadr (x)
  (list 'cdr (list 'cdadr x)))

#+acl2-loop-only
(defmacro cdddar (x)
  (list 'cdr (list 'cddar x)))

#+acl2-loop-only
(defmacro cddddr (x)
  (list 'cdr (list 'cdddr x)))

#+acl2-loop-only
(defun null (x)
  (declare (xargs :mode :logic :guard t))
  (eq x nil))

(defun symbol-listp (lst)
  (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)
  (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)
  (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))))))

#-acl2-loop-only
(defvar *hard-error-returns-nilp*

; For an explanation of this defvar, see the comment in hard-error, below.

  nil)

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

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

#-acl2-loop-only
(defvar *hard-error-is-error* t) ; set to nil at the end of the boot-strap

(defun hard-error (ctx str alist)

; This function returns nil -- when it returns.  However, 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.  A second special variable,
; *hard-error-is-error*, is only relevant when *hard-error-returns-nilp* is
; nil: when *hard-error-returns-nilp* is nil and *hard-error-is-error* is
; non-nil, an actual Lisp error occurs (which can then be caught with
; ignore-errors or handler-bind).

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

  (declare (xargs :guard t))
  #-acl2-loop-only
  (when (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).

    (let ((state *the-live-state*))
      (cond
       (*hard-error-is-error*
        (hard-error-is-error ctx str alist))
       (t
        (when (not (and (f-get-global 'inhibit-er-hard state)
                        (member 'error
                                (f-get-global 'inhibit-output-lst state)
                                :test #'eq)))
          (let ((*standard-output* *error-output*)
                (*wormholep* nil))
            (error-fms t ctx str alist state)))

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

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

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

  (declare (xargs :guard (hard-error ctx str alist)))
  (hard-error ctx str alist))

#-acl2-loop-only
(defun-one-output intern-in-package-of-symbol (str sym)

; See the Essay on Symbols and Packages below.  We moved this definition from
; just under that Essay to its present location, in order to support the
; definition of guard-check-fn.

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

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

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

(defun return-last-fn (qfn)

; Return nil unless qfn is of the form (quote s) for a symbol s.

  (declare (xargs :guard t))
  (and (consp qfn)
       (eq (car qfn) 'quote)
       (consp (cdr qfn))
       (symbolp (cadr qfn))
       (null (cddr qfn))
       (cadr qfn)))

#-acl2-loop-only
(defun return-last-arg2 (fn arg2)

; Here fn is known to be a symbol, for example as returned by applying
; return-last-fn to the first argument of a call of return-last.  Note that fn
; can be nil, in which case the second cond clause below is taken.  We think of
; arg2 as being the second argument of a call of return-last, and here we cause
; that argument to be evaluated with attachments when appropriate.

; 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.).  Note that with the binding of *aokp*, we guarantee that changes to
; *aokp* during evaluation of arg2 won't prevent the storing of memoization
; results.  For further explanation on this point, see the comment in *aokp*.

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

#-acl2-loop-only
(defmacro return-last (qfn arg2 arg3)
  (let* ((fn (return-last-fn qfn))
         (arg2 (return-last-arg2 fn 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.

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

  `(mbe1 ,exec ,logic))

(defmacro mbe (&key (exec 'nil exec-p) (logic 'nil logic-p))
  (declare (xargs :guard (and exec-p logic-p))
           (ignorable exec-p logic-p))
  `(mbe1 ,exec ,logic))

(defmacro mbt (x)
  `(mbe1 t ,x))

(defmacro mbt* (x)

; This macro is like mbt, except that not only is it trivial in raw Lisp, it's
; also trivial in the logic.  Its only purpose is to generate a guard proof
; obligation.

  `(mbe :logic t
        :exec (mbe :logic ,x
                   :exec t)))

(defun binary-append (x y)
  (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)
  (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)

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

(defthm append-to-nil
  (implies (true-listp x)
           (equal (append x nil)
                  x)))

#+acl2-loop-only
(defmacro concatenate (result-type &rest sequences)
  (declare (xargs :guard (or (equal result-type ''string)
                             (equal result-type ''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)
  (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.  (We ensure the preceding
; sentence by calling verify-termination-boot-strap later in this file.  We
; have seen an ACL2(p) stack overflow caused in thanks-for-the-hint when this
; function was in :program mode and we were in safe-mode because we were
; macroexpanding.)

       (concatenate 'string str1 str2)))

(defun string-listp (x)
  (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))))))

(defun guard-check-fn (sym)

; Below, we call intern-in-package-of-symbol instead of intern or intern$,
; because those have not yet been defined; they are defined later in this file.

; We intern in package "ACL2", rather than in the package of e, because our
; intended use of this function is for ACL2 definitions of macros like member,
; and we expect the guard-check function symbol to be in the "ACL2" package,
; not the main Lisp package.

  (declare (xargs :guard (symbolp sym)))
  (intern-in-package-of-symbol
   (concatenate 'string (symbol-name sym) "$GUARD-CHECK")
   'acl2::rewrite))

(defun let-mbe-guard-form (logic exec)
  (declare (ignore logic) ; for guard only
           (xargs :mode :program
                  :guard (and (consp logic)
                              (consp exec)
                              (symbolp (car exec))
                              (equal (cdr logic) (cdr exec))))) ; same args
  (cond ((consp exec)
         (cons (guard-check-fn (car exec))
               (cdr exec)))
        (t (hard-error 'let-mbe-guard-form
                       "Bad input, ~x0!"
                       (list (cons #\0 exec))))))

(defmacro let-mbe (bindings &key
                            logic exec (guardp 't))
  (cond (guardp
         `(let ,bindings
            (mbe :logic
                 (prog2$ ,(let-mbe-guard-form logic exec)
                         ,logic)
                 :exec ,exec)))
        (t `(let ,bindings
              (mbe :logic ,logic
                   :exec ,exec)))))

(defmacro defun-with-guard-check (name args guard body)
  (let ((decl `(declare (xargs :guard ,guard))))
    `(progn (defun ,(guard-check-fn name) ,args ,decl
              (declare (ignore ,@args))
              t)
            (defun ,name ,args ,decl ,body))))

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

  `(return-last 'progn ,x ,y))

; Member

(defun-with-guard-check member-eq-exec (x lst)
  (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-with-guard-check member-eql-exec (x lst)
  (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))
  (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-with-guard-check subsetp-eq-exec (x y)
  (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-with-guard-check subsetp-eql-exec (x y)
  (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))
  (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)
  (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-with-guard-check assoc-eq-exec (x alist)
  (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-with-guard-check assoc-eql-exec (x alist)
  (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))
  (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)
  (List 'not (list '< y x)))

#+acl2-loop-only
(defun = (x y)
  (declare (xargs :mode :logic
                  :guard (and (acl2-numberp x)
                              (acl2-numberp y))))

  (equal x y))

#+acl2-loop-only
(defun /= (x y)
  (Declare (xargs :mode :logic
                  :guard (and (acl2-numberp x)
                              (acl2-numberp y))))
  (not (equal x y)))

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

#+acl2-loop-only
(defmacro >= (x y)
  (list 'not (list '< x y)))

(defmacro int= (i j)
  (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))))
  (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)))
  (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)
  (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)
  (declare (xargs :guard (and (stringp s)
                              (integerp n)
                              (>= n 0)
                              (< n (length s)))))
  (nth n (coerce s 'list)))

#+acl2-loop-only
(defun sleep (n)
  (declare (xargs :guard (and (rationalp n)
                              (<= 0 n))))
  (declare (ignore n))
  nil)

(defun proper-consp (x)
  (declare (xargs :guard t))
  (and (consp x)
       (true-listp x)))

(defun improper-consp (x)
  (declare (xargs :guard t))
  (and (consp x)
       (not (true-listp x))))

#+acl2-loop-only
(defmacro * (&rest rst)
  (cond ((null rst) 1)
        ((null (cdr rst)) (list 'binary-* 1 (car rst)))
        (t (xxxjoin 'binary-* rst))))

;; Historical Comment from Ruben Gamboa:
;; This function was modified to accept all complex arguments,
;; not just the complex-rationalps

#+acl2-loop-only
(defun conjugate (x)
  (declare (xargs :guard (acl2-numberp x)))
  (complex (realpart x)
           (- (imagpart x))))

(defun add-suffix (sym str)
  (declare (xargs :guard (and (symbolp sym)
                              (stringp str))))
  (intern-in-package-of-symbol
   (concatenate 'string (symbol-name sym) str)
   sym))

(defconst *inline-suffix* "$INLINE") ; also see above defun-inline-form

#-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)))
        (*1*fn$inline (add-suffix (*1*-symbol (car x)) *inline-suffix*)))
    `(cond
      (*safe-mode-verified-p* ; see below for discussion of this case
       ,x)
      (t
       (funcall
        (cond
         ((fboundp ',*1*fn) ',*1*fn)
         ((fboundp ',*1*fn$inline)
          (assert$ (macro-function ',(car x)) ; sanity check; could be omitted
                   ',*1*fn$inline))
         (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 ultimate 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)
  (declare (xargs :guard t))
  `(ec-call1 nil ,x))

(defmacro non-exec (x)
  (declare (xargs :guard t))
  `(prog2$ (throw-nonexec-error :non-exec ',x)
           ,x))

#+acl2-loop-only
(defmacro / (x &optional (y 'nil binary-casep))
  (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)
  (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)

;; Historical Comment from Ruben Gamboa:
;; This axiom was weakened to accommodate 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)

;; Historical Comment from Ruben Gamboa:
;; This axiom was weakened to accommodate the reals.

(defaxiom complex-implies1
  (and (real/rationalp (realpart x))
       (real/rationalp (imagpart x)))
  :rule-classes nil)

;; Historical Comment from Ruben Gamboa:
;; This axiom was strengthened to include the reals.
; (Note: We turned this into a disabled rewrite rule after ACL2 7.4.)

(defaxiom complex-definition
  (implies (and (real/rationalp x)
                (real/rationalp y))
           (equal (complex x y)
                  (+ x (* #c(0 1) y)))))
(in-theory (disable complex-definition))

;; Historical Comment from Ruben Gamboa:
;; This axiom was weakened to accommodate 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.

;; Historical Comment from Ruben Gamboa:
;; 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)))

;; Historical Comment from Ruben Gamboa:
;; 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)))

;; Historical Comment from Ruben Gamboa:
;; 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)

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

;; Historical Comment from Ruben Gamboa:
;; 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.

;; Historical Comment from Ruben Gamboa:
;; 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 ()

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

;; Historical Comment from Ruben Gamboa:
;; 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.

;; Historical Comment from Ruben Gamboa:
;; After adding the non-standard predicates, this changed to 113.

(defconst *immediate-force-modep-xnume*
  (+ *force-xnume* 3))

(defun case-split (x)

; 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
  '(in-theory (disable (:executable-counterpart force))))

(defmacro enable-forcing nil
  '(in-theory (enable (:executable-counterpart force))))

(defmacro disable-immediate-force-modep ()
  '(in-theory (disable (:executable-counterpart immediate-force-modep))))

(defmacro enable-immediate-force-modep ()
  '(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))
  `(synp (quote nil) (quote (syntaxp ,form)) (quote (and ,form t))))

(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))))))
  (if vars
      `(synp (quote ,vars) (quote (bind-free ,form ,vars)) (quote ,form))
    `(synp (quote t) (quote (bind-free ,form)) (quote ,form))))

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

(defun tau-system (x)
  (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-bitp-pair*
  #+non-standard-analysis
  '(21 . BITP)
  #-non-standard-analysis
  '(18 . BITP))
(defconst *tau-posp-pair*
  #+non-standard-analysis
  '(22 . POSP)
  #-non-standard-analysis
  '(19 . POSP))
(defconst *tau-minusp-pair*
  #+non-standard-analysis
  '(30 . MINUSP)
  #-non-standard-analysis
  '(27 . MINUSP))
(defconst *tau-booleanp-pair*
  #-non-standard-analysis
  '(31 . BOOLEANP)
  #+non-standard-analysis
  '(34 . 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.

;; Historical Comment from Ruben Gamboa:
;; 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 functions 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)

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

(defaxiom characterp-return
  (characterp #\Return)
  :rule-classes nil)

; No-duplicatesp

(defun-with-guard-check no-duplicatesp-eq-exec (l)
  (symbol-listp l)
  (cond ((endp l) t)
        ((member-eq (car l) (cdr l)) nil)
        (t (no-duplicatesp-eq-exec (cdr l)))))

(defun-with-guard-check no-duplicatesp-eql-exec (l)
  (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))
  (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))))

(defun chk-no-duplicatesp (lst)

; This function is used in the implementation of stobj-let.  Do not modify it
; without seeing where it is used and understand the implications of the
; change.

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

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

  (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-with-guard-check rassoc-eq-exec (x alist)
  (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-with-guard-check rassoc-eql-exec (x alist)
  (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))
  (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)

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

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

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

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

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

; 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 (upper-case-p x)
           (lower-case-p (char-downcase x))))

(defthm upper-case-p-char-upcase
  (implies (lower-case-p x)
           (upper-case-p (char-upcase x))))

(defthm lower-case-p-forward-to-alpha-char-p
  (implies (lower-case-p x)
           (alpha-char-p x))
  :rule-classes :forward-chaining)

(defthm upper-case-p-forward-to-alpha-char-p
  (implies (upper-case-p x)
           (alpha-char-p x))
  :rule-classes :forward-chaining)

(defthm alpha-char-p-forward-to-standard-char-p
  (implies (alpha-char-p x)
           (standard-char-p x))
  :hints (("Goal" :in-theory (enable standard-char-p)))
  :rule-classes :forward-chaining)

(defthm standard-char-p-forward-to-characterp
  (implies (standard-char-p x)
           (characterp x))
  :hints (("Goal" :in-theory (enable standard-char-p)))
  :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)
  (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)
    (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))
  `(our-digit-char-p ,ch ,radix))

#+acl2-loop-only
(defun char-equal (x y)
  (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)
  (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.

  (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)
  (declare (xargs :guard t))
  (if (integerp x) x 0))

(defun rfix (x)
  (declare (xargs :guard t))
  (if (rationalp x) x 0))

;; Historical Comment from Ruben Gamboa:
;; 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)
  (declare (xargs :guard t))
  (if (real/rationalp x) x 0))

(defun nfix (x)
  (declare (xargs :guard t))
  (if (and (integerp x) (>= x 0))
      x
    0))

; 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)
  (list '+ 1 x))

#+acl2-loop-only
(defmacro 1- (x)
  (list '- x 1))

(defun natp (x)
  (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 standard-string-p1 (x n)
  (declare (xargs :guard (and (stringp x)
                              (natp n)
                              (<= n (length x)))))
  (cond ((zp n) t)
        (t (let ((n (1- n)))
             (and (standard-char-p (char x n))
                  (standard-string-p1 x n))))))

(defun standard-string-p (x)
  (declare (xargs :guard (stringp x)))
  (standard-string-p1 x (length x)))

(defun standard-string-listp (x)
  (declare (xargs :guard t))
  (cond ((atom x) (eq x nil))
        (t (and (stringp (car x))
                (standard-string-p (car x))
                (standard-string-listp (cdr x))))))

(defun string-equal1 (str1 str2 i maximum)
  (declare (xargs :guard (and (stringp str1)
                              (standard-string-p str1)
                              (stringp str2)
                              (standard-string-p str2)
                              (integerp i)
                              (integerp maximum)
                              (<= maximum (length str1))
                              (<= maximum (length str2))
                              (<= 0 i)
                              (<= i maximum))
                  :measure (nfix (- (ifix maximum) (nfix i)))
                  :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 ; Commented out for patch file
(defun string-equal (str1 str2)
  (declare (xargs :guard (and (stringp str1)
                              (standard-string-p str1)
                              (stringp str2)
                              (standard-string-p str2))
                  :mode :program))
  (let ((len1 (length str1)))
    (and (= len1 (length str2))
         (string-equal1 str1 str2 0 len1))))

(defun member-string-equal (str lst)
  (declare (xargs :guard (and (stringp str)
                              (standard-string-p str)
                              (standard-string-listp lst))
                  :mode :program))
  (cond
   ((endp lst) nil)
   (t (or (string-equal str (car lst))
          (member-string-equal str (cdr lst))))))

(defun standard-string-alistp (x)
  (declare (xargs :guard t))
  (cond
   ((atom x) (eq x nil))
   (t (and (consp (car x))
           (stringp (car (car x)))
           (standard-string-p (car (car x)))
           (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)
  (declare
   (xargs :guard (and (stringp str)
                      (standard-string-p str)
                      (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).

(defun bitp (x)
  (declare (xargs :guard t :mode :logic))
  (or (eql x 0)
      (eql x 1)))

(defthm bitp-compound-recognizer
  (equal (bitp x)
         (or (equal x 0)
             (equal x 1)))
  :rule-classes :compound-recognizer)

(defthm bitp-as-inequality
  (implies (bitp x) (and (natp x) (< x 2)))
  :rule-classes :tau-system)

(defun posp (x)
  (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)
  (declare (xargs :guard t :mode :logic))
  (atom x))

(defmacro o-infp (x)
  `(not (o-finp ,x)))

(defun o-first-expt (x)
  (declare (xargs :guard (or (o-finp x) (consp (car x))) :mode :logic))
  (if (o-finp x)
      0
    (caar x)))

(defun o-first-coeff (x)
  (declare (xargs :guard (or (o-finp x) (consp (car x))) :mode :logic))
  (if (o-finp x)
      x
    (cdar x)))

(defun o-rst (x)
  (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)
  (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)
  `(o< ,y ,x))

(defmacro o<= (x y)
  `(not (o< ,y ,x)))

(defmacro o>= (x y)
  `(not (o< ,x ,y)))

(defun o-p (x)
  (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)
  (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)
  (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*

; The variable *aokp* indicates that state of using attachments, and can take
; any of three sorts of values, as follows.

; nil
;   Attachments are not allowed.

; t
;   Attachments are allowed, but the value currently being computed does not
;   depend on any attachments.

; fn
;   Attachments are allowed, and the value currently being computed depends on
;   the attachment to the function symbol, fn.

; A case that illustrates these values is (prog2$ <expr1> <expr2>), which is
; really (return-last 'progn <expr1> <expr2>).  The #-acl2-loop-only definition
; of return-last replaces <expr1> by (let ((*aokp* t)) <expr1>).  So
; attachments are allowed during the evaluation of <expr1> and moreover, any
; use of attachments in <expr1> (and any setting of *aokp* to a function
; symbol) will be ignored when evaluating <expr2> and when returning from
; prog2$.  This is reasonable, since the values of <expr2> and the prog2$ call
; do not depend on any attachments used in the evaluation of <expr1>.

; We initialize *aokp* to t simply so that we can use attachments at the top
; level of the ACL2 loop and also in raw Lisp.  This variable is bound suitably
; inside the ACL2 loop by calls of raw-ev-fncall.

; Before Version_7.0, *aokp* was Boolean and a separate special variable,
; *attached-fn-called*, was used for holding a function symbol whose
; attachment has been called.  By folding that role into *aokp* we reduced the
; time for (defthm spec-body ...) in
; books/misc/misc2/reverse-by-separation.lisp from 188 seconds to 181 seconds,
; a savings of about 4%.

  t)

(defmacro aokp ()
  '*aokp*)

#+hons
(defmacro update-attached-fn-called (fn)
  `(when (eq *aokp* t)
     (setq *aokp* ,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
(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")))))
  (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)
  `(intern-in-package-of-symbol ,x (pkg-witness ,y)))

#+acl2-loop-only
(defun keywordp (x)
  (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)

(defthm default-pkg-imports
  (implies (not (stringp x))
           (equal (pkg-imports x)
                  nil))
  :hints (("Goal" :use completion-of-pkg-imports)))

; 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
(defvar *load-compiled-stack* nil)

#-acl2-loop-only
(defun-one-output pkg-imports (pkg)

; Warning: Keep this function in sync with pkg-witness.

  (declare (type string pkg))
  (let ((entry (if *load-compiled-stack*
                   (find-package-entry pkg *ever-known-package-alist*)
                 (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 pkg))))))

#-acl2-loop-only
(defun-one-output pkg-witness (pkg)

; Warning: This function is responsible for halting execution when pkg is not
; the name of a package known to ACL2.  (However, when including compiled files
; or expansion files on behalf of include-book, we instead assume that event
; processing can take responsibility for doing such a check, so we make a
; weaker check that avoids assuming that defpkg events have been evaluated in
; the loop.)  Keep this function in sync with pkg-imports.

  (declare (type string pkg))
  (let ((entry (if *load-compiled-stack* ; including a book; see comment above
                   (find-package-entry pkg *ever-known-package-alist*)
                 (find-non-hidden-package-entry pkg
                                                (known-package-alist
                                                 *the-live-state*)))))
    (cond (entry
           (let ((ans (intern *pkg-witness-name* pkg)))

; See comment in intern-in-package-of-symbol for an explanation of this trick.

             ans))
          (t

; We avoid using illegal, because we want to halt execution even when
; *hard-error-returns-nilp* is true.

           (throw-raw-ev-fncall (list 'pkg-imports pkg))))))

;  UTILITIES - definitions of the rest of applicative Common Lisp.

; Binary-append, append, concatenate, etc. were initially defined here, but
; have been moved up in support of guard-check-fn.

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

(defun cons-with-hint (x y hint)
  (declare (xargs :guard t)
           (ignorable hint))
  #-acl2-loop-only
  (when (and (consp hint)
             (eql (car hint) x)
             (eql (cdr hint) y))
    (return-from cons-with-hint
                 hint))
  (cons x y))

; Remove

(defun-with-guard-check remove-eq-exec (x l)
  (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-with-guard-check remove-eql-exec (x l)
  (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))
  (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-with-guard-check remove1-eq-exec (x l)
  (if (symbolp x)
      (true-listp l)
    (symbol-listp l))
  (cond ((endp l) nil)
        ((eq x (car l))
         (cdr l))
        (t (cons-with-hint (car l)
                           (remove1-eq-exec x (cdr l))
                           l))))

(defun-with-guard-check remove1-eql-exec (x l)
  (if (eqlablep x)
      (true-listp l)
    (eqlable-listp l))
  (cond ((endp l) nil)
        ((eql x (car l))
         (cdr l))
        (t (cons-with-hint (car l)
                           (remove1-eql-exec x (cdr l))
                           l))))

(defun remove1-equal (x l)
  (declare (xargs :guard (true-listp l)))
  (cond ((endp l) nil)
        ((equal x (car l))
         (cdr l))
        (t (cons-with-hint (car l)
                           (remove1-equal x (cdr l))
                           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))
  (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))))

; Remove-duplicates

(defun-with-guard-check remove-duplicates-eq-exec (l)
  (symbol-listp l)
  (cond
   ((endp l) nil)
   ((member-eq (car l) (cdr l)) (remove-duplicates-eq-exec (cdr l)))
   (t (cons-with-hint (car l)
                      (remove-duplicates-eq-exec (cdr l))
                      l))))

(defun-with-guard-check remove-duplicates-eql-exec (l)
  (eqlable-listp l)
  (cond
   ((endp l) nil)
   ((member (car l) (cdr l)) (remove-duplicates-eql-exec (cdr l)))
   (t (cons-with-hint (car l)
                      (remove-duplicates-eql-exec (cdr l))
                      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-with-hint (car l)
                      (remove-duplicates-equal (cdr l))
                      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))
  (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))
              :guardp nil ; handled below
              :logic (prog2$
                      (or (stringp x)
                          (,(guard-check-fn 'remove-duplicates-eql-exec)
                           x))
                      (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.

#+acl2-loop-only
(defmacro first (x)
  (list 'car x))

#+acl2-loop-only
(defmacro second (x)
  (list 'cadr x))

#+acl2-loop-only
(defmacro third (x)
  (list 'caddr x))

#+acl2-loop-only
(defmacro fourth (x)
  (list 'cadddr x))

#+acl2-loop-only
(defmacro fifth (x)
  (list 'car (list 'cddddr x)))

#+acl2-loop-only
(defmacro sixth (x)
  (list 'cadr (list 'cddddr x)))

#+acl2-loop-only
(defmacro seventh (x)
  (list 'caddr (list 'cddddr x)))

#+acl2-loop-only
(defmacro eighth (x)
  (list 'cadddr (list 'cddddr x)))

#+acl2-loop-only
(defmacro ninth (x)
  (list 'car (list 'cddddr (list 'cddddr x))))

#+acl2-loop-only
(defmacro tenth (x)
  (list 'cadr (list 'cddddr (list 'cddddr x))))

#+acl2-loop-only
(defmacro rest (x)
  (list 'cdr x))

#+acl2-loop-only
(defun identity (x) (declare (xargs :guard t))
  x)

#+acl2-loop-only
(defun revappend (x y)
  (declare (xargs :guard (true-listp x)))
  (if (endp x)
      y
    (revappend (cdr x) (cons (car x) y))))

(defthm true-listp-revappend-type-prescription
  (implies (true-listp y)
           (true-listp (revappend x y)))
  :rule-classes :type-prescription)

(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)
  (declare (xargs :guard (or (true-listp x)
                             (stringp x))))
  (cond ((stringp x)
         (coerce (revappend (coerce x 'list) nil) 'string))
        (t (revappend x nil))))

(defun pairlis$-tailrec (x y acc)
  (declare (xargs :guard (and (true-listp x)
                              (true-listp y)
			      (true-listp acc))))
  (cond ((endp x) (reverse acc))
        (t (pairlis$-tailrec (cdr x) (cdr y) (cons (cons (car x) (car y)) acc)))))

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

  (declare (xargs :guard (and (true-listp x)
                              (true-listp y))
                  :verify-guards nil))
  (mbe :logic
       (cond ((endp x) nil)
             (t (cons (cons (car x) (car y))
                      (pairlis$ (cdr x) (cdr y)))))
       :exec
       (pairlis$-tailrec x y nil)))

(defthm pairlis$-tailrec-is-pairlis$
  (implies (true-listp acc)
           (equal (pairlis$-tailrec x y acc)
                  (revappend acc (pairlis$ x y)))))

(verify-guards pairlis$)

; Set-difference$

(defun-with-guard-check set-difference-eq-exec (l1 l2)
  (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-with-guard-check set-difference-eql-exec (l1 l2)
  (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))
  (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))))

(defconst *window-descriptions*

; See the Essay on Inhibited Output and the Illusion of Windows.

; If you change this list, also consider changing the value of INHIBIT in
; distributed books files Makefile-generic and build/make_cert.

;                  str clr top pop
  '((proof-tree    "0" t   t   nil)
;   (rewrite-state "1" t   nil nil)
;   (frame         "2" t   t   t)
    (error         "3" t   t   t)
    (warning!      "3" t   t   t)
    (warning       "3" t   t   t)
    (observation   "3" t   t   t)
    (prove         "4" nil nil nil)
    (event         "4" nil nil nil)
    (summary       "4" nil nil nil)
;   (chronology    "5" t   nil nil)
    (proof-builder "6" nil nil nil)
    (history       "t" t   t   t)
    (temporary     "t" t   t   t)
    (query         "q" t   t   t)))

(defconst *valid-output-names*

; If you change this list, also consider changing the value of INHIBIT in
; distributed books files Makefile-generic and build/make_cert.

  (set-difference-eq (strip-cars *window-descriptions*)
                     '(TEMPORARY QUERY)))

#+acl2-loop-only
(defun listp (x)
  (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

; Errors are normally not part of the summary.  However, for encapsulate and
; progn (and progn!), they are.

           errors))

(defmacro with-evisc-tuple (form &key ; from *evisc-tuple-sites*
                                 (term 'nil termp)
                                 (ld 'nil ldp)
                                 (abbrev 'nil abbrevp)
                                 (gag-mode 'nil gag-modep))

; Unlike without-evisc, form must return an error triple.

  `(state-global-let*
    (,@(and termp `((term-evisc-tuple (term-evisc-tuple nil state)
                                      set-term-evisc-tuple-state)))
     ,@(and ldp `((ld-evisc-tuple (ld-evisc-tuple state)
                                  set-ld-evisc-tuple-state)))
     ,@(and abbrevp `((abbrev-evisc-tuple (abbrev-evisc-tuple state)
                                          set-abbrev-evisc-tuple-state)))
     ,@(and gag-modep `((gag-mode-evisc-tuple (gag-mode-evisc-tuple state)
                                              set-gag-mode-evisc-tuple-state))))
    (er-progn
     ,@(and termp `((set-term-evisc-tuple ,term state)))
     ,@(and ldp `((set-ld-evisc-tuple ,ld state)))
     ,@(and abbrevp `((set-abbrev-evisc-tuple ,abbrev state)))
     ,@(and gag-modep `((set-gag-mode-evisc-tuple ,gag-mode state)))
     ,form)))

(defun with-output-fn (ctx args off on gag-mode off-on-p gag-p stack
                           summary summary-p evisc evisc-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 evisc evisc-p))
           (t (illegal ctx
                       illegal-value-string
                       (list (cons #\0 (cadr args))
                             (cons #\1 :gag-mode))))))
         ((eq (car args) :evisc) ; we leave it to without-evisc to check syntax
          (with-output-fn ctx (cddr args) off on gag-mode off-on-p gag-p
                            stack summary summary-p (cadr args) t))
         ((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 evisc evisc-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
                                 evisc evisc-p))))
         ((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 evisc evisc-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
                                                 evisc evisc-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
    (let ((form
           `(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)))))
      (cond (evisc-p `(with-evisc-tuple ,form ,@evisc))
            (t form))))))

#+acl2-loop-only
(defun last (l)
  (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)
         (revappend ac nil))
        (t (first-n-ac (1- i) (cdr l) (cons (car l) ac)))))

(defthm true-listp-first-n-ac-type-prescription
  (implies (true-listp ac)
           (true-listp (first-n-ac i l ac)))
  :rule-classes :type-prescription)

(defun take (n l)
  (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
; discovered that at least in CCL, the looping stops in that case when l is
; empty.

                       collect (pop l))))
  (first-n-ac n l nil))

(defthm true-listp-take

; This rule was not needed until we added verify-termination-boot-strap for
; first-n-ac and take.

  (true-listp (take n l))
  :rule-classes :type-prescription)

#+acl2-loop-only
(defun butlast (lst n)
  (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))))

(defmacro with-output! (&rest args)
  `(if (eq (ld-skip-proofsp state) 'include-book)
       ,(car (last args))
     ,(let ((val (with-output-fn 'with-output
                                 args nil nil nil nil nil nil nil nil nil nil)))
        (or val
            (illegal 'with-output
                     "Macroexpansion of ~q0 failed."
                     (list (cons #\0 (cons 'with-output args))))))))

#-acl2-loop-only
(defmacro with-output (&rest args)
  (car (last args)))

#+acl2-loop-only
(defmacro with-output (&rest args)
  `(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 ctx)
  (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)
                           (ctx ,ctx))
                       (cond (check
                              (cond
                               ((check-vars-not-free
                                 (check)
                                 ,form)
                                :passed)
                               ((tilde-@p check)
                                (er hard ctx
                                    "Assertion failed:~%~@0~|"
                                    check))
                               (t
                                (er hard ctx
                                    "Assertion failed on form:~%~x0~|"
                                    ',form))))
                             (t ,form)))))
               `(state-global-let*
                 ((safe-mode (not (f-get-global 'boot-strap-flg state))))
                 (value ,form))))))

#+acl2-loop-only
(defmacro value-triple (form &key on-skip-proofs check (ctx ''value-triple))
  (value-triple-fn form on-skip-proofs check ctx))

(defmacro assert-event (form &key on-skip-proofs msg)
  (declare (xargs :guard (booleanp on-skip-proofs)))
  `(value-triple ,form
                 :on-skip-proofs ,on-skip-proofs
                 :check ,(or msg t)
                 :ctx 'assert-event))

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

(defun keyword-value-listp (l)
  (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)
  (declare (xargs :guard (keyword-value-listp l)))
  (cond ((endp l) nil)
        ((eq key (car l)) l)
        (t (assoc-keyword key (cddr l)))))

(defun program-declared-p2 (dcls)
  (declare (xargs :guard t))
  (cond ((atom dcls) nil)
        ((and (consp (car dcls))
              (eq (caar dcls) 'xargs)
              (keyword-value-listp (cdr (car dcls)))
              (eq (cadr (assoc-keyword :mode (cdr (car dcls))))
                  :program))
         t)
        (t (program-declared-p2 (cdr dcls)))))

(defun program-declared-p1 (lst)
  (declare (xargs :guard t))
  (cond ((atom lst) nil)
        ((and (consp (car lst))
              (eq (caar lst) 'declare))
         (or (program-declared-p2 (cdar lst))
             (program-declared-p1 (cdr lst))))
        (t (program-declared-p1 (cdr lst)))))

(defun program-declared-p (def)

; Def is a definition with the initial DEFUN or DEFUND stripped off.  We return
; t if the declarations in def are minimally well-formed and there is an xargs
; declaration of :mode :program.

  (declare (xargs :guard (true-listp def)))
  (program-declared-p1 (butlast (cddr def) 1)))

(defun true-list-listp (x)
  (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 some-program-declared-p (defs)
  (declare (xargs :guard (true-list-listp defs)))
  (cond ((endp defs) nil)
        (t (or (program-declared-p (car defs))
               (some-program-declared-p (cdr defs))))))

#+acl2-loop-only
(defmacro mutual-recursion (&whole event-form &rest rst)
  (declare (xargs :guard (mutual-recursion-guardp rst)))
  (let ((rst (update-mutual-recursion-for-defun-nx rst)))
    (let ((defs (strip-cdrs rst)))
      (let ((form (list 'defuns-fn
                        (list 'quote defs)
                        'state
                        (list 'quote event-form)
                        #+:non-standard-analysis ; std-p
                        nil)))
        (cond
         ((and (assoc-eq 'defund rst)
               (not (some-program-declared-p defs)))
          (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)
  (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-with-guard-check add-to-set-eq-exec (x lst)
  (if (symbolp x)
      (true-listp lst)
    (symbol-listp lst))
  (cond ((member-eq x lst) lst)
        (t (cons x lst))))

(defun-with-guard-check add-to-set-eql-exec (x lst)
  (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))
  (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)))
(defconst *2* (quote (quote 2)))

(defun kwote (x)
  (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)
  (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 remedy 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-with-guard-check intersectp-eq-exec (x y)
  (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-with-guard-check intersectp-eql-exec (x y)
  (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))
  (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 warning$ (ctx summary str+ &rest fmt-args)

; Warning: Keep this in sync with warning$-cw1.

; Note: This macro was originally defined in basis-a.lisp, but was moved
; forward after *acl2-files* was changed so that "hons-raw" occurs before
; "basis-a".

; A typical use of this macro might be:
; (warning$ ctx "Loops" "The :REWRITE rule ~x0 loops forever." name) or
; (warning$ ctx nil "The :REWRITE rule ~x0 loops forever." name).
; If the second argument is wrapped in a one-element list, as in
; (warning$ ctx ("Loops") "The :REWRITE rule ~x0 loops forever." name),
; then that argument is quoted, and no check will be made for whether the
; warning is disabled, presumably because we are in a context where we know the
; warning is enabled.

  (list 'warning1
        ctx

; We seem to have seen a GCL 2.6.7 compiler bug, laying down bogus calls of
; load-time-value, when replacing (consp (cadr args)) with (and (consp (cadr
; args)) (stringp (car (cadr args)))).  But it seems fine to have the semantics
; of warning$ be that conses are quoted in the second argument position.

        (if (consp summary)
            (kwote summary)
          summary)
        str+
        (make-fmt-bindings '(#\0 #\1 #\2 #\3 #\4
                             #\5 #\6 #\7 #\8 #\9)
                           fmt-args)
        'state))

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

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

; Warning: We actually handle this macro directly in translate11, in case that
; is an efficiency win.  Keep this macro and that part of translate11 in sync.

; 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)))
  (cond ((null vars) form) ; optimization, perhaps needless
        (t `(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.

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

  (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)
  (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-with-guard-check position-ac-eq-exec (item lst acc)
  (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-with-guard-check position-ac-eql-exec (item lst acc)
  (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-with-guard-check position-eq-exec (item lst)
  (and (true-listp lst)
       (or (symbolp item)
           (symbol-listp lst)))
  (position-ac-eq-exec item lst 0))

(defun-with-guard-check position-eql-exec (item lst)
  (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))
  (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)
  (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 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)
  (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!

; 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 "Historical Comment from Ruben Gamboa" comment in the definition of floor
; for an explanation of why we need this function.

  (floor x 1))

#+acl2-loop-only
(progn

(defun floor (i j)

;; Historical Comment from Ruben Gamboa:
;; 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.

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

;; Historical Comment from Ruben Gamboa:
;; 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)
  (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)))))
  )

;; Historical Comment from Ruben Gamboa:
;; Another function  modified to fit in the reals, using floor1.

(defun truncate (i j)
  (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)))))
  )

;; Historical Comment from Ruben Gamboa:
;; Another function  modified to fit in the reals, using floor1.

(defun round (i j)
  (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)))))))))
  )

;; Historical Comment from Ruben Gamboa:
;; 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)
  (declare (xargs :guard (and (real/rationalp x)
                              (real/rationalp y)
                              (not (eql y 0)))))
  (- x (* (floor x y) y)))

(defun rem (x y)
  (declare (xargs :guard (and (real/rationalp x)
                              (real/rationalp y)
                              (not (eql y 0)))))
  (- x (* (truncate x y) y)))

(defun evenp (x)
  (declare (xargs :guard (integerp x)))
  (integerp (* x (/ 2))))

(defun oddp (x)
  (declare (xargs :guard (integerp x)))
  (not (evenp x)))

(defun zerop (x)
  (declare (xargs :mode :logic
                  :guard (acl2-numberp x)))
  (eql x 0))

;; Historical Comment from Ruben Gamboa:
;; Only the guard changed here.

(defun plusp (x)
  (declare (xargs :mode :logic
                  :guard (real/rationalp x)))
  (> x 0))

;; Historical Comment from Ruben Gamboa:
;; Only the guard changed here.

(defun minusp (x)
  (declare (xargs :mode :logic
                  :guard (real/rationalp x)))
  (< x 0))

;; Historical Comment from Ruben Gamboa:
;; Only the guard changed here.

(defun min (x y)
  (declare (xargs :guard (and (real/rationalp x)
                              (real/rationalp y))))
  (if (< x y)
      x
    y))

;; Historical Comment from Ruben Gamboa:
;; Only the guard changed here.

(defun max (x y)
  (declare (xargs :guard (and (real/rationalp x)
                              (real/rationalp y))))
  (if (> x y)
      x
    y))

;; Historical Comment from Ruben Gamboa:
;; Only the guard changed here.  The doc string below says that
;; abs must not be used on complex arguments, since that could result
;; in a non-ACL2 object.

(defun abs (x)
  (declare (xargs :guard (real/rationalp x)))

  (if (minusp x) (- x) x))

(defun signum (x)
  (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)
  (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.

)

(encapsulate
  ()
  (local (defthm hack
           (implies (integerp i)
                    (equal (+ -1 1 i)
                           i))))
  (local
   (defthm standard-string-p1-forward-to-standard-char-p
     (implies (and (standard-string-p1 s n) ; n is free
                   (stringp s)
                   (integerp n)
                   (natp i)
                   (< i n))
              (standard-char-p (nth i (coerce s 'list))))))

  (verify-termination-boot-strap string-equal1))

; The following was probably formerly needed for the event just above,
; (verify-termination-boot-strap string-equal1).  It's no longer necessary for
; that but it's a nice rule nonetheless.
(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-equal)
(verify-termination-boot-strap assoc-string-equal)
(verify-termination-boot-strap member-string-equal)
(verify-termination-boot-strap xxxjoin)

#+acl2-loop-only
(progn

(defun expt (r i)

; 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)
  (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)
  (declare (xargs :guard (and (integerp n)
                              (<= 0 n)
                              (true-listp l))))
  (if (zp n)
      l
    (nthcdr (+ n -1) (cdr l))))

(defthm true-listp-nthcdr-type-prescription
  (implies (true-listp x)
           (true-listp (nthcdr n x)))
  :rule-classes :type-prescription)

(defun logbitp (i j)
  (declare (xargs :guard (and (integerp j)
                              (integerp i)
                              (>= i 0))
                  :mode :program))
  (oddp (floor (ifix j) (expt 2 (nfix i)))))

(defun ash (i c)
  (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)

;; Historical Comment from Ruben Gamboa:
;; 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)

(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)
  (declare (xargs :guard (and (characterp x) (characterp y))))
  (< (char-code x) (char-code y)))

#+acl2-loop-only
(defun char> (x y)
  (declare (xargs :guard (and (characterp x) (characterp y))))
  (> (char-code x) (char-code y)))

#+acl2-loop-only
(defun char<= (x y)
  (declare (xargs :guard (and (characterp x) (characterp y))))
  (<= (char-code x) (char-code y)))

#+acl2-loop-only
(defun char>= (x y)
  (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)
  (declare (xargs :guard (and (stringp str1)
                              (stringp str2))))
  (string<-l (coerce str1 'list)
             (coerce str2 'list)
             0))

#+acl2-loop-only
(defun string> (str1 str2)
  (declare (xargs :guard (and (stringp str1)
                              (stringp str2))))
  (string< str2 str1))

#+acl2-loop-only
(defun string<= (str1 str2)
  (declare (xargs :guard (and (stringp str1)
                              (stringp str2))))
  (if (equal str1 str2)
      (length str1)
    (string< str1 str2)))

#+acl2-loop-only
(defun string>= (str1 str2)
  (declare (xargs :guard (and (stringp str1)
                              (stringp str2))))
  (if (equal str1 str2)
      (length str1)
    (string> str1 str2)))

(defun symbol-< (x y)
  (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)
    (revappend acc nil))
   ((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)
  (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)))

(defthm stringp-substitute-type-prescription
  (implies (stringp seq)
           (stringp (substitute new old seq)))
  :rule-classes :type-prescription)

(defthm true-listp-substitute-type-prescription
  (implies (not (stringp seq))
           (true-listp (substitute new old seq)))
  :rule-classes :type-prescription)

#+acl2-loop-only
(defun sublis (alist tree)
  (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)
  (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.

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

; Essay on Unwind-Protect

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

; Warning: Keep in sync with acl2-unwind-protect-raw.

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

; We optimize a bit, only for #+acl2-loop-only (though we could do so for
; both), to speed up translation of acl2-unwind-protect calls in the rather
; common case that cleanup1 and cleanup2 are the same form.

  #+acl2-loop-only
  (declare (ignore expl))
  #+acl2-loop-only
  (let ((cleanup1-form
         `(pprogn (check-vars-not-free
                   (acl2-unwind-protect-erp acl2-unwind-protect-val)
                   ,cleanup1)
                  (mv acl2-unwind-protect-erp
                      acl2-unwind-protect-val
                      state))))
    `(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
         ((equal cleanup1 cleanup2)
          cleanup1-form)
         (t `(cond
              (acl2-unwind-protect-erp
               ,cleanup1-form)
              (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 (gensym)))
    `(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
; (note: this is from before temp was a gensym):
;
; 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 Essay on Unwind-Protect.  There are some additional
; comments in the code for EV.

(defmacro when-logic (str x)

; It is IMPERATIVE that this is ONLY used when its second argument is a form
; that evaluates to an error triple.  Keep this function in sync with
; boot-translate.

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

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

; Note: It is tempting to remove the doc argument, as we have done for many
; other event forms after Version_7.1.  However, all defpkg calls with non-nil
; book-path or hidden-p would need to be revisited, both in the regression
; suite and in every user application of ACL2 outside the regression suite.
; That doesn't seem worth the trouble.

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

#+acl2-loop-only
(defmacro defun (&whole event-form &rest def)

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

  (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)
  (list 'defuns-fn
        (list 'quote def-lst)
        'state
        (list 'quote event-form)
        t))

(defmacro verify-termination (&rest lst)
  `(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)

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

 (list 'verify-guards-fn
       (list 'quote name)
       'state
       (list 'quote hints)
       (list 'quote otf-flg)
       (list 'quote guard-debug)
       (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, simultaneously 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.

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

#+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".

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

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

; Warning: See the Important Boot-Strapping Invariants before modifying!

  (list 'defthm-fn
        (list 'quote name)
        (list 'quote term)
        'state
        (list 'quote rule-classes)
        (list 'quote instructions)
        (list 'quote hints)
        (list 'quote otf-flg)
        (list 'quote event-form)
        #+:non-standard-analysis ; std-p
        nil))

#+acl2-loop-only
(defmacro defthmd (&whole event-form
                          name term
                          &rest rst)
  (declare (xargs :guard t) (ignore term rst))
  (list 'with-output
        :stack :push :off :all
        (list 'progn
              (list 'with-output
                    :stack :pop
                    (cons 'defthm (cdr event-form)))
              (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)
  (list 'defthm-fn
        (list 'quote name)
        (list 'quote term)
        'state
        (list 'quote rule-classes)
        (list 'quote instructions)
        (list 'quote hints)
        (list 'quote otf-flg)
        (list 'quote event-form)
        t))

#+acl2-loop-only
(defmacro defaxiom (&whole event-form name term
                    &key (rule-classes '(:REWRITE)))

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

#+acl2-loop-only
(defmacro deflabel (&whole event-form name)

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

  (list 'deflabel-fn
        (list 'quote name)
        'state
        (list 'quote event-form)))

#+acl2-loop-only
(defmacro deftheory (&whole event-form name expr &key redundant-okp ctx)

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

  (list 'deftheory-fn
        (list 'quote name)
        (list 'quote expr)
        'state
        (list 'quote redundant-okp)
        (list 'quote ctx)
        (list 'quote event-form)))

(defmacro defthy (name &rest args)
  `(deftheory ,name ,@args :redundant-okp t :ctx (defthy . ,name)))

(defmacro deftheory-static (name theory)
  `(make-event
    (let ((world (w state)))
      (declare (ignorable world))
      (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".

  (list 'defstobj-fn
        (list 'quote name)
        (list 'quote args)
        'state
        (list 'quote event-form)))

#+acl2-loop-only
(defmacro in-theory (&whole event-form expr)

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

  (list 'in-theory-fn
        (list 'quote expr)
        'state
        (list 'quote event-form)))

#+acl2-loop-only
(defmacro in-arithmetic-theory (&whole event-form expr)

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

  (list 'in-arithmetic-theory-fn
        (list 'quote expr)
        'state
        (list 'quote event-form)))

#+acl2-loop-only
(defmacro regenerate-tau-database (&whole event-form)

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

  (list 'regenerate-tau-database-fn
        'state
        (list 'quote event-form)))

#+acl2-loop-only
(defmacro push-untouchable (&whole event-form name fn-p)

; Warning: See the Important Boot-Strapping Invariants before modifying!

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

  (declare (xargs :guard (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 event-form)))

#+acl2-loop-only
(defmacro remove-untouchable (&whole event-form name fn-p)

; Warning: See the Important Boot-Strapping Invariants before modifying!

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

  (declare (xargs :guard (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 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".

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

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

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

  (list 'encapsulate-fn
        (list 'quote signatures)
        (list 'quote cmd-lst)
        'state
        (list 'quote event-form)))

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

; Warning: See the Important Boot-Strapping Invariants before modifying!

; Rather than specify a guard, we call chk-include-book-inputs.

  (list 'include-book-fn
        (list 'quote user-book-name)
        'state
        (list 'quote load-compiled-file)
        (list 'quote nil)
        (list 'quote uncertified-okp)
        (list 'quote defaxioms-okp)
        (list 'quote skip-proofs-okp)
        (list 'quote ttags)
        (list 'quote dir)
        (list 'quote event-form)))

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

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

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

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

  (list 'defchoose-fn
        (list 'quote def)
        'state
        (list 'quote event-form)))

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

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

(defun putprop (symb key value world-alist)
  (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-with-guard-check delete-assoc-eq-exec (key alist)
  (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-with-guard-check delete-assoc-eql-exec (key alist)
  (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))
  (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))))
  (getpropc var 'global-value
            '(:error "GLOBAL-VAL didn't find a value.  Initialize this ~
                     symbol in PRIMORDIAL-WORLD-GLOBALS.")
            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 (getpropc sym 'formals t 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))))

;; Historical Comment from Ruben Gamboa:
;; 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 (getpropc (cadr x) 'formals nil 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

;; Historical Comment from Ruben Gamboa:
;; 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)))))))))

)

(defun the-check (guard x y)

; See call of (set-guard-msg the-check ...) later in the sources.

  (declare (xargs :guard guard))
  (declare (ignore x guard))
  y)

(defun the-fn (x y)
  (declare (xargs :guard (translate-declaration-to-guard x 'var nil)

; Warning: Keep this in sync with the-fn-for-*1*.

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

; Warning: Keep this in sync with the-for-*1*.

  (declare (xargs :guard (translate-declaration-to-guard x 'var nil)))
  (the-fn x y))

(defun the-check-for-*1* (guard x y var)

; See call of (set-guard-msg the-check-for-*1* ...) later in the sources.

  (declare (xargs :guard guard))
  (declare (ignore x guard var))
  y)

(defun the-fn-for-*1* (x y)

; Warning: Keep this in sync with the-fn.

  (declare (xargs :guard (and (symbolp y)
                              (translate-declaration-to-guard x y nil))
                  :mode :program))
  (let ((guard (and (symbolp y)
                    (translate-declaration-to-guard x y nil))))
    `(the-check-for-*1* ,guard ',x ,y ',y)))

(defmacro the-for-*1* (x y)

; Warning: Keep this in sync with THE.

  (declare (xargs :guard (and (symbolp y)
                              (translate-declaration-to-guard x y nil))))
  (the-fn-for-*1* 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 speaking, 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 header, 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: Unsurprisingly, 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)

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

(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 ; avoid sort-symbol-listp for toothbrush
         (remove-adjacent-duplicates-eq (sort (copy-list imports) 'symbol-<))))
    (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*)
             (not-boot-strap (not (f-get-global 'boot-strap-flg *the-live-state*))))
        (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*))
                                 (getpropc 'include-book-path 'global-value
                                           nil
                                           (w *the-live-state*))))
                           :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 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 shortcut 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-make-three-packages 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$)))))

(defun array1p (name l)
  (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)
  (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))))
  #+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)
  (declare (xargs :guard (or (array1p name l) (array2p name l))))
  (cadr (assoc-keyword :dimensions
                       (cdr (header name l)))))

(defun maximum-length (name l)
  (declare (xargs :guard (or (array1p name l) (array2p name l))))
  (cadr (assoc-keyword :maximum-length (cdr (header name l)))))

(defun default (name l)
  (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)
  #+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)

; In spite of the raw Lisp code in this definition, as well as in other
; definitions pertaining to ACL2 arrays, we do not see a way that ill-guarded
; calls of the raw Lisp code for these functions (by way of top-level :program
; mode wrappers) could violate invariants that we need to maintain.  If that
; changes, see initialize-invariant-risk.

; 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 constant *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-structure, 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-structure
; 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)
  #+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)
  #+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)
  #+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)
  #+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)
  (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)
  (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)
  (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).

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

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

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

(defun update-nth (key val l)
  (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 minimum-negative-32-bit-integer ()
  (+ (- *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 (minimum-negative-32-bit-integer))))

(defthm 32-bit-integerp-forward-to-integerp
  (implies (32-bit-integerp x)
           (integerp x))
  :rule-classes :forward-chaining)

(defun acl2-number-listp (l)
  (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)
  (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)

;; Historical Comment from Ruben Gamboa:
;; 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))))))

;; Historical Comment from Ruben Gamboa:
;; 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)
  (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)
  (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)

;; Historical Comment from Ruben Gamboa:
;; 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*

; Warning: Do not assume that every symbol in this list is a function symbol.
; While that is more or less our intention, we have included some symbols that
; are only function symbols when feature acl2-par is present (indeed, all those
; below marked with a comment "for #+acl2-par" except
; set-waterfall-parallelism-fn).

; 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*
    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-body ; *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
    #+acl2-infix fmt-ppr
    acl2-raw-eval ; eval
    pstack-fn ; *pstk-stack*
    dmr-start-fn ; dmr-start-fn-raw
    ev-fncall-meta ; *metafunction-context*
    ld-loop ; *ld-level*
    print-summary ; dmr-flush
; WARNING: See chk-logic-subfunctions before removing ev from this list!
    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-msg
    w-of-any-state ; live-state-p
    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
    #+acl2-infix flpr
    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
    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-state
    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
    fix-stobj-array-type
    set-gc-threshold$-fn
    certify-book-finish-complete
    chk-absstobj-invariants
    get-stobj-creator
    iprint-oracle-updates
    iprint-oracle-updates@par
    ld-fix-command
    update-enabled-structure-array
    update-enabled-structure
    ))

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

; Might as well add additional ones below:

    random$
    throw-nonexec-error
    gc$-fn
    set-compiler-enabled
    good-bye-fn ; exit-lisp
    take
    file-write-date$
    print-call-history
    set-debugger-enable-fn ; system::*break-enable* and *debugger-hook*
    break$ ; break
    prin1$ prin1-with-slashes
    member-equal assoc-equal subsetp-equal
    rassoc-equal remove-equal position-equal
    maybe-finish-output$
    symbol-in-current-package-p
    sleep

; 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-CLEAR!
    HONS-WASH HONS-WASH!
    FAST-ALIST-CLEAN FAST-ALIST-FORK HONS-EQUAL-LITE
    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
    FAST-ALIST-CLEAN! FAST-ALIST-FORK! MEMOIZE-SUMMARY CLEAR-MEMOIZE-STATISTICS
    make-fast-alist
    serialize-read-fn serialize-write-fn
    read-object-suppress
    read-object-with-case
    print-object$-preserving-case
    assign-lock
    throw-or-attach-call
    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+
    sys-call* ; system-call+

    canonical-pathname ; under dependent clause-processor

    concrete-badge-userfn
    concrete-apply$-userfn

    ev-fncall-w-guard1

; 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
    set-gc-strategy-fn gc-strategy
    read-file-into-string2
    cons-with-hint
    file-length$
    delete-file$
    set-bad-lisp-consp-memoize
    #-acl2-devel apply$-lambda
    apply$-prim
  ))

(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 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 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
    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
    push-gframe defthmd f-get-global

; 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 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!
    with-guard-checking-event
    when-pass-2
    ))

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

  #+acl2-loop-only
  form
  #-acl2-loop-only
  `(let ((state *the-live-state*))
     ,form))

(defun init-iprint-ar (hard-bound enabledp)

; Warning: Consider also calling init-iprint-fal when calling this function.

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

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

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

; This variable is not (as of this writing) used in our own sources.  But it
; could be convenient for users.  In particular, it is used (starting
; mid-October, 2014) by the XDOC system to find the location of the ACL2
; sources graphics/ subdirectory.

                      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 8.0

; 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 in .cert files.

; 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 8.0"
                                #+non-standard-analysis
                                "(r)"
                                #+(and mcl (not ccl))
                                "(mcl)"))
    (acl2-world-alist . nil)
    (acl2p-checkpoints-for-summary . nil)
    (axiomsp . nil)
    (bddnotes . nil)
    (book-hash-alistp . nil) ; set in LP
    (boot-strap-flg .

; Keep this state global in sync with world global of the same name.  We expect
; both this and the corresponding world global both to be constant, except when
; both are changed from t to nil during evaluation of exit-boot-strap-mode.
; The state global can be useful for avoiding potentially slow calls of
; getprop, for example as noticed by Sol Swords in function make-event-fn2.
; While we could probably fix many or most such calls by suitable binding of
; the world global, it seems simple and reasonable to record the value in this
; corresponding state global.

                    t)
    (cert-data . 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-invariant-risk . :WARNING)
    (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)
    (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)
    (ignore-cert-files . nil)
    (illegal-to-certify-message . nil)
    (in-local-flg . nil)
    (in-prove-flg . nil)
    (in-verify-flg . nil) ; value can be set to the ld-level
    (including-uncertified-p . nil) ; valid only during include-book
    #+acl2-infix (infixp . nil) ; See the Essay on Infix below
    (inhibit-er-hard . nil)
    (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-fal . nil)
    (iprint-hard-bound . ,*iprint-hard-bound-default*)
    (iprint-soft-bound . ,*iprint-soft-bound-default*)
    (keep-tmp-files . nil)
    (last-event-data . nil)
    (last-make-event-expansion . 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)
    (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)
    (port-file-enabled . t)
    (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-escape . t)
    (print-gv-defaults . nil)
    (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)
    (protect-memoize-statistics . nil)
    (raw-arity-alist . nil)
    (raw-guard-warningp . nil)
    (raw-include-book-dir!-alist . :ignore)
    (raw-include-book-dir-alist . :ignore)
    (raw-proof-format . nil)
    (raw-warning-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) ; potentially set in LP
    (saved-output-p . nil)
    (saved-output-reversed . nil)
    (saved-output-token-lst . nil)
    (script-mode . 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
    (skip-reset-prehistory . nil) ; non-nil skips (reset-prehistory nil)
    (slow-apply$-action . t)
    (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)
    (verify-termination-on-raw-program-okp . nil)
    (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-bookdata . nil) ; see maybe-write-bookdata
    (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

; Note: As of late July 2017, infix printing is no longer supported.  As a
; result, it is now possible to execute some forms in safe-mode that were
; formerly prohibited; for example, evaluation of the form

;   (defconst *c* (fms-to-string "abc~x0" (list (cons #\0 (expt 2 4)))))

; formerly failed with an error saying that a call of flpr had been made in
; safe-mode, which was illegal because flpr had raw Lisp code -- which is no
; longer the case.  Note, however, that we have left the infix-printing code in
; place for the case #+acl2-infix, in case it becomes desirable to restore it
; in the future.  Indeed, if you build ACL2 with :acl2-info pushed to
; *features*, you may be able to do infix printing.  Warning: In that case,
; some user books may fail, since more functions would have raw Lisp code,
; hence would be disqualified from evaluation in safe-mode.  Here is an
; example:

;   (defconst *c* (fms-to-string "abc~x0" (list (cons #\0 (expt 2 4)))))

; Below is the rest of the 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.

; It is common to bind state global infixp to nil, so we create the following
; macro for that purpose.

(defmacro with-infixp-nil (form)
  #+acl2-infix
  `(state-global-let* ((infixp nil))
                      ,form)
  #-acl2-infix
  form)

(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
        (getpropc 'acl2-defaults-table 'table-alist nil
                  (cdr (assoc 'current-acl2-world (global-table x)))))
       (timer-alistp (cdr (assoc 'timer-alist (global-table x))))
       (known-package-alistp
        (getpropc 'known-package-alist 'global-value nil
                  (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
             (getpropc 'acl2-defaults-table 'table-alist nil
                       (cdr (assoc 'current-acl2-world (nth 2 x)))))
            (timer-alistp (cdr (assoc 'timer-alist (nth 2 x))))
            (known-package-alistp
             (getpropc 'known-package-alist 'global-value nil
                       (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)
  #-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.~|~%")
    (ld-user-stobjs-modified-warning . nil)))

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

  (declare (xargs :guard (and (state-global-let*-bindings-p bindings)
                              (no-duplicatesp-equal (strip-cars bindings)))))

  (let ((cleanup `(pprogn
                   ,@(state-global-let*-cleanup bindings 0)
                   state)))
    `(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))
         ,cleanup
         ,cleanup)))))

#-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 acl2-unwind-protect-raw (expl body cleanup)

; Warning: Keep in sync with the #-acl2-loop-only code for acl2-unwind-protect.
; We omit comments here; see acl2-unwind-protect.

; This variant of (acl2-unwind-protect expl body cleanup cleanup) is only for
; use in raw Lisp.  It too should be called from inside the ACL2 loop (also see
; push-car), that is, when *acl2-unwind-protect-stack* is non-nil.

  (let ((temp (gensym)))
    `(let* ((,temp (cons ,expl (function (lambda nil ,cleanup)))))
       (unless *acl2-unwind-protect-stack*
         (error "Attempted to execute acl2-unwind-protect-raw in raw Lisp!"))
       (cond (,temp
              (push-car ,temp
                        *acl2-unwind-protect-stack*
                        'acl2-unwind-protect)))
       (our-multiple-value-prog1
        ,body
        (cond (,temp (acl2-unwind -1 ,temp)))
        (protect-mv ,cleanup)
        (cond (,temp (pop (car *acl2-unwind-protect-stack*))))))))

#-acl2-loop-only
(defmacro state-free-global-let* (bindings body)

; This variant of state-global-let* is only for use in raw Lisp.  See also
; state-free-global-let*-safe for a safer, but probably less efficient,
; alternative.  That alternative must be used inside the ACL2 loop when any
; call of state-global-let* (or similar call of acl2-unwind-protect could bind
; a variable of bindings during the evaluation of body.  Otherwise, the wrong
; value will be stored in *acl2-unwind-protect-stack*, causing the wrong value
; to be restored after an abort during that evaluation.

; WARNING: If this macro is used when accessible in body, then the value read
; for a variable bound in bindings may not be justified in the logic.  So state
; should not be accessible in body unless you (think you) know what you are
; doing!

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

#-acl2-loop-only
(defmacro state-free-global-let*-safe (bindings body)

; Warning: Keep in sync with the #-acl2-loop-only code for acl2-unwind-protect.
; We omit comments here; see state-global-let*.

; This variant of state-global-let* is only for use in raw Lisp.  See also
; state-free-global-let* for a more efficient alternative that can be used in
; some situations.

; WARNING: If this macro is used when accessible in body, then the value read
; for a variable bound in bindings may not be justified in the logic.  So state
; should not be accessible in body unless you (think you) know what you are
; doing!

  `(if #-acl2-par *acl2-unwind-protect-stack* #+acl2-par nil
       (let* ((state *the-live-state*)
              (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-raw
          "state-free-global-let*"
          (check-vars-not-free (state-global-let*-cleanup-lst) ,body)
          (progn ,@(state-global-let*-cleanup bindings 0))))
       (state-free-global-let* ,bindings ,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)
  (declare (xargs :guard t))
  (and (integerp bits)
       (< 0 bits)
       (let ((y ; proof fails for mbe with :exec = (ash 1 (1- bits))
              (expt 2 (1- bits))))
         (integer-range-p (- y) y x))))

(defun unsigned-byte-p (bits x)
  (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))
  (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)
  (cond
   ((null args)
    -1)
   ((null (cdr args))
    (car args))
   (t (xxxjoin 'binary-logand args))))

#+acl2-loop-only
(defmacro logeqv (&rest args)
  (cond
   ((null args)
    -1)
   ((null (cdr args))
    (car args))
   (t (xxxjoin 'binary-logeqv args))))

#+acl2-loop-only
(defmacro logior (&rest args)
  (cond
   ((null args)
    0)
   ((null (cdr args))
    (car args))
   (t (xxxjoin 'binary-logior args))))

#+acl2-loop-only
(defmacro logxor (&rest args)
  (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))).

  (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)
  (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)
  (declare (xargs :guard (and (integerp i)
                              (integerp j))))
  (logior (lognot i) j))

#+acl2-loop-only
(defun logorc2 (i j)
  (declare (xargs :guard (and (integerp i)
                              (integerp j))))
  (logior i (lognot j)))

#+acl2-loop-only
(defun logandc1 (i j)
  (declare (xargs :guard (and (integerp i)
                              (integerp j))))
  (logand (lognot i) j))

#+acl2-loop-only
(defun logandc2 (i j)
  (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)
  (declare (xargs :guard (and (integerp i)
                              (integerp j))))
  (lognot (logior i j)))

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

; p. 360 of CLtL2

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

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

(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)
  (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))
  (and (member print-base '(2 8 10 16))
       t))

(defun explode-nonnegative-integer (n print-base ans)
  (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-a.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))

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

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

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

(defun table-alist (name wrld)

; Return the named table as an alist.

  (declare (xargs :guard (and (symbolp name)
                              (plist-worldp wrld))))
  (getpropc name 'table-alist nil 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 needs to be removed"
              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))))))

(defun strict-symbol-<-sortedp (x)
  (declare (xargs :guard (symbol-listp x)))
  (cond ((or (endp x) (null (cdr x)))
         t)
        (t (and (symbol-< (car x) (cadr x))
                (strict-symbol-<-sortedp (cdr x))))))

(defmacro chk-ruler-extenders (x type ctx wrld)

; We check whether x is a legal value for ruler-extenders.  This is really two
; macros, depending on whether type is 'soft or 'hard.  If type is 'soft, then
; we return an error triple; otherwise we return an ordinary value but cause a
; hard error if x is illegal.  Moreover, if x is hard then we check that x is
; sorted.

  (declare (xargs :guard (member-eq type '(soft hard))))
  (let ((err-str "The proposed ruler-extenders is illegal because ~@0."))
    `(let ((ctx ,ctx)
           (err-str ,err-str)
           (x ,x))
       (let ((msg (ruler-extenders-msg x ,wrld)))
         (cond (msg ,(cond ((eq type 'soft) `(er soft ctx err-str msg))
                           (t `(illegal ctx err-str (list (cons #\0 msg))))))
               ,@(and (eq type 'hard)
                      `(((not (strict-symbol-<-sortedp x))
                         (illegal ctx err-str
                                  (list (cons #\0 "it is not sorted"))))))
               (t ,(cond ((eq type '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))

(defun include-book-dir-alist-entry-p (key val os)
  (declare (xargs :guard t))
  (and (keywordp key)
       (stringp val)
       (absolute-pathname-string-p val t os)))

(defun include-book-dir-alistp (x os)
  (declare (xargs :guard t))
  (cond ((atom x) (null x))
        (t (and (consp (car x))
                (include-book-dir-alist-entry-p (caar x) (cdar x) os)
                (include-book-dir-alistp (cdr x) os)))))

(defconst *check-invariant-risk-values*

; In the case of the acl2-defaults-table setting for :check-invariant-risk,
; :DEFAULT is also a legal value; but it is not included in the value of this
; constant.

  '(t nil :ERROR :WARNING))

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

(defun get-register-invariant-risk-world (wrld)
  (declare (xargs :guard
                  (and (plist-worldp wrld)
                       (alistp (table-alist 'acl2-defaults-table wrld)))))
  (let ((pair (assoc-eq :register-invariant-risk
                        (table-alist 'acl2-defaults-table wrld))))
    (cond (pair (cdr pair))
          (t ; default
           t))))

(table acl2-defaults-table nil nil

; Warning: If you add or delete a new key, 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 :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 (getpropc val 'formals t 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)))

        ((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)))
        ((eq key :check-invariant-risk)
         (or (eq val :CLEAR)
             (and (member-eq val *check-invariant-risk-values*)
                  (or val
                      (ttag world)
                      (illegal 'acl2-defaults-table
                               "An active trust tag is required for setting ~
                                the :check-invariant-risk key to nil in the ~
                                acl2-defaults-table."
                               nil)))))
        ((eq key :register-invariant-risk)
         (or (eq val t)
             (and (eq val nil)
                  (or (null (get-register-invariant-risk-world world))
                      (ttag world)
                      (illegal 'acl2-defaults-table
                               "An active trust tag is required for setting ~
                                the :register-invariant-risk key to nil in ~
                                the acl2-defaults-table."
                               nil)))))
        ((eq key :user)

; The :user key is reserved for users; the ACL2 system will not consult or
; modify it (except as part of general maintenance of the acl2-defaults-table).
; In order to support more than one use of this key, we insist that it's an
; alist; thus, one user could "own" one key of that alist, and a different user
; could own another, so that for example :user is bound to ((:k1 . val1) (:k2
; . val2)).

         (alistp val))
        (t nil)))

; (set-state-ok t)
(table acl2-defaults-table :state-ok t)

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

; There is special handling when #+allegro in princ$ and prin1$, which is why
; we avoid the following test for #+allegro.

  (when (int= print-base 16)
    (let ((*print-base* 16)
          (*print-radix* nil))
      (or (equal (prin1-to-string 10) "A")

; If we get here, a solution is simply to treat the underlying Lisp as we treat
; #+allegro in the raw Lisp code for princ$ and prin1$.

          (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)
  (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)
  (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 :DEFAULTS ~
            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)))))

#-acl2-loop-only
(defun print-number-base-16-upcase-digits (x stream)

; In base 16, in Allegro CL and (when *print-case* is :downcase) CMUCL, the
; function PRINC prints alphabetic digits in lower case, unlike other Lisps we
; have seen.  While that behavior 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 PRINC violates our axioms in those two host
; Lisp implementations.  Therefore, ACL2 built on these host Lisps prints
; radix-16 numbers without using the underlying lisp's PRINC function.  Thanks
; to David Margolies of Franz Inc. for passing along a remark from his
; colleague, which showed how to use format here.

  (assert (eql *print-base* 16)) ; for base <= 10, there's no need to call this
  (if *print-radix*
      (cond ((realp x)
             (format stream "#x~:@(~x~)" x))
            (t (format stream "#C(#x~:@(~x~) #x~:@(~x~))"
                       (realpart x) (imagpart x))))
    (format stream "~:@(~x~)" x)))

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

; 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)))
              #+acl2-print-number-base-16-upcase-digits
              (cond ((and (acl2-numberp x)
                          (> *print-base* 10))
                     (print-number-base-16-upcase-digits x stream))
                    (t (princ x stream)))
              #-acl2-print-number-base-16-upcase-digits
              (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.

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

; ACL2 is now (starting with Version_7.2) always hons-enabled.  But we keep
; this function around, as well as other code that supported builds that are
; not hons-enabled, just in case we want to restore the ability to create such
; builds.  Anyone who wants to do so should visit every occurrence of
; "hons-enabled" in these sources.  Indeed, there may be very little necessary,
; since we intend (at least for awhile) to leave the code in place that allows
; for hons-enabled builds.  However, some error messages (for example) may
; change, as in the "illegal to build ... non-ANSI" message in acl2-init.lisp.

  (declare (xargs :verify-guards nil ; wait for w
                  :guard (state-p state)))
  (global-val 'hons-enabled (w state)))

(defun set-serialize-character-fn (c system-p 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)))))))
  (let ((caller (if system-p
                    'serialize-character-system
                  'serialize-character)))
    (cond
     ((or (null c)
          (and (hons-enabledp state)
               (member c '(#\Y #\Z))))
      (if system-p
          (f-put-global 'serialize-character-system c state)
        (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 caller
                  "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."
                  caller))
             (t
              (er hard caller
                  "The first argument of a call of ~x0 must be ~v1.  The ~
                   argument ~x2 is thus illegal."
                  caller '(nil #\Y #\Z) c)))
       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)))))))
  (set-serialize-character-fn c nil state))

(defun set-serialize-character-system (c state)

; By putting the form (set-serialize-character-system nil state) into one's
; acl2-customization file, one can make .cert files and .port files (among
; others) human-readable.  For example:

; cd books ; \
; make basic \
; ACL2_CUSTOMIZATION=`pwd`/../acl2-customization-files/no-serialize.lisp

  (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)))))))
  (set-serialize-character-fn c t 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))

#-acl2-loop-only
(defmacro set-acl2-readtable-case (mode)
  (declare (ignore mode))
  #+gcl
  (if (fboundp 'system::set-readtable-case)
      '(setf (readtable-case *acl2-readtable*) :preserve)
    nil)
  #-gcl
  '(setf (readtable-case *acl2-readtable*) :preserve))

(defun print-object$-preserving-case (x channel state)

; Logically, this function is just print-object$.  Is it unsound to identify
; these functions, since they print differently?  We think not, because the
; only way to see what resides in a file is with the various ACL2 reading
; functions, which all use a file-clock.  See the discussion of "deus ex
; machina" in :doc current-package.

  (declare (xargs :guard (and (state-p state)
                              (eq (get-serialize-character state)

; It's not clear that it makes sense to print preserving case when doing
; serialize printing.  If that capability is needed we can address weakening the
; guard to match the guard of print-object$.

                                  nil)
                              (symbolp channel)
                              (open-output-channel-p channel
                                                     :object state))))
  #-acl2-loop-only
  (cond ((live-state-p state)
         (cond
          #+gcl
          ((not (fboundp 'system::set-readtable-case))
           (cerror "Use print-object$ instead"
                   "Sorry, but ~s is not supported in this older version of ~%~
                    GCL (because raw Lisp function ~s is undefined)."
                   'print-object$-preserving-case
                   'system::set-readtable-case))
          (t
           (return-from print-object$-preserving-case
             (let ((*acl2-readtable* (copy-readtable *acl2-readtable*)))
               (set-acl2-readtable-case :preserve)
               (print-object$ x channel state)))))))
  (print-object$ x 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
   #+acl2-infix
   ((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.

#+(and acl2-infix (not 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)))))

#-acl2-loop-only
(defvar *read-file-alist*

; This alist associates each key, an ACL2 filename (see the Essay on
; Pathnames), with both a file-clock and its file-write-date.  Recall that the
; keys into the readable-files component of the ACL2 state are of the form
; (list file-name typ file-clock); see open-input-channel.  In order to
; preserve our logical story about file IO, we must avoid logically associating
; such a key with two different character lists.  That could happen if
; read-file-into-string is called twice on the same filename, say "F", in the
; case that there is an intervening write not performed by ACL2.  We avoid that
; problem by associating "F" with its current file-write-date, FWD, in the
; global *read-file-alist* just before opening a character input channel to
; "F".  That global is cleared whenever the file-clock of the state is updated,
; except when under read-file-into-string (or any with-local-state actually).
; Now suppose we later attempt to open a (new) character input channel to "F"
; when the file-clock of the state is as before.  Then we cause an error if the
; file-write-date is later than FWD.

; But consider the following situation: when we close an input channel on
; behalf of read-file-into-string, the file-write-date of "F" is not FWD.  In
; that case we could simply update the file-write-date associated with "F" in
; *read-file-alist*, provided this is the first time that read-file-into-string
; has been called on "F" when the file-clock is FC.  We could record whether
; this was indeed the first time, but instead, we avoid that overhead and
; simply cause an error in this (presumably) rare case; see
; read-file-into-string2.

; Any time the file-clock of the state is updated outside
; read-file-into-string, we assign *read-file-alist* to nil (if it is not
; already nil).

  nil)

#-acl2-loop-only
(defvar *inside-with-local-state* nil)

#-acl2-loop-only
(defun increment-*file-clock* ()
  (incf *file-clock*)
  (when (not *inside-with-local-state*)
    (setq *read-file-alist* nil)) ; see *read-file-alist*
  *file-clock*)

#-acl2-loop-only
(defun check-against-read-file-alist (filename
                                      &optional
                                      (fwd (our-ignore-errors
                                            (file-write-date$ filename
                                                              *the-live-state*))))

; See *read-file-alist* for relevant background.

  (let ((pair (assoc-equal filename *read-file-alist*)))
    (cond (pair
           (cond
            ((null fwd)
             (error "Unable to determine file-write-date of file ~
                     ~s.~%Therefore, considering consecutive reads from that ~
                     file to be illegal;~%see :DOC read-file-into-string."
                    filename))
            ((< (cdr pair) fwd)
             (error "Illegal consecutive reads from file ~s.~%See :DOC ~
                     read-file-into-string."
                    filename))
            (t fwd)))
          (t nil))))

(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
            (when (eq typ :character)
              (check-against-read-file-alist file-name))
            (increment-*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*))
                 #+(and acl2-infix 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
            (increment-*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
            (increment-*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)
  (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)
  `(prog2$ (or ,test
               (er hard 'assert$
                   "Assertion failed:~%~x0"
                   '(assert$ ,test ,form)))
           ,form))

(defmacro assert* (test form)
  `(and (mbt* ,test)
        ,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.

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

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

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

#-(or acl2-loop-only (not acl2-par))
(defmacro with-lock (bound-symbol &rest forms)
  `(with-lock-raw ,bound-symbol ,@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 *standard-co*))
                       (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 *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.

           (return-from
            close-output-channel
            (mv (state-free-global-let*
                 ((standard-co *standard-co*))
                 (er hard! 'close-output-channel
                     "It is illegal to call close-output-channel on ~
                      *standard-co*."))
                state-state)))
         (when (eq channel (f-get-global 'standard-co state-state))

; In Version_6.1 and probably before, we have seen an infinite loop occur
; when attempting to close standard-co.  So we just say how to do it properly.

           (return-from
            close-output-channel
            (mv (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 failures 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
            (increment-*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))))

#+(and acl2-infix (not 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 raw-mode-p (state)
  (declare (xargs :guard (and (state-p state)
                              (boundp-global 'acl2-raw-mode-p state))))
  (f-get-global 'acl2-raw-mode-p state))

(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-comma-count* 0)
                 (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-fast
                             (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*))
                 #+acl2-infix
                 (infixp (f-get-global 'infixp state-state))
                 (stream (get-input-stream-from-channel channel))
                 (obj
                  (cond
                   #+acl2-infix
                   ((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.  There were spurious
; ill-formed certificate and checksum problems with Allegro CL for a few months
; (as of Aug. 2009) and I was 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 time improvement given by this declaration
; seems rather trivial, but the space improvement can be substantial; so I'll
; include it.

            #+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-with-case (channel mode state)
  (declare (xargs :guard
                  (and (state-p state)
                       (symbolp channel)
                       (open-input-channel-p channel :object state)
                       (member-eq mode ; case sensitivity mode
                                  '(:upcase :downcase :preserve :invert)))))
  #+acl2-loop-only
  (declare (ignore mode))
  #-acl2-loop-only
  (cond ((live-state-p state)
         (cond
          #+gcl
          ((not (fboundp 'system::set-readtable-case))
           (cerror "Use read-object instead"
                   "Sorry, but ~s is not supported in this older version of ~%~
                    GCL (because raw Lisp function ~s is undefined)."
                   'read-object-with-case
                   'system::set-readtable-case))
          (t
           (return-from read-object-with-case
             (cond ((eq mode :upcase) ; optimization
                    (read-object channel state))
                   (t (let ((*acl2-readtable*
                             (copy-readtable *acl2-readtable*)))
                        (set-acl2-readtable-case :preserve)
                        (read-object channel state)))))))))
  (read-object channel 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 list must contain exactly the characters whose codes are associated with
; T in *slashable-array*, so that the #+acl2-loop-only and #-acl2-loop-only
; code in may-need-slashes-fn are consistent.  This is checked at build time by
; the function check-slashable.

  (list (CODE-CHAR 0) (CODE-CHAR 1) (CODE-CHAR 2) (CODE-CHAR 3)
        (CODE-CHAR 4) (CODE-CHAR 5) (CODE-CHAR 6) (CODE-CHAR 7)
        (CODE-CHAR 8) (CODE-CHAR 9) (CODE-CHAR 10) (CODE-CHAR 11)
        (CODE-CHAR 12) (CODE-CHAR 13) (CODE-CHAR 14) (CODE-CHAR 15)
        (CODE-CHAR 16) (CODE-CHAR 17) (CODE-CHAR 18) (CODE-CHAR 19)
        (CODE-CHAR 20) (CODE-CHAR 21) (CODE-CHAR 22) (CODE-CHAR 23)
        (CODE-CHAR 24) (CODE-CHAR 25) (CODE-CHAR 26) (CODE-CHAR 27)
        (CODE-CHAR 28) (CODE-CHAR 29) (CODE-CHAR 30) (CODE-CHAR 31)
        (CODE-CHAR 32) (CODE-CHAR 34) (CODE-CHAR 35) (CODE-CHAR 39)
        (CODE-CHAR 40) (CODE-CHAR 41) (CODE-CHAR 44) (CODE-CHAR 58)
        (CODE-CHAR 59) (CODE-CHAR 92) (CODE-CHAR 96) (CODE-CHAR 97)
        (CODE-CHAR 98) (CODE-CHAR 99) (CODE-CHAR 100) (CODE-CHAR 101)
        (CODE-CHAR 102) (CODE-CHAR 103) (CODE-CHAR 104) (CODE-CHAR 105)
        (CODE-CHAR 106) (CODE-CHAR 107) (CODE-CHAR 108) (CODE-CHAR 109)
        (CODE-CHAR 110) (CODE-CHAR 111) (CODE-CHAR 112) (CODE-CHAR 113)
        (CODE-CHAR 114) (CODE-CHAR 115) (CODE-CHAR 116) (CODE-CHAR 117)
        (CODE-CHAR 118) (CODE-CHAR 119) (CODE-CHAR 120) (CODE-CHAR 121)
        (CODE-CHAR 122) (CODE-CHAR 124) (CODE-CHAR 127) (CODE-CHAR 128)
        (CODE-CHAR 129) (CODE-CHAR 130) (CODE-CHAR 131) (CODE-CHAR 132)
        (CODE-CHAR 133) (CODE-CHAR 134) (CODE-CHAR 135) (CODE-CHAR 136)
        (CODE-CHAR 137) (CODE-CHAR 138) (CODE-CHAR 139) (CODE-CHAR 140)
        (CODE-CHAR 141) (CODE-CHAR 142) (CODE-CHAR 143) (CODE-CHAR 144)
        (CODE-CHAR 145) (CODE-CHAR 146) (CODE-CHAR 147) (CODE-CHAR 148)
        (CODE-CHAR 149) (CODE-CHAR 150) (CODE-CHAR 151) (CODE-CHAR 152)
        (CODE-CHAR 153) (CODE-CHAR 154) (CODE-CHAR 155) (CODE-CHAR 156)
        (CODE-CHAR 157) (CODE-CHAR 158) (CODE-CHAR 159) (CODE-CHAR 160)
        (CODE-CHAR 168) (CODE-CHAR 170) (CODE-CHAR 175) (CODE-CHAR 178)
        (CODE-CHAR 179) (CODE-CHAR 180) (CODE-CHAR 181) (CODE-CHAR 184)
        (CODE-CHAR 185) (CODE-CHAR 186) (CODE-CHAR 188) (CODE-CHAR 189)
        (CODE-CHAR 190) (CODE-CHAR 224) (CODE-CHAR 225) (CODE-CHAR 226)
        (CODE-CHAR 227) (CODE-CHAR 228) (CODE-CHAR 229) (CODE-CHAR 230)
        (CODE-CHAR 231) (CODE-CHAR 232) (CODE-CHAR 233) (CODE-CHAR 234)
        (CODE-CHAR 235) (CODE-CHAR 236) (CODE-CHAR 237) (CODE-CHAR 238)
        (CODE-CHAR 239) (CODE-CHAR 240) (CODE-CHAR 241) (CODE-CHAR 242)
        (CODE-CHAR 243) (CODE-CHAR 244) (CODE-CHAR 245) (CODE-CHAR 246)
        (CODE-CHAR 248) (CODE-CHAR 249) (CODE-CHAR 250) (CODE-CHAR 251)
        (CODE-CHAR 252) (CODE-CHAR 253) (CODE-CHAR 254) (CODE-CHAR 255)))

(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)
                            (member (car lst) *letter-chars*)
                            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 string 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
                             (svref *letter-array* ch)))
                      ((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 characters as necessary,
; including lower-case characters and certain others such as #\Tab, and to
; avoid the possibility of reading the printed result back in as a number
; instead of a symbol.

; In particular, this function should return true if x represents a potential
; number.  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 other than 10.  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)
  `(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))

(defthm stringp-subseq-type-prescription
  (implies (stringp seq)
           (stringp (subseq seq start end)))
  :rule-classes :type-prescription)

(defthm true-listp-subseq-type-prescription
  (implies (not (stringp seq))
           (true-listp (subseq seq start end)))
  :rule-classes :type-prescription)

(local (in-theory (enable boundp-global1)))

(verify-guards w)
(verify-guards hons-enabledp)
(verify-guards set-serialize-character-fn)
(verify-guards set-serialize-character)
(verify-guards set-serialize-character-system)

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

#-acl2-loop-only
(defun pathname-os-to-unix (str os state)

; Warning: Keep this in sync with the corresponding redefinition in file
; non-ascii-pathnames-raw.lsp, under books/kestrel/.

; This function takes an OS pathname and converts it to an ACL2 pathname; see
; the Essay on Pathnames.

  (if (equal str "")
      str
    (let ((result
           (case os
             (:unix str)
             (:mswindows
              (let* ((sep #\\)
                     (str0 (substitute *directory-separator* sep str)))
                (cond
                 ((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 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)))))
      (let ((msg (and result
                      *check-namestring* ; always true unless a ttag is used
                      (bad-lisp-stringp result))))
        (cond (msg (interface-er
                    "Illegal ACL2 pathname, ~x0:~%~@1"
                    result msg))
              (t result))))))

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

#-acl2-loop-only
(defun pathname-unix-to-os (str state)

; Warning: Keep this in sync with the corresponding redefinition in file
; non-ascii-pathnames-raw.lsp, under books/kestrel/.

; This function takes an ACL2 pathname and converts it to an OS pathname; see
; the Essay on Pathnames.  In the case of :mswindows, the ACL2 filename may or
; may not start with the drive, but the result definitely does.

  #+(and 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)
        (:mswindows
         (let ((sep #\\))
           (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* str)))
               (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)
    #-gcl
    (get-internal-run-time)
    #+gcl
    (multiple-value-bind
     (top child)

; Note that binding two variables here is OK, as per CL HyperSpec, even if
; get-internal-run-time returns more than two values.  Starting around
; mid-October 2013, GCL 2.6.10pre returns four values.

     (get-internal-run-time)
     (+ top child))))

(defun read-run-time (state-state)
  (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)
  (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) ; guard check, for robustness
                             (getenv$-raw str)))))
  (read-acl2-oracle state))

(defun setenv$ (str val)
  (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
        (progn (when *cmucl-unix-setenv-fn*

; It's not enough to update ext::*environment-list* if we want the process's
; environment to be updated, as opposed to merely supporting an update seen by
; run-program.  We use funcall just below in case the "UNIX" package doesn't
; exist, though most likely it does.  See *cmucl-unix-setenv-fn*.

                 (funcall *cmucl-unix-setenv-fn* str val 1))
               (when (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*))))))
        #+allegro
        (setf (sys::getenv str) val)
        #+clisp
        (setf (ext::getenv str) val)
        #+(or gcl lispworks ccl sbcl)
        (let ((fn
               #+gcl       'si::setenv
               #+lispworks 'hcl::setenv
               #+sbcl      'our-sbcl-putenv
               #+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)
  (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)
  (declare (xargs :guard (and (stringp command-string)
                              (string-listp args))))
  #+acl2-loop-only
  (declare (ignore command-string args))
  #-acl2-loop-only
  (cond
   ((or (f-get-global 'in-prove-flg *the-live-state*)
        (f-get-global 'in-verify-flg *the-live-state*))

; We use (er hard ...) rather than (er hard! ...) to avoid a distracting error
; when reasoning about calls of sys-call on concrete data during a proof.  We
; really only want to see this error message when sys-call is invoked by a
; metafunction or a clause-processor.

    (er hard 'sys-call
        "It is illegal to call ~x0 inside the ~s1.  Consider using ~x2 ~
         or ~x3 instead."
        'sys-call
        (if (f-get-global 'in-prove-flg *the-live-state*)
            "prover"
          "proof-builder")
        'sys-call+
        'sys-call*))
   (t
    (let ((rslt (system-call command-string args)))
      (progn (setq *last-sys-call-status* rslt)
             nil))))
  #+acl2-loop-only
  nil)

; Avoid running sys-call on terms.  We already prevent this under prover and
; proof-builder calls, but not for example under the expander from community
; book books/misc/expander.lisp.
(in-theory (disable (:executable-counterpart sys-call)))

(defun sys-call-status (state)
  (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)))

(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)
  (declare (xargs :stobjs state
                  :guard (and (stringp command-string)
                              (string-listp args))))
  #+acl2-loop-only
  (declare (ignore command-string args))
  #-acl2-loop-only
  (when (live-state-p state)
    (return-from sys-call+
      (multiple-value-bind
          (status rslt)
          (system-call+ command-string args)
        (mv (if (eql status 0)
                nil
              status)
            rslt
            state))))
  (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))))

(defun sys-call* (command-string args state)
  (declare (xargs :stobjs state
                  :guard (and (stringp command-string)
                              (string-listp args))))
  #+acl2-loop-only
  (declare (ignore command-string args))
  #-acl2-loop-only
  (when (live-state-p state)
    (return-from sys-call*
      (let ((status (system-call command-string args)))
        (mv (if (eql status 0)
                nil
              status)
            nil
            state))))
  (mv-let (erp1 erp state)
    (read-acl2-oracle state)
    (declare (ignore erp1))
    (mv (and (integerp erp)
             (not (eql 0 erp))
             erp)
        nil
        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-with-guard-check put-assoc-eq-exec (name val alist)
  (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-with-guard-check put-assoc-eql-exec (name val alist)
  (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))
  (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)))

; Addition suggested by Dmitry Nadezhin (a proof that succeeded in ACL2 using
; the lemma just above failed without the following):

#+:non-standard-analysis
(defthm realp-implies-acl2-numberp
  (implies (realp 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
  (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))
)

(defthm state-p1-update-print-base
  (implies (state-p1 state)
           (state-p1 (update-nth 2
                                 (add-pair 'print-base 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 'print-base val (nth 2 state))
                               state)))))

(defun set-print-base-radix (base state)
  (declare (xargs :guard (and (print-base-p base)
                              (state-p state))))
  (prog2$ (check-print-base base 'set-print-base)
          (pprogn (f-put-global 'print-base base state)
                  (f-put-global 'print-radix
                                (if (int= base 10)
                                    nil
                                  t)
                                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)))
  (getpropc 'known-package-alist 'global-value))

;  Prin1

(defun symbol-in-current-package-p (x state)
  (declare (xargs :guard (and (symbolp x)
                              (state-p state)
                              (f-boundp-global 'current-package state))))
  #+acl2-loop-only
  (or (equal (symbol-package-name x)
             (f-get-global 'current-package state))
      (and (ec-call ; avoid guard proof; this is just logic anyhow
            (member-equal
             x
             (package-entry-imports
              (find-package-entry
               (f-get-global 'current-package state)
               (known-package-alist state)))))
           t))
  #-acl2-loop-only
  (multiple-value-bind
   (sym foundp)
   (find-symbol (symbol-name x)
                (f-get-global 'current-package state))
   (and foundp ; return nil when x is nil but is not in the current package
        (eq sym x))))

(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)
                   #+acl2-print-number-base-16-upcase-digits
                   (cond ((and (acl2-numberp x)
                               (> *print-base* 10))
                          (print-number-base-16-upcase-digits x stream))
                         (t (princ x stream)))
                   #-acl2-print-number-base-16-upcase-digits
                   (princ 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")
                      (#\Return  "Return")
                      (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))
                         ((symbol-in-current-package-p x 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")
                    (#\Return  "Return")
                    (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))
                ((symbol-in-current-package-p x 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)))
  (f-get-global 'current-package state))

(defthm state-p1-update-nth-2-world
  (implies (and (state-p1 state)
                (plist-worldp wrld)
                (known-package-alistp
                 (getpropc 'known-package-alist 'global-value nil wrld))
                (symbol-alistp (getpropc 'acl2-defaults-table 'table-alist nil
                                         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-fncall-w ev-fncall-w-body ev-w ev-w-lst

    set-w set-w! cloaked-set-w!

; The next group of functions includes those that call set-w or set-w!, except
; that not included are those that we know are safe, for example because they
; are event functions (like encapsulate-fn).  We also include at the functions
; that call any in this group of function, etc.  Note that even though ld-fn
; isn't an event function, we exclude it because sometimes there is a reason
; for a user to call ld.  Is that safe?  We hope so!  Also note that even
; though table-fn1 isn't an event function but calls install-event, it is
; invoked by calling the macro, theory-invariant; but table-fn1 seems safe for
; users to call, since it is the essence of table-fn.

    install-event
    defuns-fn1
    process-embedded-events
    encapsulate-pass-2
    include-book-fn1
;   defabsstobj-fn1 ; called by defabsstobj-missing-events; seems safe
    maybe-add-command-landmark
    ubt-ubu-fn1
    install-event-defuns ; calls install-event
    defthm-fn1 ; calls install-event
    defuns-fn0 ; calls defuns-fn1
    ld-read-eval-print ; calls maybe-add-command-landmark
    ld-loop ; calls ld-read-eval-print
    ld-fn-body ; calls ld-loop
    ld-fn0 ld-fn1 ; both call ld-fn-body

; End of functions leading to calls of 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
    init-iprint-fal update-iprint-fal-rec update-iprint-fal init-iprint-fal+

    checkpoint-world

    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

    update-enabled-structure-array ; many assumptions for calling correctly

    when-pass-2

; 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
    acl2-world-alist
    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-fal
    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 raw-include-book-dir-alist
    deferred-ttag-notes
    deferred-ttag-notes-saved
    pc-assign
    illegal-to-certify-message
    acl2-sources-dir
    including-uncertified-p
    check-invariant-risk ; set- function ensures proper values
    print-gv-defaults
    global-enabled-structure
    cert-data
    verify-termination-on-raw-program-okp
    prompt-memo
    ))

; There is 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)))
  (f-get-global 'ld-skip-proofsp state))

#-acl2-loop-only
(save-def
(defun-one-output bad-lisp-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)))))))))))))))
)

#-acl2-loop-only
(defun-one-output bad-lisp-atomp (x)

; At one time LispWorks printed a warning for this function:

;   Eliminating a test of a variable with a declared type : ACL2::X [type ATOM]

; We were told in December 2016 that this compiler bug would be fixed in the
; next LispWorks release, and that the bug is only in printing of the warning,
; not in the code generated by the compiler.  The warning is indeed gone in
; LispWorks 7.1.

  (declare (type atom x))
  (cond ((typep x 'integer)

; 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 integers (like (H)) are not an issue
; because all Common Lisp integers are "real" integers, hence standard.

         nil)
        ((typep x 'symbol)
         (cond
          ((eq x nil) nil) ; seems like useful special case for true lists
          ((bad-lisp-stringp (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))))))
        ((typep x 'string)
         (bad-lisp-stringp x))
        ((typep x 'character)
         (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-atomp (numerator x))
             (bad-lisp-atomp (denominator x))))
        ((typep x '(complex rational))
         (or (bad-lisp-atomp (realpart x))
             (bad-lisp-atomp (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
(declaim (inline bad-lisp-objectp))
#-acl2-loop-only
(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 ((typep x 'cons) (bad-lisp-consp x))
        (t (bad-lisp-atomp x))))

#-acl2-loop-only
(save-def
(defun-one-output bad-lisp-consp (x)
  (declare (type cons x))
  (or (bad-lisp-objectp (car x))
      (bad-lisp-objectp (cdr 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)
  (declare (type symbol x))
  `(pprogn (f-put-global ',x ,y state)
           (mv nil (f-get-global ',x state) state)))

(defmacro @ (x)
  (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-with-guard-check union-eq-exec (l1 l2)
  (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-with-guard-check union-eql-exec (l1 l2)
  (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-equal-with-union-eq-exec-guard (l1 l2)
  `(let ((l1 ,l1) (l2 ,l2))
     (prog2$ (,(guard-check-fn 'union-eq-exec) l1 l2)
             (union-equal l1 l2))))

(defmacro union-equal-with-union-eql-exec-guard (l1 l2)
  `(let ((l1 ,l1) (l2 ,l2))
     (prog2$ (,(guard-check-fn 'union-eql-exec) l1 l2)
             (union-equal l1 l2))))

(defmacro union$ (&whole form &rest x)
  (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
                          :guardp nil ; guard handled by :logic
                          :logic
                          ,(xxxjoin 'union-equal-with-union-eq-exec-guard
                                    vars)
                          :exec
                          ,(xxxjoin 'union-eq-exec vars)))
               ((equal test ''eql)
                `(let-mbe ,bindings
                          :guardp nil ; guard handled by :logic
                          :logic
                          ,(xxxjoin 'union-equal-with-union-eql-exec-guard
                                    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))

; Intersection$

(defun-with-guard-check intersection-eq-exec (l1 l2)
  (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-with-guard-check intersection-eql-exec (l1 l2)
  (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-equal-with-intersection-eq-exec-guard (l1 l2)
  `(let ((l1 ,l1) (l2 ,l2))
     (prog2$ (,(guard-check-fn 'intersection-eq-exec) l1 l2)
             (intersection-equal l1 l2))))

(defmacro intersection-equal-with-intersection-eql-exec-guard (l1 l2)
  `(let ((l1 ,l1) (l2 ,l2))
     (prog2$ (,(guard-check-fn 'intersection-eql-exec) l1 l2)
             (intersection-equal l1 l2))))

(defmacro intersection$ (&whole form &rest x)
  (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
                          :guardp nil ; guard handled by :logic
                          :logic
                          ,(xxxjoin
                            'intersection-equal-with-intersection-eq-exec-guard
                            vars)
                          :exec
                          ,(xxxjoin 'intersection-eq-exec vars)))
               ((equal test ''eql)
                `(let-mbe ,bindings
                          :guardp nil ; guard handled by :logic
                          :logic
                          ,(xxxjoin
                            'intersection-equal-with-intersection-eql-exec-guard
                            vars)
                          :exec
                          ,(xxxjoin 'intersection-eql-exec vars)))
               (t ; (equal test 'equal)
                `(xxxjoin 'intersection-equal ,args))))))))

#+acl2-loop-only
(defmacro set-enforce-redundancy (x)
  `(with-output
     :off (event summary)
     (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)

(defun get-enforce-redundancy (wrld)
  (declare (xargs :guard (and (plist-worldp wrld)
                              (alistp (table-alist 'acl2-defaults-table
                                                   wrld)))))
  (cdr (assoc-eq :enforce-redundancy
                 (table-alist 'acl2-defaults-table wrld))))

(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)
  `(with-output
     :off (event summary)
     (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)
  `(with-output
     :off (event summary)
     (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)
  (declare (xargs :guard t
                  :stobjs state))
  (cond ((member-eq val '(t nil :books))
         (f-put-global 'compiler-enabled val state))
        (t (prog2$ (hard-error 'set-compiler-enabled
                               "Illegal value for set-compiler-enabled: ~x0"
                               val)
                   state))))

(defun set-port-file-enabled (val state)
  (declare (xargs :guard t
                  :stobjs state))
  (cond ((member-eq val '(t nil))
         (f-put-global 'port-file-enabled val state))
        (t (prog2$ (hard-error 'set-port-file-enabled
                               "Illegal value for set-port-file-enabled: ~x0"
                               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)
  `(with-output
     :off (event summary)
     (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)
  `(with-output
     :off (event summary)
     (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)
  (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
  '(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
  '(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)
  (declare (xargs :guard (plist-worldp wrld)))
  (table-alist 'invisible-fns-table wrld))

(defmacro set-invisible-fns-table (alist)
  `(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 (getpropc (car lst) 'formals nil 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)
  `(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)
  `(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)
  `(with-output
     :off (event summary)
     (progn (table acl2-defaults-table :bogus-defun-hints-ok ,x)
            (table acl2-defaults-table :bogus-defun-hints-ok))))

(defmacro set-bogus-measure-ok (x)

; After Version_7.2 we are extending the capability offered by
; set-bogus-defun-hints-ok, since Version_3.4, so that it applies to bogus
; measures as well.

  `(set-bogus-defun-hints-ok ,x))

#-acl2-loop-only
(defmacro set-bogus-defun-hints-ok (x)
  (declare (ignore x))
  nil)

#+acl2-loop-only
(defmacro set-bogus-mutual-recursion-ok (x)
  `(with-output
     :off (event summary)
     (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)

; Set-ruler-extenders has been moved from here to simplify.lisp, so that
; sort-symbol-listp is defined first.

#+acl2-loop-only
(defmacro set-irrelevant-formals-ok (x)
  `(with-output
     :off (event summary)
     (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)
  `(with-output
     :off (event summary)
     (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)
  (declare (xargs :guard (string-listp lst)))
  `(with-output
     :off (event summary)
     (progn (table inhibit-warnings-table nil ',(pairlis$ lst nil) :clear)
            (value-triple ',lst))))

(defmacro set-inhibit-warnings (&rest lst)
  `(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.

  `(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)
  `(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)
  `(with-output
     :off (event summary)
     (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)
  `(with-output
     :off (event summary)
     (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 :DOC 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)
  `(with-output
     :off (event summary)
     (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)
  (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)
  `(with-output
     :off (event summary)
     (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)
  (declare (xargs :guard
                  (and (member-eq flg '(:ts :rewrite :meta))
                       (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.

  `(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)
  `(with-output
     :off (event summary)
     (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)
  (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*))

; 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)))))
  (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)
  `(with-output
     :off (event summary)
     (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 we prefer
; to start with an acl2-defaults-table that agrees with the one in
; chk-raise-portcullis1; this isn't essential, but for example it avoids laying
; down extra table forms when we :puff.  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)
  (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)
         (unary-- -)
         (unary-/ /))
       :clear)

(defmacro add-macro-fn (macro macro-fn &optional right-associate-p)
  `(progn (add-macro-alias ,macro ,macro-fn)
          (table untrans-table ',macro-fn '(,macro . ,right-associate-p))))

(defmacro add-binop (macro macro-fn)
  `(add-macro-fn ,macro ,macro-fn t))

(defmacro remove-macro-fn (macro-fn)
  `(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)
  `(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)
  `(with-output
     :off (event summary)
     (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)
  (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)
  `(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)
  `(change-include-book-dir ',keyword
                            ',dir
                            'add-include-book-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)
  `(change-include-book-dir ,keyword
                            nil
                            'delete-include-book-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
; delete-include-book-dir in a suitable list in the definition of translate11.

                            #+acl2-loop-only state
                            #-acl2-loop-only *the-live-state*))

(table include-book-dir!-table nil nil
       :guard (include-book-dir-alist-entry-p
               key val (global-val 'operating-system world)))

(defun raw-include-book-dir-p (state)

; See the Essay on Include-book-dir-alist.  An invariant is that the value of
; 'raw-include-book-dir-alist is :ignore if and only if the value of
; 'raw-include-book-dir!-alist is :ignore, though quite possibly we do not need
; to maintain that invariant.

  (declare (xargs :guard (and (state-p state)
                              (boundp-global 'raw-include-book-dir-alist state))))
  (not (eq (f-get-global 'raw-include-book-dir-alist state)
           :ignore)))

(defmacro add-include-book-dir! (keyword dir)
  `(change-include-book-dir ',keyword
                            ',dir
                            'add-include-book-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)
  `(change-include-book-dir ,keyword
                            nil
                            'delete-include-book-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
; 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)
  `(with-output
     :off (event summary)
     (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)
  `(with-output
     :off (event summary)
     (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)
  (declare (xargs :guard (symbolp tag-name)))
  `(with-output
     :off (event summary)
     (progn (table acl2-defaults-table
                   :ttag
                   ',(and tag-name
                          (intern (symbol-name tag-name) "KEYWORD")))
            (table acl2-defaults-table :ttag))))

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

; We here document some Common Lisp functions.  The primitives are near
; the end of this file.

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

(table macro-aliases-table nil nil
       :guard
       (and (symbolp key)
            (not (eq (getpropc key 'macro-args t 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)
  `(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)
  `(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.

(table nth-aliases-table nil nil
       :guard
       (and (symbolp key)
            (not (eq key 'state))
            (eq (getpropc key 'accessor-names t 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)
  `(table nth-aliases-table ',alias-name ',name))

(defmacro remove-nth-alias (alias-name)
  `(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.

(defun default-hints (wrld)
  (declare (xargs :guard (and (plist-worldp wrld)
                              (alistp (table-alist 'default-hints-table
                                                   wrld)))))
  (cdr (assoc-eq t (table-alist 'default-hints-table wrld))))

(defmacro set-default-hints (lst)
  `(local (set-default-hints! ,lst)))

#+acl2-loop-only
(defmacro set-default-hints! (lst)
  `(with-output
     :off (event summary)
     (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)
  `(local (add-default-hints! ,lst :at-end ,at-end)))

#+acl2-loop-only
(defmacro add-default-hints! (lst &key at-end)
  `(with-output
     :off (event summary)
     (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)
  `(local (remove-default-hints! ,lst)))

#+acl2-loop-only
(defmacro remove-default-hints! (lst)
  `(with-output
     :off (event summary)
     (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)
  (declare (xargs :guard (booleanp at-end)))
  `(set-override-hints-macro ,lst ,at-end 'add-override-hints!))

(defmacro add-override-hints (lst &key at-end)
  (declare (xargs :guard (booleanp at-end)))
  `(local
    (set-override-hints-macro ,lst ,at-end 'add-override-hints)))

(defmacro set-override-hints! (lst)
  `(set-override-hints-macro ,lst :clear 'set-override-hints!))

(defmacro set-override-hints (lst)
  `(local
    (set-override-hints-macro ,lst :clear 'set-override-hints)))

(defmacro remove-override-hints! (lst)
  `(set-override-hints-macro ,lst :remove 'remove-override-hints!))

(defmacro remove-override-hints (lst)
  `(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))
;         (progn$ (cw string)
;                 (cw "~|~x0:~|  ~x1~|~x2:~|  ~x3~|~%"
;                     '(tagged-objects 'rw-cache-nil-tag ttree)
;                     (tagged-objects 'rw-cache-nil-tag ttree)
;                     '(tagged-objects 'rw-cache-any-tag ttree)
;                     (tagged-objects 'rw-cache-any-tag ttree))
;                 (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.

  `(local (set-rw-cache-state! ,val)))

#+acl2-loop-only
(defmacro set-rw-cache-state! (val)
  `(with-output
     :off (event summary)
     (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)
  (declare (xargs :guard t))
  (if (consp x)
      (cons-with-hint (car x)
                      (fix-true-list (cdr x))
                      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)))

;; Historical Comment from Ruben Gamboa:
;; 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)

(defthm default-code-char
  (implies (and (syntaxp (not (equal x ''0))) ; for efficiency
                (not (and (integerp x)
                          (>= x 0)
                          (< x 256))))
           (equal (code-char x)
                  (code-char 0)))
  :hints (("Goal" :use completion-of-code-char)))

;; Historical Comment from Ruben Gamboa:
;; 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)

;; Historical Comment from Ruben Gamboa:
;; 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)))

;; Historical Comment from Ruben Gamboa:
;; 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))))))

;; Historical Comment from Ruben Gamboa:
;; This axiom was modified to include the reals.

(defthm complex-0
  (equal (complex x 0)
         (realfix 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)))

;; Historical Comment from Ruben Gamboa:
;; 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)

;; Historical Comment from Ruben Gamboa:
;; 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)))

;; Historical Comment from Ruben Gamboa:
;; 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)))

;; Historical Comment from Ruben Gamboa:
;; 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)

;; Historical Comment from Ruben Gamboa:
;; 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)

;; Historical Comment from Ruben Gamboa:
;; 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)))

;; Historical Comment from Ruben Gamboa:
;; Here, I put in the basic theory that we will use for
;; non-standard analysis.

#+: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.
; Historical Comment from Ruben Gamboa:
; TODO: 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))

)

(defun double-rewrite (x)
  (declare (xargs :guard t))
  x)

#-acl2-loop-only
(progn

; The following variables implement prover time limits.  The variable
; *acl2-time-limit* is nil by default, but is set to a positive time limit (in
; units of internal-time-units-per-second) by with-prover-time-limit, and is
; set to 0 to indicate that a proof has been interrupted (see our-abort).

; The variable *acl2-time-limit-boundp* is used in bind-acl2-time-limit, which
; provides the only legal way to bind *acl2-time-limit*.  For more information
; about these variables, see bind-acl2-time-limit.

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

(defconst *interrupt-string*
  "Aborting due to an interrupt.")

(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)
              *interrupt-string*
            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.

; We could probably let-bind the global-symbol of 'guard-checking-on rather
; than using state-free-global-let*, and that might be slightly more efficient.
; But this way is more robust in case state is accessed in form using
; with-local-state or raw Lisp.

  `(state-free-global-let*
    ((guard-checking-on ,val))
    ,form))

(defmacro with-guard-checking1 (val gated-form)
  `(return-last 'with-guard-checking1-raw ,val ,gated-form))

(defun with-guard-checking-gate (form)

; This is a custom version of check-vars-not-free, used by with-guard-checking.

  (declare (xargs :guard t))
  `(lambda (term)
     (or (not (member-eq 'state (all-vars term)))
         (msg "It is forbidden to use ~x0 in the scope of a call of ~x1, but ~
               ~x0 occurs in the [translation of] the form ~x2.  Consider ~
               using ~x3 instead."
              'state
              'with-guard-checking
              ',form
              'with-guard-checking-error-triple))))

(defmacro with-guard-checking (val form)
  (declare (xargs :guard t))
  `(with-guard-checking1
    (chk-with-guard-checking-arg ,val)
    (translate-and-test
     ,(with-guard-checking-gate form)

; Through Version_7.1, the following events all succeeded, which could be
; viewed as a soundness bug.  The problem is clear from this example: we are
; binding the state global 'guard-checking-on in raw Lisp but not in the logic.
; We now solve this problem by insisting that state is not free in the form.
; Otherwise, one should consider using state-global-let* to bind
; 'guard-checking-on, as with any state global.  If that proves to be a
; hardship, we might consider a new construct that allows binding state globals
; without returning state, trusting that the effects of those bindings will be
; undone when exiting the scope of that construct.

;   (defun foo (state)
;     (declare (xargs :stobjs state
;                      :guard (f-boundp-global 'guard-checking-on state)))
;     (with-guard-checking :all (f-get-global 'guard-checking-on state)))
;
;   (thm (equal (foo state)
;               (f-get-global 'guard-checking-on state)))
;
;   (assert-event (not (equal (foo state)
;                             (f-get-global 'guard-checking-on state))))

     ,form)))

(defmacro with-guard-checking-error-triple (val form)
  `(prog2$ (chk-with-guard-checking-arg ,val)
           (state-global-let* ((guard-checking-on ,val))
                              ,form)))

#+acl2-loop-only
(defmacro with-guard-checking-event (val form)
  `(with-guard-checking-error-triple ,val ,form))

#-acl2-loop-only
(defmacro with-guard-checking-event (val form)
  (declare (ignore val))
  form)

(defun abort! ()
  (declare (xargs :guard t))
  #-acl2-loop-only
  (throw 'local-top-level :abort)
  nil)

(defmacro a! ()
  (declare (xargs :guard t))
  '(abort!))

(defun p! ()

; If p! is executed inside a brr wormhole break, it will cause an abort out of
; the brkpt1 call.  The message "Pop up to ACL2 top-level" might be a bit
; misleading in that case, but it appears to be accurate: the brr wormhole from
; brkpt1 is indeed exited.

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

(defmacro bind-acl2-time-limit (form &optional (limit 'nil limit-p))

; The raw Lisp code for this macro arranges that *acl2-time-limit* is restored
; to its global value (presumably nil) after we exit its top-level call.
; Consider the following key example of how this can work.  Suppose
; *acl2-time-limit* is set to 0 by our-abort because of an interrupt.
; Inspection of the code for our-abort shows that *acl2-time-limit-boundp* must
; be true in that case; but then we must be in the dynamic scope of
; bind-acl2-time-limit, as that is the only legal way for
; *acl2-time-limit-boundp* to be bound or set.  But inside bind-acl2-time-limit
; we are only modifying a let-bound *acl2-time-limit*, not its global value.
; In summary, setting *acl2-time-limit* to 0 by our-abort will not change the
; global value of *acl2-time-limit*.

; However, the description above is a bit flawed if we enter a wormhole.  We
; really want a fresh binding of *acl2-time-limit* in that case, as illustrated
; by the following example, which explains the call of bind-acl2-time-limit
; around ld-fn in wormhole1.

;   (defun foo (x) (cons x x))
;   (brr t)
;   (monitor '(:definition foo) t)
;   ; The following succeeds if we type :go at the breaks.
;   ; But suppose we don't:
;   (with-prover-time-limit
;    1/10
;    (thm (equal (append (append x y) (foo z))
;                (append x y (foo z)))))
;   ; Now in the break...
;   ; Try the following several times, and eventually you'll see it quit with an
;   ; error due to being out of time!
;   (thm (equal (append (append x y) z)
;               (append x y z)))
;   ; Without the call of bind-acl2-time-limit around ld-fn in wormhole1,
;   ; the following fails after enough THM calls just above.  But that's not
;   ; surprising, since time-limits are based on total cpu time, which includes
;   ; time in the wormhole.
;   :go

  #-acl2-loop-only
  (cond (limit-p ; then definitely bind
         `(let ((*acl2-time-limit-boundp* t)
                (*acl2-time-limit* ,limit))
            ,form))
        (t `(if *acl2-time-limit-boundp*
                ,form
              (let ((*acl2-time-limit-boundp* t)
                    (*acl2-time-limit* *acl2-time-limit*))
                ,form))))
  #+acl2-loop-only
  (declare (ignore limit limit-p))
  #+acl2-loop-only
  form)

(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)
      (bind-acl2-time-limit

; See the comments in bind-acl2-time-limit to understand why we are using it
; here.

       (ld-fn (append
               `((standard-oi . (,form . ,*standard-oi*))
                 (standard-co . ,*standard-co*)
                 (proofs-co . ,*standard-co*))
               ld-specials)
              state
              t)
       nil)
      (eval *wormhole-cleanup-form*)
      (pop (car *acl2-unwind-protect-stack*))
      nil))))

(defun wormhole-p (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 -16384 #+:non-standard-analysis -131072
           (cadr x))
       (<= (cadr x)
           #-:non-standard-analysis 16383 #+:non-standard-analysis 131071)))

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

(defun if* (x y z)
  (declare (xargs :mode :logic :verify-guards t))
  (if x y z))

(defun resize-list-exec (lst n default-value acc)
  (declare (xargs :guard (true-listp acc)))
  (if (and (integerp n) (> n 0))
      (resize-list-exec (if (atom lst) lst (cdr lst))
                        (1- n)
                        default-value
                        (cons (if (atom lst) default-value (car lst))
                              acc))
    (reverse acc)))

(defun resize-list (lst n default-value)

; This function supports stobjs.

  (declare (xargs :guard t :verify-guards nil))
  (mbe :logic
       (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)
       :exec ; tail-recursive
       (resize-list-exec lst n default-value nil)))

(defthm resize-list-exec-is-resize-list
  (implies (true-listp acc)
           (equal (resize-list-exec lst n default-value acc)
                  (revappend acc
                             (resize-list lst n default-value)))))

(verify-guards resize-list)

; Define e/d, adapted with only minor changes from Bishop Brock's community
; book books/ihs/ihs-init.lisp.

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

  (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.
; Added 2/21/2016: The build succeeds for CCL and SBCL even when the next form
; is commented out, but on a Mac at least, rather little time is saved:
; 0m51.160s down to 0m48.163s for CCL, and 1m9.987s down to 1m8.409s for SBCL.
; And even though those builds succeeded, we didn't check that the resulting
; saved image is correct by running a regression.

#+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-eql-exec$guard-check)
 (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)
 (verify-termination-boot-strap binary-append) ; for string-append
; The following avoids an ACL2(p) loop in thanks-for-the-hint; see
; string-append.
 (verify-termination-boot-strap string-append)

 )

(defun mod-expt (base exp mod)

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

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

  (append *top-hint-keywords*
          '(:computed-hint-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)))
  `(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)
  `(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)))))))

(defmacro show-custom-keyword-hint-expansion (flg)
  `(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-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))
  `(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)
  `(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)
  (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
(defmacro heap-bytes-allocated ()
  '(the-mfixnum #+ccl (ccl::total-bytes-allocated)
                #+sbcl (sb-ext:get-bytes-consed)
                #-(or ccl sbcl)
                (error "Heap-bytes-allocated is unknown for this host Lisp.")))

#-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))
        #+(or ccl sbcl)
        (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
                 #-gcl (get-internal-run-time)
                 #+gcl (multiple-value-list (get-internal-run-time)))
                #+(or ccl sbcl)
                (,g-start-alloc (heap-bytes-allocated)))
           (our-multiple-value-prog1
            ,x
            ,(protect-mv
              `(let* ((end-run-time
                       #-gcl (get-internal-run-time)
                       #+gcl (multiple-value-list (get-internal-run-time)))
                      (end-real-time (get-internal-real-time))
                      #+(or ccl sbcl) ; evaluate before computations below:
                      (allocated (- (heap-bytes-allocated)
                                    ,g-start-alloc))
                      (float-units-sec (float internal-time-units-per-second))
                      (real-elapsed (/ (- end-real-time ,g-start-real-time)
                                       float-units-sec))
                      (run-elapsed (/ #-gcl (- end-run-time ,g-start-run-time)
                                      #+gcl (- (car end-run-time)
                                               (car ,g-start-run-time))
                                      float-units-sec))
                      #+gcl
                      (child-run-elapsed (/ (- (cadr end-run-time)
                                               (cadr ,g-start-run-time))
                                            float-units-sec))
                      #+gcl
                      (sys-elapsed (and (cddr end-run-time)
                                        (/ (- (caddr end-run-time)
                                              (caddr ,g-start-run-time))
                                           float-units-sec)))
                      #+gcl
                      (child-sys-elapsed (and (cdddr end-run-time)
                                              (/ (- (cadddr end-run-time)
                                                    (cadddr ,g-start-run-time))
                                                 float-units-sec))))
                 (when
                     (not (or (and ,g-real-mintime
                                   (< real-elapsed (float ,g-real-mintime)))
                              (and ,g-run-mintime
                                   (< run-elapsed (float ,g-run-mintime)))
                              #+(or ccl sbcl)
                              (and ,g-minalloc
                                   (< allocated ,g-minalloc))))
                   (let* ((alist (list* (cons #\t (format nil "~,2F"
                                                          real-elapsed))
                                        (cons #\c (format nil "~,2F"
                                                          run-elapsed))
                                        #+gcl
                                        (cons #\C (format nil "~,2F"
                                                          child-run-elapsed))
                                        #+gcl
                                        (cons #\s (and sys-elapsed
                                                       (format nil "~,2F"
                                                               sys-elapsed)))
                                        #+gcl
                                        (cons #\S (and child-sys-elapsed
                                                       (format
                                                        nil "~,2F"
                                                        child-sys-elapsed)))
                                        (cons #\a
                                              #+(or ccl sbcl)
                                              (format nil "~:D" allocated)
                                              #-(or ccl sbcl)
                                              "[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
                                      #+(or ccl sbcl)
                                      "; ~Xfe took ~|; ~st seconds realtime, ~
                                       ~sc seconds runtime~|; (~sa bytes ~
                                       allocated).~%"
                                      #+gcl
                                      (cond
                                       (child-sys-elapsed
                                        "; ~Xfe took ~|; ~st seconds ~
                                         realtime,~|; ~sc seconds runtime, ~
                                         ~sC seconds child runtime,~|; ~ss ~
                                         seconds systime, ~sS seconds child ~
                                         systime.~%")
                                       (t ; "seconds" => "sec" to fit on 1 line
                                        "; ~Xfe took ~|; ~st sec ~
                                         realtime, ~sc sec runtime, ~sC ~
                                         sec child runtime.~%"))
                                      #-(or ccl gcl)
                                      "; ~Xfe took~|; ~st seconds realtime, ~
                                       ~sc seconds runtime.~%")))
                     (state-free-global-let*
                      ((fmt-hard-right-margin 100000)
                       (fmt-soft-right-margin 100000))
                      (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))))

 (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
  (case (length args)
    (1 (si::gbc (car args)))
    (0 (si::gbc t))
    (otherwise
     (er hard 'gc$
         "In GCL, gc$ requires one argument, typically T, or no arguments.")))
  #+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)
  `(gc$-fn ',args))

#-acl2-loop-only
(defun-one-output gc-verbose-fn (arg1 arg2)

; For a related function, see gc$-fn.

  (declare (ignorable arg2))
  (let ((arg1 (and arg1 t))) ; coerce to Boolean
    (declare (ignorable arg1))
    #+ccl (ccl::gc-verbose arg1 arg2)
    #+cmu (setq ext:*gc-verbose* arg1)
    #+gcl (setq si:*notify-gbc* arg1)

; Warning: If you change the Lisps for which GC-VERBOSE is supported (by
; changing the #- expression below), make the corresponding change to #-
; expressions where gc-verbose is called (currently, in acl2h-init).

    #-(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 (arg1 arg2)
  (declare (ignore arg1 arg2)
           (xargs :guard t))
  nil)

(defmacro gc-verbose (arg1 &optional arg2)
  `(gc-verbose-fn ,arg1 ,arg2))

(defun get-wormhole-status (name state)
   #+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)

; File is an ACL2 filename; see the Essay on Pathnames.

  (declare (xargs :guard (stringp file)
                  :stobjs state)
           (ignorable file))
  #+(not acl2-loop-only)
  (when (live-state-p state)
    (return-from
     file-write-date$
     (mv (our-ignore-errors
          (file-write-date (pathname-unix-to-os file state)))
         state)))
  (mv-let (erp val state)
          (read-acl2-oracle state)
          (mv (and (null erp)
                   (posp val)
                   val)
              state)))

(defun delete-file$ (file state)

; File is an ACL2 pathname; see the Essay on Pathnames.

; It may seem a bit surprising that this function does not update the
; file-clock of the state.  To see why that isn't necessary, let us review the
; role of the file-clock (also see :DOC state).  When open-input-channel opens
; a channel, it logically associates that channel in the open-input-channels
; field of the state with (among other things) "header" information that
; includes an incremented file-clock; similarly for close-input-channel and the
; read-files field of the state.  Updates using an incremented file-clock also
; take place for open-output-channel and close-output-channel for fields
; writeable-files and written-files, respectively.  Moreover: logically, when
; we open an input channel we magically grab the full contents of the file that
; we will ultimately read associate them with the channel, and these are popped
; by functions that read, such as read-char$; rather dually, we push values on
; the open-output-channels entries when we call functions that write, such as
; print-object$, and then deposit all those values in written-files when we
; close the channel.

; We would get into trouble logically if we could get different answers when
; obtaining two different values from two reads of the same file when the two
; states agree on their state fields that pertain to contents of channels and
; files.  But this can't happen, because the file-clock is incremented
; immediately before we create a channel.  In particular, when we open an input
; channel we access a readable-files entry based on a file-clock that we
; haven't yet seen, since the file-clock is incremented first.  So we can never
; see what we already wrote!  This avoids the problem of seeing contents in a
; file that we didn't put there because an external agent wrote to that file.
; It also avoids the problem of opening a channel to a non-existent file that
; used to exist: all file-related entries in various state fields are
; associated with earlier file-clocks than the one associated with the new
; channel.

; So in particular, if we open or close a channel at file-clock fc1 and then
; run delete-file$, a subsequent open or close will involve entries whose
; file-clock is greater than fc1.  Thus, there will be no way to detect
; logically any effect of delete-file$ on the four state fields above, since
; nothing was known about fields for file-clock exceeding fc1 before running
; delete-file$.  The special case of read-file-into-string is also handled,
; because of reliance on the file-write-date when the file-clock hasn't
; changed; see *read-file-alist*.

  (declare (xargs :guard (stringp file)
                  :stobjs state))
  #+acl2-loop-only
  (declare (ignore file))
  #-acl2-loop-only
  (when (live-state-p state)
    (return-from
     delete-file$
     (mv (our-ignore-errors
          (delete-file (pathname-unix-to-os file state)))
         state)))
  (mv-let (erp val state)
          (read-acl2-oracle state)
          (mv (and (null erp)
                   (natp 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.

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

#-acl2-loop-only
(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))
  (when (f-get-global 'boot-strap-flg *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))
  (when (f-get-global 'certify-book-info *the-live-state*)

; The additional "Book under certification" message is helpful when the
; backtrace output goes to the terminal instead of a .out file, which could
; happen in SBCL before Feb. 2016.  That problem now seems to be solved for
; SBCL, but we retain this printing in case it is helpful some day for some
; Lisp.

    (eval ; using eval because the certify-book-info record is not yet defined
     '(format *debug-io*
              "~%; Book under certification: ~s~%"
              (access certify-book-info
                      (f-get-global 'certify-book-info *the-live-state*)
                      :full-book-name))))
  #+ccl
  (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)))

  #+allegro
  (when (fboundp 'tpl::do-command)
    (eval '(tpl:do-command "zoom"
                           :from-read-eval-print-loop nil
                           :count t :all t)))
  #+sbcl
  (cond ((fboundp 'sb-debug::print-backtrace)
         (eval '(sb-debug::print-backtrace :stream *debug-io*)))
        ((fboundp 'sb-debug::backtrace)
         (eval '(sb-debug::backtrace nil *debug-io*))))
  #+cmucl
  (when (fboundp 'debug::backtrace)
    (eval '(debug::backtrace 1000 ; default for sbcl
                             *debug-io*)))
  #+clisp
  (when (fboundp 'system::print-backtrace)
    (eval '(catch 'system::debug
             (system::print-backtrace))))
  #+lispworks
  (when (fboundp 'dbg::output-backtrace)
    (eval '(dbg::output-backtrace :verbose)))

; Return nil, for compatibility with the #+acl2-loop-only definition.

  nil)

#+acl2-loop-only
(defun print-call-history ()

; Keep the return value in sync with the #-acl2-loop-only definition.

  (declare (xargs :guard t))
  nil)

(defmacro debugger-enabledp-val (val)
  `(and (member-eq ,val '(t :break :break-bt :bt-break))
        t))

(defun debugger-enabledp (state)
  (declare (xargs :guard (and (state-p state)
                              (boundp-global 'debugger-enable state))))
  (debugger-enabledp-val (f-get-global 'debugger-enable state)))

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

  `(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 system::*break-enable* (debugger-enabledp-val val)))
  (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.  The "mac" suffix is for "macro".

  'state)

#+acl2-par
(defmacro state-mac@par ()

; Keep in sync with state-mac.  The "mac" suffix is for "macro".

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

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

(defun symbol-constant-fn (prefix sym)
  (declare (xargs :guard (and (symbolp prefix)
                              (symbolp sym))))
  (intern (concatenate 'string
                       (symbol-name prefix)
                       "-"
                       (symbol-name sym))
          "ACL2"))

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

    (getpropc fn 'stobjs-in nil w)))

(defun all-nils (lst)
  (declare (xargs :guard (true-listp lst)))
  (cond ((endp lst) t)
        (t (and (eq (car lst) nil)
                (all-nils (cdr lst))))))

(defconst *ttag-fns-and-macros*

; Each cdr is either nil or a msg.

  `((hons-wash!)
    (hons-clear!)
    (open-output-channel!)
    (progn!) ; protected because it is legal in books; it's OK to omit progn-fn
    (remove-untouchable-fn
     .
     ,(msg "  Note that the same restriction applies to the macro ~x0, whose ~
            expansions generate calls of ~x1."
           'remove-untouchable
           'remove-untouchable-fn))
    (set-raw-mode-on
     .
     ,(msg "  If you do not plan to certify books in this session, then ~
            instead you may want to call ~x0; see :DOC ~x0."
           'set-raw-mode-on!))
    (set-temp-touchable-fns)
    (set-temp-touchable-vars)
    (sys-call)
    (sys-call*)
    (sys-call+)
    ))

#-acl2-loop-only
(progn

; We implement a very simple cache for ev-fncall-w-guard, in support of
; ev-fncall-w and magic-ev-fncall.

(defconstant *ev-fncall-w-guard1-cache-size*

; This size is rather arbitrary.  We avoid making it too large, to avoid having
; a cache that takes up a lot of memory, as it holds a world in each entry.

  10)

(defconstant *ev-fncall-w-guard1-cache-init*
  (cons 0 (make-list *ev-fncall-w-guard1-cache-size*)))

(defvar *ev-fncall-w-guard1-cache*
  *ev-fncall-w-guard1-cache-init*)

(defun ev-fncall-w-guard1-cache-clear ()
  (let ((cache *ev-fncall-w-guard1-cache*))
    (setf (car cache) 0)
    (loop for tail on (cdr cache)
          do
          (setf (car tail) nil))))

(defun ev-fncall-w-guard1-cache-lookup (fn wrld temp-touchable-fns)
  (let ((tuple (assoc-eq fn (cdr *ev-fncall-w-guard1-cache*))))
    (and (consp tuple)
         (or (and (eq (cadr tuple) wrld)
                  (eq (caddr tuple) temp-touchable-fns)
                  (cdddr tuple))

; Otherwise eliminate the tuple's key, so that this tuple doesn't get found
; next time we look up fn in the cache.

             (setf (car tuple) nil)))))

(defun ev-fncall-w-guard1-cache-update (fn wrld temp-touchable-fns data)

; This function is thread-safe, in the sense that it will always result in a
; valid update.

  (let* ((cache *ev-fncall-w-guard1-cache*)
         (index (car cache))
         (alist (cdr cache)))
    (when (>= (incf index) *ev-fncall-w-guard1-cache-size*)
; Avoid using (= index *ev-fncall-w-guard1-cache-size*), for thread safety
      (setq index 0))
    (let ((tail (nthcdr index alist)))
      (setf (car tail)
            (list* fn wrld temp-touchable-fns data)))))

; It is a bit tempting to add
; (declaim (inline ev-fncall-w-guard1))
; but a bit of experimentation suggests that this doesn't help.
)

(defun logicp (fn wrld)

; We assume that fn is not the name of a theorem (presumably it's a function
; symbol), in order to avoid the use of symbol-class, which can check the
; 'theorem property of fn.

  (declare (xargs :guard (and (plist-worldp wrld)

; We deliberately avoid adding the conjunct (function-symbolp fn), even though
; we expect it to be true when we call logicp.  Otherwise we would incur more
; proof obligations; indeed, guard verification would fail for arities-okp.

                              (symbolp fn))))
  (not (eq (getpropc fn 'symbol-class nil wrld)
           :program)))

(defmacro logicalp (fn wrld)
; DEPRECATED in favor of logicp!
  `(logicp ,fn ,wrld))

(defmacro programp (fn wrld)

; We assume that fn is not the name of a theorem (presumably it's a function
; symbol), in order to avoid the use of symbol-class, which can check the
; 'theorem property of fn.

  `(not (logicp ,fn ,wrld)))

(defconst *stobjs-out-invalid*
  '(if return-last))

(defun stobjs-out (fn w)

; Warning: keep this in sync with get-stobjs-out-for-declare-form.

; See the Essay on STOBJS-IN and STOBJS-OUT.

; Note that even though the guard implies (not (member-eq fn
; *stobjs-out-invalid*)), we keep the member-eq test in the code in case
; stobjs-out is called from a :program-mode function, since in that case the
; guard may not hold.

  (declare (xargs :guard (and (symbolp fn)
                              (plist-worldp w)
                              (not (member-eq fn *stobjs-out-invalid*)))))
  (cond ((eq fn 'cons)
; We call this function on cons so often we optimize it.
         '(nil))
        ((member-eq fn *stobjs-out-invalid*)
         (er hard! 'stobjs-out
             "Implementation error: Attempted to find stobjs-out for ~x0."
             fn))
        (t (getpropc fn 'stobjs-out '(nil) w))))

(defun ev-fncall-w-guard1 (fn wrld temp-touchable-fns)

; See ev-fncall-w-guard.  Here we use a cache to avoid most of that computation
; in some cases.  We return the length of the formals of fn if all the expected
; conditions hold, else nil.

  (declare (xargs :guard t))
  #-acl2-loop-only
  (let ((data (ev-fncall-w-guard1-cache-lookup fn wrld
                                               temp-touchable-fns)))
    (when data
      (return-from ev-fncall-w-guard1 data)))
  (and (plist-worldp wrld)
       (symbolp fn)

; We avoid potential problems obtaining the stobjs-out of 'if.  (We give
; special handling to 'return-last in ev-fncall-w-guard1, so we don't need to
; avoid it here.)

       (not (eq fn 'if))
       (not (assoc-eq fn *ttag-fns-and-macros*))
       (let* ((formals (getpropc fn 'formals t wrld))
              (stobjs-in (stobjs-in fn wrld))
              (untouchable-fns (global-val 'untouchable-fns wrld)))

; It is tempting to call untouchable-fn-p, but it seems inconvenient to fold
; the necessary true-listp tests into that macro.  So we open-code here.

         (and (not (eq formals t))
              (true-listp untouchable-fns)
              (or (not (member-eq fn untouchable-fns))
                  (eq t temp-touchable-fns)
                  (and (true-listp temp-touchable-fns)
                       (member-eq fn temp-touchable-fns)))

; Perhaps we could skip the next check.  It is equivalent to (not
; (stobj-creatorp fn wrld)), but stobj-creatorp is defined later.

              (not (and (null formals)
                        (getpropc fn 'stobj-function nil wrld)))
              (true-listp stobjs-in) ; needed for guard of all-nils
              (all-nils stobjs-in)
              (let ((data (list* (len formals)
                                 (programp fn wrld)
                                 (if (eq fn 'return-last)

; We handle return-last in raw-ev-fncall-simple as we do in raw-ev-fncall.

                                     '(nil)
                                   (stobjs-out fn wrld)))))
                #-acl2-loop-only
                (progn
                  (ev-fncall-w-guard1-cache-update fn wrld temp-touchable-fns
                                                   data)
                  data)
                #+acl2-loop-only
                data)))))

(defun ev-fncall-w-guard (fn args wrld temp-touchable-fns)

; This function should return nil if the term (cons fn (kwote-lst args)) can
; not be translated for execution.  See translate11.

; Warning: If this function is changed, then consider changing the table guard
; for dive-into-macros-table.

  (declare (xargs :guard t))
  (let ((len-formals/programp/stobjs-out
         (ev-fncall-w-guard1 fn wrld temp-touchable-fns)))
    (and len-formals/programp/stobjs-out
         (true-listp args)
         (eql (car len-formals/programp/stobjs-out)
              (length args))
         (cdr len-formals/programp/stobjs-out))))

(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 :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))
        (:start! (tt-start tag t)))
      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)

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

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

(defun tau-interval-lo-rel (x)
  (declare (xargs :guard (and (consp x) (consp (cdr x)) (consp (cadr x)))))
  (car (cadr x)))

(defun tau-interval-lo (x)
  (declare (xargs :guard (and (consp x) (consp (cdr x)) (consp (cadr x)))))
  (cdr (cadr x)))

(defun tau-interval-hi-rel (x)
  (declare (xargs :guard (and (consp x) (consp (cdr x)) (consp (cddr x)))))
  (car (cddr x)))

(defun tau-interval-hi (x)
  (declare (xargs :guard (and (consp x) (consp (cdr x)) (consp (cddr x)))))
  (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)))))
  (cons dom (cons (cons lo-rel lo)
                  (cons hi-rel hi))))

(defun tau-intervalp (int)
  (declare (xargs :guard t))
  (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)))
  (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))))

; We added the following three defthm forms at the request of Jared Davis, who
; noted that many book that seem to depend on community book
; books/arithmetic/top.lisp can get by with just these three theorems.  We
; might consider adding analogues for multiplication as well, but that could
; break a lot of books.  Since we already build in linear arithmetic but not
; (by default) non-linear arithmetic, we think it not unreasonable to include
; these rules only for addition and not multiplication.

(defthm commutativity-2-of-+
  (equal (+ x (+ y z))
         (+ y (+ x z))))

(defthm fold-consts-in-+
  (implies (and (syntaxp (quotep x))
                (syntaxp (quotep y)))
           (equal (+ x (+ y z))
                  (+ (+ x y) z))))

(defthm distributivity-of-minus-over-+
  (equal (- (+ x y))
         (+ (- x) (- y))))

; The following was moved here from other-events.lisp (and tweaked slightly in
; order to be guard-verified) so that it is included in the toothbrush.

(defun decimal-string-to-number (s bound expo)

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

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

(defun check-dcl-guardian (val term)

; See call of (set-guard-msg check-dcl-guardian ...) later in the sources.  The
; term argument is included in support of the call (set-guard-msg
; check-dcl-guardian ...) in these sources.

  (declare (xargs :guard val))
  (declare (ignore val term))
  t)

(defconst *gc-strategy-alist*
  '((:egc   . set-gc-strategy-builtin-egc)
    (:delay . set-gc-strategy-builtin-delay)))

(defun set-gc-strategy-fn (op threshold)

; The first call of this function cannot be made with op = :current, since
; *gc-strategy* will not yet be bound.

  (declare (xargs :guard (or (eq op :current)
                             (assoc-eq op *gc-strategy-alist*)))
           #+(and ccl (not acl2-loop-only))
           (special *gc-strategy*)
           (ignorable threshold))
  #+(and ccl (not acl2-loop-only))
  (let* ((op (if (eq op :current) *gc-strategy* op))
         (fn (cdr (assoc-eq op *gc-strategy-alist*))))
    (ccl-initialize-gc-strategy threshold)
    (assert (and (symbolp fn)
                 (fboundp fn)))
    (setq *gc-strategy* op)
    (funcall fn))
  #+(and (not ccl) (not acl2-loop-only))
  (cw "; Note: Set-gc-strategy is a no-op in this host Lisp.~|")
  op)

(defmacro set-gc-strategy (op &optional threshold)
  `(set-gc-strategy-fn ,op ,threshold))

(defun gc-strategy (state)
  (declare (xargs :stobjs state)
           #+(and ccl (not acl2-loop-only))
           (special *gc-strategy*))
  #+(not acl2-loop-only)
  (when (live-state-p state)
    (return-from
     gc-strategy
     (value #+ccl
            *gc-strategy*
            #-ccl
            (cw "; Note: Set-gc-strategy is a no-op in this host Lisp.~|"))))
  (read-acl2-oracle state))

(defun file-length$ (file state)
  (declare (xargs :guard (stringp file)
                  :stobjs state))
  #+acl2-loop-only
  (declare (ignore file))
  #-acl2-loop-only
  (when (live-state-p state)
    (return-from file-length$
                 (mv (our-ignore-errors
                      (with-open-file
                        (str file
                             :direction :input
                             :element-type '(unsigned-byte 8)
                             :if-does-not-exist nil)
                        (and str (file-length str))))
                     state)))
  (mv-let (erp val state)
          (read-acl2-oracle state)
          (mv (and (null erp)
                   (natp val)
                   val)
              state)))

(encapsulate
  ()

; The following function symbols are used (ancestrally) in the constraints on
; concrete-badge-userfn and concrete-apply$-userfn.  They must be in logic
; mode.  We use encapsulate so that verify-termination-boot-strap will do its
; intended job in the first pass of the build.

  (logic)
  (verify-termination-boot-strap booleanp)
  (verify-termination-boot-strap all-nils)
  (verify-termination-boot-strap member-eql-exec)
  (verify-termination-boot-strap member-eql-exec$guard-check)
  (verify-termination-boot-strap member-equal)
  (verify-termination-boot-strap subsetp-eql-exec)
  (verify-termination-boot-strap subsetp-eql-exec$guard-check)
  (verify-termination-boot-strap subsetp-equal)
  (verify-termination-boot-strap revappend)
  (verify-termination-boot-strap first-n-ac)
  (verify-termination-boot-strap take))

(defmacro when-pass-2 (&rest x)

; This alternative to when-logic is useful in apply.lisp and related files,
; where we want to avoid compilation because of the use of make-event, and we
; also want to avoid evaluation during pass 1 of initialization, because we are
; waiting for a suitable function-theory.  We cannot simply define when-logic
; to be nil in raw Lisp, becase its use is not limited to the definition of
; local.

  #-acl2-loop-only
  (declare (ignore x))
  #-acl2-loop-only
  nil
  #+acl2-loop-only
  (list 'if
        '(eq (default-defun-mode-from-state state)
             :program)
        (list 'skip-when-logic (list 'quote "WHEN-PASS-2") 'state)
        `(progn!
          :state-global-bindings
          ((ld-skip-proofsp t))

; Since when-pass-2 avoids raw Lisp compilation, we instruct ACL2 to compile
; on-the-fly.  This is unnecessary for Lisps that always compile, but it seems
; harmless for us to avoid making an exception for those Lisps, for which
; set-compile-fns is a no-op.

          (set-compile-fns t)
          ,@x
          (set-compile-fns nil))))