axioms.lisp

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

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

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

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

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

; 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, as with other ACL2 source files, is read in two ways: first by
; Common Lisp, and second by the ACL2 read-eval-print loop.  The process is
; roughly as follows ("roughly", because for example we never compile
; acl2.lisp).

;   (1) If the Lisp compiles on-the-fly (currently SBCL or CCL), then this step
;       is skipped.  Otherwise we compile the ACL2 source files.

;   (2) In a fresh Lisp session, we load the source files if the Lisp compiles
;       on-the-fly (currently SBCL or CCL), and otherwise, the compiled files.

;   (3) In the same session as (2), we add :acl2-loop-only to *features* and
;       then we LD each source file.

; Suppose for example a source file has the following code.

;   (defun foo (x)
;     #-acl2-loop-only
;     <expression_1>
;     #+acl2-loop-only
;     <expression_2>)

; Then in steps (1) and (2) the body of this definition is <expression_1>, but
; in step (3) it is <expression_2>.

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

      ))

#+acl2-loop-only
(defconst nil

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

  'nil)

#+acl2-loop-only
(defconst t

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

  't)

(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.  Also see the companion
; Essay on Hidden Packages Added by Certify-book for how certify-book arranges
; to track hidden defpkg events.

; 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 hidden defpkg events as appropriate.  Of course,
;   these extra hidden defpkg events are not counted when checking against a
;   numeric argument supplied as the second argument of certify-book.

;   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
;   (or see :DOC hidden-defpkg, which is just a pointer to :DOC
;   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 of that existing hidden 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.  (At least we think
; so; but ultimately we do not rely on this for soundness, since :puff sets
; world global 'skip-proofs-seen, which defeats certification.)

; 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)
  `(remove1-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*

; The value of this 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.

; Historical Note: Through Version_8.2, for a stobj named st, (the-live-var st)
; was a special variable whose value was the live object.  E.g., if you
; did (defstobj st ...) then in raw Lisp *the-live-st* held the actual
; vector or hash table.  Now it's (cdr (assoc 'st *user-stobj-alist*)).

  nil)

(defvar *non-executable-user-stobj-lst*
  nil)

; Essay on the Wormhole Implementation Nexus

; The implementation of wormhole and wormhole-eval are scattered over many
; source files and functions and macros.  When one of those functions or macros
; is changed it is often necessary to change others.  We call this group of
; names the ``wormhole implementation nexus.''  The functions (or macros) in
; question are:

;  wormhole-eval             ; obviously relevant top-level defs
;  wormhole                  ; obviously relevant top-level defs
;  wormhole1                 ; workhorse of wormhole
;  ev-rec                    ; recapitulate def of wormhole-eval
                             ;  for interpreted execution in ACL2 loop
;  translate11-wormhole-eval ; enforce syntactic restrictions on args
;  translate11-call-1        ; enforce syntactic restrictions on args
;  translate11-call          ; enforce syntactic restrictions on args
;  guard-clauses             ; guarantee guards on quoted entry lambdas
;  oneify                    ; correct execution of *1* calls

; If you change one of these, look at all the others!  In that quest, visit
; each function and search for ``wormhole''.  Be sure to pay attention to the
; #-acl2-loop-only cases.  For example, wormhole-eval has a #+acl2-loop-only
; defun and, a few definitions below that, a #-acl2-loop-only defmacro.

; The definition of each function and macro above is marked with the comment:

; Warning: Keep this function in sync with the other functions listed in the
; Essay on the Wormhole Implementation Nexus in axioms.lisp.

; If you're changing wormhole or wormhole-eval, be advised that there are many
; more functions involved in its correct execution despite rather tenuous
; call-graph connections.

; The problem there is that wormhole calls ld and ld reads from the user and
; can execute virtually any ACL2 function -- and many functions detect that
; they're being called under a wormhole and behave differently than they would
; otherwise.  They are not included in the nexus but you might have to look at
; them.

; For example, wormhole1 binds the special raw Lisp variable *wormholep*, which
; tells raw Lisp code that it is executing under a wormhole.  The following 35
; functions (in axioms.lisp, basis-a.lisp, boot-strap-pass-2-a,
; futures-raw.lisp, history-management.lisp, interface-raw.lisp, ld.lisp, and
; translate.lisp) all mention that variable and behave differently when it's
; true than when its nil: hard-error, one-output, makunbound-global,
; put-global, f-put-global, princ$, write-byte$, open-input-channel,
; close-input-channel, open-output-channel, fmt-to-comment-window-raw,
; get-output-stream-string$-fn, close-output-channel, read-char$, peek-char$,
; read-byte$, read-object, prin1-with-slashes, read-idate, read-run-time,
; prin1$, wormhole1, wormhole-p, wormhole-eval,
; sync-ephemeral-whs-with-persistent-whs, one-output,
; write-user-stobj-alist-raw, make-closure-expr-with-acl2-bindings, set-w,
; oneify-cltl-code, ld-loop, ld-fn-body, and ev-rec.  These functions are not
; in the nexus, they are not necessarily even called by wormhole but instead
; may be called by the read-eval-print loop in ld, as determined by user input.
; Whether you should look at them when you're changing wormhole depends on what
; changes you're making.

; Another way wormholes are distantly but critically linked to functions not
; called in the implementation is via the *wormhole-cleanup-form*.  This form
; is bound by wormhole1 to a raw Lisp form that grows as expressions are
; executed under a wormhole.  The final value of *wormhole-cleanup-form* is
; eval'd in raw Lisp as the wormhole exits.  The function that adds
; subexpressions to *wormhole-cleanup-form* is push-wormhole-undo-formi.  It is
; not sensitive to *wormholep* and so it is not mentioned in the big
; ``secondary'' list above.  But it is called by many of the functions in that
; list.  When called it may add a subexpression to the cleanup form.  That
; subexpression may appear as a quoted raw Lisp term in
; push-wormhole-undo-formi, or may be consed up from symbols there.  So the
; call-graph is obscured.  That subexpression may mention functions not
; otherwise linked to wormholes, e.g., compress1.  And so compress1 can be
; called when wormholes are operating, despite the tenuous connection.

; We should note that wormhole has another warning in it, stemming from its
; use of ld.

; Warning: Also, keep this in sync with f-get-ld-specials, f-put-ld-specials,
; *initial-ld-special-bindings*, ld-alist-raw, chk-acceptable-ld-fn1-pair, and
; ld.

; We have droned on about this issue to bring home the problem, suggest ways to
; find the functions you'll need to look at, and impress upon you that the
; rather short list nexus names is just the tip of the iceberg.  The bottom
; line is simply: think twice before wandering into the definition of wormhole!

; End of Essay on the Wormhole Implementation Nexus

; 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 "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-ephemeral-whs 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-ephemeral-whs safety-set STATE) and
; new formis are added immediately after save-ephemeral-whs, making the final
; form a stack with save-ephemeral-whs always on top and the formi succeeding
; it in reverse order of their storage.  The save-ephemeral-whs form will save
; into the persistent wormhole status the final value of the ephemeral wormhole
; status (except for the brr wormhole which is treated differently).  The
; save-ephemeral-whs 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 we do our
; best.

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

; About brr-evisc-tuple and Its Mirror

; In past implementations of break-rewrite brr-evisc-tuple was only a component
; of the brr status and had no special value outside of the brr wormhole.
; However, in the current implementation brr-evisc-tuple is a full-fledged,
; system-maintained, untouchable state global variable like ld-evisc-tuple.  It
; can be read and written in or out of the brr wormhole, but the only use of it
; in system code is by break-rewrite when it is printing terms.  This
; implementation is essentially based on the implementation of
; *wormhole-iprint-ar*, etc.

; Every time the state global variable 'brr-evisc-tuple is set via
; set-site-evisc-tuple (actually by set-brr-evisc-tuple1) we also set this raw
; Lisp var, *wormhole-brr-evisc-tuple*, to the same value.  This variable can
; thus be thought of as a ``mirror'' of brr-evisc-tuple.  Unwind protection in
; wormhole1 undoes the setting of the state global value of 'brr-evisc-tuple
; when we pop out of break-rewrite, but cleanup does not mess with the mirrored
; value.  The function brr-evisc-tuple-oracle-update is called in
; eviscerate-top and eviscerate-stobjs-top, to restore brr-evisc-tuple to its
; mirrored value before anything interesting happens.

(defvar *wormhole-brr-evisc-tuple* :default)
)

#-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-ephemeral-whs 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-ephemeral-whs 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*)

; Originally we used interface-er here.  However, that could get us into an
; infinite loop in Version_8.1, for example as follows.

;   (accumulated-persistence t)
;   (trace$ pop-accp-fn)
;   (mini-proveall)

; The essence of the problem in the example just above was that pop-accp-fn is
; called inside wormhole-eval (see pop-accp), which doesn't seem to accommodate
; state modification; indeed, as documented, wormhole1 should be used in that
; case.  Yet state global trace-level was modified during tracing, by
; custom-trace-ppr.  (That is no longer the case, but was so in Version_8.1.)
; The following example, derived from the one above, makes this more clear.

;   (defn foo (n) n)
;   (value :q)
;   ; Derived from (trace$ foo):
;   (CCL:ADVISE foo
;               (PROGN (SETQ *TRACE-ARGLIST* CCL:ARGLIST)
;                      (CUSTOM-TRACE-PPR
;                       :IN
;                       (CONS 'FOO
;                             (TRACE-HIDE-WORLD-AND-STATE
;                              *TRACE-ARGLIST*))))
;               :WHEN
;               :BEFORE)
;   (lp)
;   (wormhole-eval 'demo
;                  '(lambda (whs) (set-wormhole-data whs (foo 6)))
;                  nil)

; So now we use error instead of interface-er, to avoid the infinite loop.

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

; See the comment above describing why we avoid interface-er.

       (error "Unrecognized op in push-wormhole-undo-formi, ~s." 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 it may help to see :DOC raw-lisp-error.~&")

(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.  It may also help to see :DOC raw-lisp-error.~&")

(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
           gc-off1 ; used in oneified code
           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
           untouchable-marker
           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.

; 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 include
; STATE as a formal, 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!

; Note: In apply-raw.lisp we use a relaxed version of the expansion of
; defun-overrides that ignores the requirement that STATE be a formal!  We use
; that relaxed code to define doppelganger-badge-userfn and
; doppelganger-apply$-userfn.  The basic argument is that it is ok to secretly
; look at the current world as long as we cause an error if the current world
; does not specify a value for the notion being ``defined'' and that once the
; world does specify a value that value never changes.  If more functions like
; these two arise in the future we may wish to relax defun-overrides or at
; least define a relaxed version of it.

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

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

; The value of this variable is t when we are inside an include-book that is
; not being performed by the local compatibility check of certify-book.
; Otherwise the value is nil unless we are inside certify-book in either of two
; cases: inside hcomp-build-from-state, or inside a call of include-book made
; by the local compatibility check.

; 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 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
                             save-event-data)
  (declare (ignore form on-behalf-of save-event-data))
  (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))))

(defun defconst-redeclare-error (name)
  (let ((stk (symbol-value '*load-compiled-stack*))
        (project-dir-alist (project-dir-alist (w *the-live-state*)))
        (ctx 'defconst-redeclare-error))
    (cond
     (stk (error
           "Illegal attempt to redeclare the constant ~s.~%~
            The problem appears to be that you are including a book,~%~
            ~2T~a,~%~
            that attempts to give a definition of this constant that~%~
            is incompatible with its existing definition.  The ~%~
            discrepancy is being discovered while loading that book's~%~
            compiled (or expansion) file~:[, as the last such load for~%~
            the following nested sequence of included books (outermost~%~
            to innermost):~%~{  ~a~%~}~;.~]"
           name
           (book-name-to-filename-1 (caar stk) project-dir-alist ctx)
           (null (cdr stk))
           (book-name-lst-to-filename-lst
            (reverse-strip-cars stk nil)
            project-dir-alist
            ctx)))
     (t (error "Illegal attempt to redeclare the constant ~s."
               name)))))
)

;                          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

(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
                  :mode :logic))
  (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 x x-equiv)
           (equal (implies x y) (implies x-equiv y)))
  :rule-classes (:congruence))

(defthm iff-implies-equal-implies-2
  (implies (iff y y-equiv)
           (equal (implies x y) (implies x y-equiv)))
  :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)

; Warning: If you change this definition, make the corresponding change in the
; definition of macroexpand1-cmp!

  (list-macro args))

(defmacro list$ (&rest args)

; The logical definitions agree for this macro and list.  But in raw Lisp, a
; macro call of list$ expands to a nest of cons calls, which allows GCL version
; 2.7.0 (and presumably later versions) to avoid causing an error when list is
; called on too many arguments.

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

; Warning: If you change this definition, make the corresponding change in the
; definition of macroexpand1-cmp!

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

; Warning: If you change this definition, make the corresponding change in the
; definition of macroexpand1-cmp!

   (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 :mode :logic))
  (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
(declaim (ftype (function (t) fixnum) len))

(defun len (x)
  (declare (xargs :guard t :mode :program))
  #-acl2-loop-only
  (loop with acc of-type (and fixnum (integer 0 *)) = 0
        for nil on x
        do (if (= acc most-positive-fixnum)

; We really don't expect lists of length greater than most-positive-fixnum.
; But we do the check above, potentially (though unlikely) causing this error,
; to be faithful to the ftype declaim form above.

               (error "~s was given a a list whose length is not a fixnum!"
                      'len)
             (incf acc))
        finally (return acc))
  #+acl2-loop-only
  (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 :program))
  (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 :mode :program))
  (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)))))

(verify-termination-boot-strap :skip-proofs
                               len (declare (xargs :mode :logic)))
(verify-termination-boot-strap :skip-proofs
                               length (declare (xargs :mode :logic)))
(verify-termination-boot-strap :skip-proofs
                               acl2-count (declare (xargs :mode :logic)))

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

; Warning: If you change this definition, make the corresponding change in the
; definition of macroexpand1-cmp!

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

(defconst *null-char*
  (code-char 0))

(defun make-character-list (x)

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

  (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 *null-char* (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)

; Warning: If you change this definition, make the corresponding change in the
; definition of macroexpand1-cmp!

  (list 'car (list 'cdr x)))

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

#+acl2-loop-only
(defmacro cddr (x)

; Warning: If you change this definition, make the corresponding change in the
; definition of macroexpand1-cmp!

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

; The rule symbol-listp-forward-to-true-listp was formerly here, but it's
; subsumed by a combination of the following strengthening together with
; eqlable-listp-forward-to-atom-listp, and atom-listp-forward-to-true-listp.
(defthm symbol-listp-forward-to-eqlable-listp
       (implies (symbol-listp x)
                (eqlable-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 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
(progn

(defvar *hard-error-returns-nilp*

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

  nil)

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

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

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

(defvar *raw-ev-fncall-catchable* nil)

(defmacro catch-raw-ev-fncall (&rest forms)
  `(let ((*raw-ev-fncall-catchable* t))
     (catch 'raw-ev-fncall
       ,@forms)))
)

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

(defun hard-error (ctx str alist)

; Str is often a fmt string to print with respect to alist.  But it may also be
; a cons pair (summary . str), where str is as above and summary is a string
; that could be a key of inhibit-er-table.

; 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 :mode :logic))
  #-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*)
          (summary (if (consp str) (car str) nil))
          (str (if (consp str) (cdr str) str)))
      (cond
       (*hard-error-is-error*
        (if (fboundp 'hard-error-is-error) ; for early in boot-strap
            (hard-error-is-error ctx str alist)
          (error "Error during ACL2 build in ctx ~s with string~%~s~%and ~
                  alist~%~s"
                 ctx str alist)))
       (t
        (when (not (inhibit-er-hard state))
          (let ((*standard-output* *error-output*)
                (*wormholep* nil))
            (error-fms t ctx summary str alist state)))

; Here is a historical comment, perhaps no longer directly relevant.

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

        (if *raw-ev-fncall-catchable*
            (throw-raw-ev-fncall 'illegal)

; Before we introduced catch-raw-ev-fncall, it was possible to get a raw Lisp
; error at the top level from a hard error during translate, because there was
; no catcher for the tag thrown to by the call just above of
; throw-raw-ev-fncall, which is 'raw-ev-fncall.  Now we abort cleanly.  It's a
; bit unfortunate perhaps that we abort all the way to the top level, so
; hard-error should be used sparingly when not in the scope of
; catch-raw-ev-fncall.

          (abort!))))))
  #+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-atomp), 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)
             (and (consp arg2)
                  (or (eq (car arg2)
                          'quote)
; Avoid paying the price of binding *aokp* below when arg2 is of the form
; (untouchable-marker (quote name)), as generated by defmacro-untouchable:
                      (and (eq (car arg2)
                               'untouchable-marker)
                           (consp (cdr arg2))
                           (null (cddr arg2))
                           (let ((arg (cadr arg2)))
                             (and (consp arg)
                                  (consp (cdr arg))
                                  (null (cddr arg))
                                  (eq (car arg) 'quote)))))))

; Under each of the conditions above, we avoid doing the *aokp* binding below.

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

(defun character-alistp (x)
  (declare (xargs :guard t))
  (cond ((atom x) (eq x nil))
        (t (and (consp (car x))
                (characterp (car (car x)))
                (character-alistp (cdr x))))))

(defthm character-alistp-forward-to-eqlable-alistp
  (implies (character-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-safe (key alist)

; This function supports translation of do loop$ expressions; see
; var-to-cdr-assoc-var-substitution.

  (declare (xargs :guard (symbolp key)))
  (cond ((atom alist)
         nil)
        ((and (consp (car alist))
              (eq key (caar alist)))
         (car alist))
        (t
         (assoc-eq-safe key (cdr alist)))))

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

(defun assoc-eq-cadr (x alist)
  (declare (xargs :guard (and (symbolp x)
                              (alistp alist)
                              (alistp (strip-cdrs alist)))))
  (cond ((endp alist) nil)
        ((eq x (cadr (car alist))) (car alist))
        (t (assoc-eq-cadr x (cdr alist)))))

(defun assoc-equal-cadr (x alist)
  (declare (xargs :guard (and (alistp alist)
                              (alistp (strip-cdrs alist)))))
  (cond ((endp alist) nil)
        ((equal x (cadr (car alist))) (car alist))
        (t (assoc-equal-cadr x (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))))

(defaxiom nonnegative-product

; Note that in (* x x), x might be complex.  So, we do not want to force the
; hypothesis below.

; This axiom can be proved.  John Cowles has proved some such axioms and we
; have proved others in our efforts to verify the guards in our code.
; Eventually we may 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.

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

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

#-(or acl2-loop-only gcl)
(declaim

; This declaim form avoids warnings that would otherwise be generated during
; the boot-strap (in CCL, at least) by ec-call.  We don't bother in GCL because
; the declaim form itself has caused a warning!

 (ftype function
        acl2_*1*_acl2::apply$
        acl2_*1*_acl2::rewrite-rule-term-exec
        acl2_*1*_acl2::linear-lemma-term-exec
        acl2_*1*_acl2::conjoin
        acl2_*1*_acl2::pairlis$
        acl2_*1*_acl2::close-input-channel
        acl2_*1*_acl2::warnings-as-errors-val
        acl2_*1*_acl2::member-equal
        acl2_*1*_acl2::brr-data-mirror))

#-acl2-loop-only
(defmacro to-df (x)

; This raw Lisp definition of to-df would naturally seem to belong in
; float-a.lisp next to the #+acl2-loop definition of to-df.  Instead we define
; it here so that it's defined before the definition of ec-call1-raw-dfs,
; below.  That may be important since to-df is a macro, which in turn is
; because we want it expanded away before compilation: the byte length of the
; assembly code produced by the following roughly doubles in CCL if to-df is
; instead merely the obvious inlined function.

; (disassemble (defun f (x) (declare (type double-float x)) (df+ 5 x)))

; We use (float x 0.0D0) here, rather than (coerce x 'double-float), since we
; rely an the float-rational identity discussed in a comment in
; constrained-to-df-idempotent.

; It is however tempting to avoid (float x 0.0D0) in favor of (coerce x
; 'double-float), since the latter seems to have a clearer specification than
; the former.

; The CL HyperSpec says this about coerce at
; http://www.lispworks.com/documentation/HyperSpec/Body/f_coerce.htm#coerce

;   If the result-type is any of float, short-float, single-float,
;   double-float, long-float, and the object is a real, then the result is a
;   float of type result-type which is equal in sign and magnitude to the
;   object to whatever degree of representational precision is permitted by
;   that float representation. (If the result-type is float and object is not
;   already a float, then the result is a single float.)

; So it should be fine to use coerce here.  But the CL HyperSpec is less clear
; that we can use (float x 0.0D0); here is what the page on float
; (http://www.lispworks.com/documentation/HyperSpec/Body/f_float.htm) says:

;   If a prototype is supplied, a float is returned that is mathematically
;   equal to number but has the same format as prototype.

; That doesn't seem to specify the value of (float 1/3 0.0D0), since 1/3 isn't
; representable.

; Fortunately, even though that's unfortunate, it doesn't seem to be important
; for our purposes.

  (cond ((rationalp x) ; compute suitable constant at compile time
         (float x 0.0D0))
        ((and (consp x)
              (eq (car x) 'quote)
              (consp (cdr x))
              (rationalp (cadr x))
              (null (cddr x)))
         (float (cadr x) 0.0D0))
        (t
         `(float ,x 0.0D0))))

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

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

#-acl2-loop-only
(declaim (inline ec-call1-raw-dfs))

#-acl2-loop-only
(defun ec-call1-raw-dfs (x flg form n)

; If flg is nil or x is a double-float, then return x.  Otherwise x should be a
; representable rational (because x was produced by a df or df{i} expression),
; and we return the double-float that represents x.

; But what is the point of this function?

; Ec-call presents a bit of an implementation challenge.  Recall that ec-call
; invokes executable-counterpart (*1*) functions.  Also note that code
; generated for *1* functions is designed to return ordinary objects, not
; double-floats.  Yet ec-call invokes *1* functions, hence returns ordinary
; objects where raw Lisp code might expect a double-float.

; When a guard-verified function or program-mode function leads to evaluation
; of an ec-call form in raw Lisp, the caller may expect double-float outputs.
; So ec-call's expansions in raw Lisp need to make adjustments to the outputs
; when double-floats are expected.  The :dfs-out argument of ec-call tells Lisp
; when to convert rationals returned by a *1* function to double-floats.

  (cond ((null flg) x)
        ((typep x 'double-float) x)
        (t (let ((val (and (rationalp x)
                           (let ((val (to-df x)))
                             (and (= val x)
                                  val)))))
             (or val
                 (let ((*print-pretty* t))
                   (error "Implementation error (please contact the ACL2 ~
                           implementors):~%~s error:~%Form: ~s~%Value~a that ~
                           does not represent a double-float:~%  ~s"
                          'ec-call
                          form
                          (if n
                              (format nil " (at position ~s)" n)
                            "")
                          x)))))))

(defun qdfs-check (qdfs)

; Qdfs might be nil, 'nil, or '(b1 ... bk) where each bi is Boolean.  Note that
; 'nil is actually a special case of the last of these, where k=0.

  (declare (xargs :guard t))
  (or (null qdfs)
      (and (true-listp qdfs)
           (= (length qdfs) 2)
           (eq (car qdfs) 'quote)
           (boolean-listp (cadr qdfs)))))

#-acl2-loop-only
(defmacro ec-call1-raw (qdfs-in/qdfs-out x)

; X is a call of ec-call.  Qdfs-in/qdfs-out is either nil or is a term of the
; form (cons qdfs-in qdfs-out), where each of qdfs-in and qdfs-out is either
; nil or the quoted :dfs-in/:dfs-out argument from an ec-call.

  (declare (xargs :guard (or (null qdfs-in/qdfs-out)
                             (and (true-listp qdfs-in/qdfs-out)
                                  (eq (car qdfs-in/qdfs-out) 'cons)))))
  (let ((qdfs-in (cadr qdfs-in/qdfs-out))
        (qdfs-out (caddr qdfs-in/qdfs-out)))
    (cond
     ((not (and (consp x) (symbolp (car x))))

; This case is normally impossible, as enforced by translate.  However, it can
; happen if we are not translating for execution; an example is (non-exec
; (ec-call x)).  In that case we simply cause an error at execution time, as a
; precaution, while fully expecting that we never actually hit this case.

      `(error "Implementation error: It is unexpected to be executing a ~
               call~%of ec-call on other than the application of a symbol ~
               to~%arguments, but we are executing it on the form,~%~s."
              ',x))
     ((not (qdfs-check qdfs-in))
      `(error "Implementation error (or incorrect use of implementation ~%~
               macros for ec-call): the :dfs-in argument should be nil or a ~%~
               quoted list of booleans, but it is ~s."
              ',qdfs-in))
     ((not (qdfs-check qdfs-out))
      `(error "Implementation error (or incorrect use of implementation ~%~
               macros for ec-call): the :dfs-out argument should be nil or ~%~
               a quoted list of booleans, but it is ~s."
              ',qdfs-out))
     (t
      (let* ((dfs-in (and qdfs-in (member-eq t (cadr qdfs-in)) (cadr qdfs-in)))
             (dfs-out (and qdfs-out (member-eq t (cadr qdfs-out)) (cadr qdfs-out)))
             (fn (car x))
             (*1*fn (*1*-symbol fn))
             (*1*fn$inline (add-suffix (*1*-symbol (car x)) *inline-suffix*))
             (*1*args (if dfs-in
                          (loop for arg in (cdr x)
                                as d in dfs-in
                                collect
                                (if d
                                    `(rational ,arg)
                                  arg))
                        (cdr x)))
             (form
              `(cond (*safe-mode-verified-p*

; We are presumably in a context where we know that evaluation will not lead to
; an ill-guarded call in raw Lisp.  See *safe-mode-verified-p*.

                      ,x)

; Through Version_8.2 we had a single funcall below, where the first argument
; depended on whether (fboundp ',*1*fn) or else (fboundp ',*1*fn$inline).  But
; SBCL took a very long time to compile the function apply$-prim in
; books/projects/apply-model-2/apply-prim.lisp (and perhaps other such
; apply$-prim definitions), which we fixed by lifting those fboundp tests above
; the calls of funcall.  This reduced the time (presumably virtually all of it
; for compilation) from 1294.33 seconds to 8.12 seconds.

                     ((fboundp ',*1*fn)
                      (funcall ',*1*fn ,@*1*args))
                     ((fboundp ',*1*fn$inline)
                      (funcall
; The following call of macro-function is a sanity check that could be
; omitted.
                       (assert$ (macro-function ',fn)
                                ',*1*fn$inline)
                       ,@*1*args))
                     (t
                      (error "Undefined function, ~s.  Please contact the ~
                              ACL2 implementors."
                             ',*1*fn)))))
        (cond
         ((null dfs-out) form)
         ((null (cdr dfs-out)) ; hence dfs-out = (t)
          `(ec-call1-raw-dfs ,form t ',x nil))
         (t `(let ((lst (multiple-value-list ,form)))
               (values-list
                (loop for e in lst
                      as flg in ',dfs-out
                      as n from 0
                      collect
                      (ec-call1-raw-dfs e flg ',x n)))))))))))

(defmacro ec-call1 (qdfs-in0 qdfs-out0 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).

  (let ((qdfs-in (if (null qdfs-in0) *nil* qdfs-in0))
        (qdfs-out (if (null qdfs-out0) *nil* qdfs-out0)))
    `(return-last 'ec-call1-raw
                  ,(if (and (equal qdfs-in *nil*)
                            (equal qdfs-out *nil*))
                       *nil*
                     `(cons ,qdfs-in ,qdfs-out))
                  ,x)))

(defmacro ec-call (&whole w x &key dfs-in dfs-out)
  (declare (xargs :guard t))
  (let ((dfs-in-check (qdfs-check dfs-in))
        (dfs-out-check (qdfs-check dfs-out)))
    (cond ((and dfs-in-check dfs-out-check)
           `(ec-call1 ,dfs-in ,dfs-out ,x))
          (t (illegal 'ec-call
                      "The call~|~x0~|is illegal because the ~#1~[:dfs-in ~
                       argument fails~/:dfs-out argument fails~/:dfs-in and ~
                       :dfs-out arguments each fail~] to be either nil or a ~
                       quoted true list of Booleans.  See :DOC ec-call."
                      (list (cons #\0 w)
                            (cons #\1 (cond (dfs-out-check 0)
                                            (dfs-in-check 1)
                                            (t 2)))))))))

(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
                  :mode :logic))
  (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 165))
    #+: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 on quoted arguments 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-booleanp-pair*
  #+non-standard-analysis
  '(11 . BOOLEANP)
  #-non-standard-analysis
  '(8 . BOOLEANP))
(defconst *tau-natp-pair*
  #+non-standard-analysis
  '(21 . NATP)
  #-non-standard-analysis
  '(18 . NATP))
(defconst *tau-bitp-pair*
  (cons (+ 1 (car *tau-natp-pair*))
        'BITP))
(defconst *tau-posp-pair*
  (cons (+ 2 (car *tau-natp-pair*))
        'POSP))
(defconst *tau-minusp-pair*
  (cons (+ 13 (car *tau-natp-pair*))
        'MINUSP))

(defun rewrite-lambda-modep (x)
  (declare (xargs :mode :logic :guard t))
  x)

; Elsewhere in this code, e.g., cleanse-type-prescriptions, we use the variable
; named ``def-nume'' to hold the nume of a :definition rune, whereas we use
; ``xnume'' to hold the name of an :executable-counterpart rune.  It's in that
; spirit that we named the constants below to hold the numes for (:definition
; rewrite-lambda-modep) and (:executable-counterpart rewrite-lambda-modep).

(defconst *rewrite-lambda-modep-def-nume*
  (+ *tau-system-xnume* 2))

(defconst *rewrite-lambda-modep-xnume*
  (+ *tau-system-xnume* 3))

; Note: The constants declared above are checked for accuracy after bootstrap
; by check-built-in-constants in interface-raw.lisp.

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

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

(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
                  :mode :logic))
  (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 nat-alistp (x) ; may be used in the guards of some system functions
  (declare (xargs :guard t))
  (cond ((atom x) (eq x nil))
        (t (and (consp (car x))
                (natp (car (car x)))
                (nat-alistp (cdr x))))))

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

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

(verify-termination-boot-strap :skip-proofs
                               o<g (declare (xargs :mode :logic)))
(verify-termination-boot-strap :skip-proofs
                               o< (declare (xargs :mode :logic)))

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

(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-p+ (x)

; The following guard is required by p. 234 of CLtL.

  (declare (xargs :guard t))
  (and (characterp x)
       (standard-char-p x)))

(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
                  :mode :logic))
  (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-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))
                  :mode :logic))
  (cond
   ((stringp x) x)
   ((symbolp x) (symbol-name x))
   (t (coerce (list x) '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))

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

(defthm characterp-nth
  (implies (and (character-listp x)
                (<= 0 i)
                (< i (len x)))
           (characterp (nth i x))))

(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 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
           (replace-live-stobjs-in-list (list ,@formals)))))

(defvar *aokp*

; The variable *aokp* indicates the 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 ()

; See *aokp* for explanation of that variable.

  '*aokp*)

(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
       (declare (special ,at-fn-var *warrant-reqs*))
       (cond ((and ,at-fn-var
                   ,(if (member fn '(apply$-userfn badge-userfn)
                                :test #'eq)
                        '(or (aokp)
                             *warrant-reqs*)
                      '(aokp)))
              (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)
                  :mode :logic))
  (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))

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

(encapsulate
  ()
  (table acl2-defaults-table :defun-mode :logic)
  (verify-termination-boot-strap member-eq-exec$guard-check)
  (verify-termination-boot-strap member-eql-exec$guard-check)
  (verify-termination-boot-strap member-eq-exec)
  (verify-termination-boot-strap member-eql-exec)
  (verify-termination-boot-strap member-equal)
  (verify-termination-boot-strap no-duplicatesp-eq-exec$guard-check)
  (verify-termination-boot-strap no-duplicatesp-eql-exec$guard-check)
  (verify-termination-boot-strap no-duplicatesp-eq-exec)
  (verify-termination-boot-strap no-duplicatesp-eql-exec)
  (verify-termination-boot-strap no-duplicatesp-equal)
  )

(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 finitely 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 it more efficient to use the native assoc; so
; we do the analogous thing here, in raw Lisp.
  (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)
    (comment       "7" 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.

; Warning: With-output depends on :other-than not being a member of this list.

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

; Warning: Keep this list in sync with :doc summary.

; Warning: With-output depends on :other-than not being a member of this list.

  '(errors form header hint-events redundant rules splitter-rules
           steps ; shown as "Prover steps counted"
           system-attachments time value warnings))

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

#+acl2-loop-only
(defun last (l)
  (declare (xargs :guard (listp l)))
  (if (atom (cdr l))
      l
    (last (cdr l))))

(defun last-cdr (x)
  (declare (xargs :guard t))
  (if (atom x)
      x
    (cdr (last x))))

(defthm last-cdr-is-nil
  (implies (true-listp x)
           (equal (last-cdr x) nil)))

(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
  (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))
                   :verify-guards nil))
  #-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))))
  (mbe :logic
       (if (zp n)
           nil
         (cons (car l)
               (take (1- n) (cdr l))))
       :exec
       (first-n-ac n l nil)))

#+acl2-loop-only
(defun butlast (lst n)
  (declare (xargs :guard (and (true-listp lst)
                              (integerp n)
                              (<= 0 n))
                  :mode :program))
  (let ((lng (len lst))
        (n (nfix n)))
    (if (<= lng n)
        nil
      (take (- lng n) lst))))

; 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-member-eq (x alist)
  (declare (xargs :guard (and (symbol-listp x)
                              (assoc-eq-equal-alistp alist))))
  (cond ((endp alist) nil)
        ((member-eq (car (car alist)) x)
         (cons (cadr (car alist))
               (collect-cadrs-when-car-member-eq x (cdr alist))))
        (t (collect-cadrs-when-car-member-eq x (cdr alist)))))

(defmacro value (x)

; Keep in sync with value@par.

; Warning: If you change this definition, make the corresponding change in the
; definition of macroexpand1-cmp!

  `(mv nil ,x state))

(defun legal-constantp1 (name)

; This function should correctly distinguish between variables and
; constants for symbols that are known to satisfy
; legal-variable-or-constant-namep.  Thus, if name satisfies this
; predicate then it cannot be a variable.

  (declare (xargs :guard (symbolp name)))
  (or (eq name t)
      (eq name nil)
      (let ((s (symbol-name name)))
        (and (not (= (length s) 0))
             (eql (char s 0) #\*)
             (eql (char s (1- (length s))) #\*)))))

(defun value-triple-macro-fn (form on-skip-proofs check safe-mode stobjs-out
                                   ctx)

; Warning: The checks below should be at least as strong as those in
; chk-value-triple.

  (declare (xargs :guard t))
  `(let ((form ',form)
         (on-skip-proofs ,on-skip-proofs)
         (check ,check)
         (safe-mode ,safe-mode)
         (stobjs-out ,stobjs-out))
     (cond ((and (not on-skip-proofs)
                 (f-get-global 'ld-skip-proofsp state))
            (value :skipped))
           ((and (eq on-skip-proofs :interactive)
                 (eq (f-get-global 'ld-skip-proofsp state) 'include-book))
            (value :skipped))
           ((and (null check)
                 (eq safe-mode :same)
                 (or (null stobjs-out)
                     (equal stobjs-out '(nil)))
                 (or (booleanp on-skip-proofs)
                     (eq on-skip-proofs :interactive))
                 (cond ((consp form)
                        (and (eq (car form) 'QUOTE)
                             (consp (cdr form))
                             (null (cddr form))))
                       ((symbolp form)
                        (or (legal-constantp1 form) ; includes t, nil, and constants *c*
                            (keywordp form)))
                       (t (or (acl2-numberp form)
                              (stringp form)))))
            (value (if (consp form) (cadr form) form)))
           (t (value-triple-fn form
                               on-skip-proofs check safe-mode
                               stobjs-out ,ctx state)))))

#+acl2-loop-only
(defmacro value-triple (form &key
                             on-skip-proofs
                             check
                             (safe-mode ':same)
                             (stobjs-out 'nil)
                             (ctx ''value-triple))

; Value-triple is used in mutual-recursion, which is called in axioms.lisp
; before the definition of state-global-let*, which is used in value-triple-fn.
; So we avoid calling value-triple-fn in some of the most common cases, which
; also aids efficiency in those cases.

  (value-triple-macro-fn form on-skip-proofs check safe-mode stobjs-out ctx))

(defmacro assert-event (assertion &key
                                  event
                                  on-skip-proofs
                                  msg
                                  (safe-mode ':same)
                                  (stobjs-out 'nil)
                                  (ctx ''assert-event))
  (let ((ev `(value-triple ,assertion
                           :on-skip-proofs ,on-skip-proofs
                           :check ,(or msg t)
                           :safe-mode ,safe-mode
                           :stobjs-out ,stobjs-out
                           :ctx ,ctx)))
    (cond (event `(with-output
                    :stack :push
                    :off (summary event)
                    (progn ,ev
                           (with-output :stack :pop ,event))))
          (t ev))))

(defun event-keyword-name (event-type name)
  (declare (xargs :guard (member-eq event-type
                                    '(defund defthmd defun-nx defund-nx))))
  (list (intern (symbol-name event-type) "KEYWORD") name))

(defun event-keyword-name-lst (defuns acc)
  (declare (xargs :guard (and (mutual-recursion-guardp defuns)
                              (true-listp acc))))
  (cond ((endp defuns) (reverse acc))
        (t (event-keyword-name-lst
             (cdr defuns)
             (cons (if (member-eq (caar defuns)
                                  '(defund defthmd defun-nx defund-nx))
                       (event-keyword-name (caar defuns) (cadar defuns))
                     (cadar defuns))
                   acc)))))

; Begin support for defun-nx.

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

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

#-acl2-loop-only
(defvar *throw-nonexec-error*

; This variable should always have a non-nil value.  Its only use is in
; throw-nonexec-error, so as to defeat a GCL 2.7.0 warning reported by Camm
; Maguire.  That warning was about a type mismatch from a term (to-df (non-exec
; (constrained-df-expt-fn x y))): non-exec was deduces as returning nil.  The
; reason is that throw-nonexec-error doesn't return: (non-exec X) expands to
; (prog2$ (throw-nonexec-error :non-exec 'X) X).  We defeat that warning by
; having throw-nonexec-error consult this variable before throwing or causing
; an error.

  t)

(defun throw-nonexec-error (fn actuals)
  (declare (xargs :mode :logic
                  :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)
           #+acl2-loop-only
           (ignore fn actuals))
  #-acl2-loop-only
  (when *throw-nonexec-error* ; always t; see comment in *throw-nonexec-error*
    (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
                (replace-live-stobjs-in-list
                 (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 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)))

; mv and mv-let

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

(defmacro mv (&rest l)
  (declare (xargs :guard (>= (length l) 2)))
  #+acl2-loop-only
  (cons 'list l)
  #-acl2-loop-only
  (return-from mv (cons 'values l)))

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

;;;;;;;;;;
; NOTE: Some of the discussion below may well be obsolete now after removing
; feature :acl2-mv-as-values in late August 2021 because it was always true.
;;;;;;;;;;

; 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))
  #-acl2-loop-only
  (return-from mv-let (cons 'multiple-value-bind 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))))

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

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

; As noted by Mihir Mehta, the test above could reasonably be replaced by an
; mbe call whose :logic component is as shown above and whose :exec component
; is (< i j), but that wouldn't enhance performance, given the #-acl2-loop-only
; code above.  (See : DOC developers-guide-background for discussion of
; #-acl2-loop-only.)

; If this code nevertheless is changed to use mbe, consider that there may be
; many other similar opportunities to use mbe.

      0
    (+ 1 (nonnegative-integer-quotient (- i j) j))))

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

; 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!"
                                 (list (cons #\0 ignore-vars))))
                 (prog2$ (or (null ignorable-vars)
                             (hard-error 'let*-macro
                                         "Implementation error: Ignorable ~
                                          variables ~x0 must be bound in ~
                                          superior LET* form!"
                                         (list (cons #\0 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!

; Warning: If you change this definition, make the corresponding change in the
; definition of macroexpand1-cmp!

; 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)
; Logic mode is needed because abs is called in the event introducing
; constrained-binary-df+.
                  :mode :logic))
  (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.

)

(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
                  :mode :logic))
  (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)))))

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

(defun make-var-lst (sym n)
  (declare (xargs :guard (and (symbolp sym)
                              (integerp n)
                              (<= 0 n))
                  :mode :program))
  (make-var-lst1 (coerce (symbol-name sym) 'list) sym n nil))

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

; 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))
                  :mode :program))
  (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))))))))

(defconst *xargs-keywords*

; Keep this in sync with :doc xargs.  Also, if you add to this list, consider
; modifying memoize-partial-declare accordingly.

  '(:guard :guard-hints :guard-debug :guard-simplify
           :hints :measure :measure-debug
           :ruler-extenders :mode :non-executable :normalize
           :otf-flg #+:non-standard-analysis :std-hints
           :stobjs :dfs :verify-guards :well-founded-relation
           :split-types :loop$-recursion :type-prescription))

(defun plausible-dclsp1 (lst)

; We determine whether lst is a plausible cdr for a DECLARE form.  Ignoring the
; order of presentation and the number of occurrences of each element
; (including 0), we ensure that lst is of the form (... (TYPE ...) ... (IGNORE
; ...) ... (IGNORABLE ...) ... (IRRELEVANT ...) ... (XARGS ... :key val ...)
; ...)  where the :keys are our xarg keys (members of *xargs-keywords*).

  (declare (xargs :guard t))
  (cond ((atom lst) (null lst))
        ((and (consp (car lst))
              (true-listp (car lst))
              (or (member-eq (caar lst) '(type ignore ignorable irrelevant))
                  (and (eq (caar lst) 'xargs)
                       (keyword-value-listp (cdar lst))
                       (subsetp-eq (evens (cdar lst)) *xargs-keywords*))))
         (plausible-dclsp1 (cdr lst)))
        (t nil)))

(defun plausible-dclsp (lst)

; We determine whether lst is a plausible thing to include between the formals
; and the body in a defun, e.g., a list of doc strings and DECLARE forms.  We
; do not insist that the DECLARE forms are "perfectly legal" -- for example, we
; would approve (DECLARE (XARGS :measure m1 :measure m2)) -- but they are
; well-enough formed to permit us to walk through them with the fetch-from-dcls
; functions below.

; Note: This predicate is not actually used by defuns but is used by
; verify-termination in order to guard its exploration of the proposed dcls to
; merge them with the existing ones.  After we define the predicate we define
; the exploration functions, which assume this fn as their guard.  The
; exploration functions below are used in defuns, in particular, in the
; determination of whether a proposed defun is redundant.

  (declare (xargs :guard t))
  (cond ((atom lst) (null lst))
        ((stringp (car lst)) (plausible-dclsp (cdr lst)))
        ((and (consp (car lst))
              (eq (caar lst) 'declare)
              (plausible-dclsp1 (cdar lst)))
         (plausible-dclsp (cdr lst)))
        (t nil)))

; The above function, plausible-dclsp, is the guard and the role model for the
; following functions which explore plausible-dcls and either collect all the
; "fields" used or delete certain fields.

(defun strip-keyword-list (fields lst)

; Lst is a keyword-value-listp, i.e., (:key1 val1 ...).  We remove any key/val
; pair whose key is in fields.

  (declare (xargs :guard (and (symbol-listp fields)
                              (keyword-value-listp lst))))
  (cond ((endp lst) nil)
        ((member-eq (car lst) fields)
         (strip-keyword-list fields (cddr lst)))
        (t (cons (car lst)
                 (cons (cadr lst)
                       (strip-keyword-list fields (cddr lst)))))))

(defun strip-dcls1 (fields lst)
  (declare (xargs :guard (and (symbol-listp fields)
                              (plausible-dclsp1 lst))))
  (cond ((endp lst) nil)
        ((member-eq (caar lst) '(type ignore ignorable irrelevant))
         (cond ((member-eq (caar lst) fields) (strip-dcls1 fields (cdr lst)))
               (t (cons (car lst) (strip-dcls1 fields (cdr lst))))))
        (t
         (let ((temp (strip-keyword-list fields (cdar lst))))
           (cond ((null temp) (strip-dcls1 fields (cdr lst)))
                 (t (cons (cons 'xargs temp)
                          (strip-dcls1 fields (cdr lst)))))))))

(defun strip-dcls (fields lst)

; Lst satisfies plausible-dclsp.  Fields is a list as returned by dcl-fields,
; i.e., a subset of the union of the values of '(comment type ignore ignorable
; irrelevant) and *xargs-keywords*.  We copy lst deleting any part of it that
; specifies a value for one of the fields named, where 'comment denotes a
; string.  The result satisfies plausible-dclsp.

  (declare (xargs :guard (and (symbol-listp fields)
                              (plausible-dclsp lst))))
  (cond ((endp lst) nil)
        ((stringp (car lst))
         (cond ((member-eq 'comment fields) (strip-dcls fields (cdr lst)))
               (t (cons (car lst) (strip-dcls fields (cdr lst))))))
        (t (let ((temp (strip-dcls1 fields (cdar lst))))
             (cond ((null temp) (strip-dcls fields (cdr lst)))
                   (t (cons (cons 'declare temp)
                            (strip-dcls fields (cdr lst)))))))))

(defun fetch-dcl-fields2 (field-names kwd-list acc)
  (declare (xargs :guard (and (symbol-listp field-names)
                              (keyword-value-listp kwd-list))))
  (cond ((endp kwd-list)
         acc)
        (t (let ((acc (fetch-dcl-fields2 field-names (cddr kwd-list) acc)))
             (if (member-eq (car kwd-list) field-names)
                 (cons (cadr kwd-list) acc)
               acc)))))

(defun fetch-dcl-fields1 (field-names lst)
  (declare (xargs :guard (and (symbol-listp field-names)
                              (plausible-dclsp1 lst))))
  (cond ((endp lst) nil)
        ((member-eq (caar lst) '(type ignore ignorable irrelevant))
         (if (member-eq (caar lst) field-names)
             (cons (cdar lst) (fetch-dcl-fields1 field-names (cdr lst)))
           (fetch-dcl-fields1 field-names (cdr lst))))
        (t (fetch-dcl-fields2 field-names (cdar lst)
                             (fetch-dcl-fields1 field-names (cdr lst))))))

(defun fetch-dcl-fields (field-names lst)
  (declare (xargs :guard (and (symbol-listp field-names)
                              (plausible-dclsp lst))))
  (cond ((endp lst) nil)
        ((stringp (car lst))
         (if (member-eq 'comment field-names)
             (cons (car lst) (fetch-dcl-fields field-names (cdr lst)))
           (fetch-dcl-fields field-names (cdr lst))))
        (t (append (fetch-dcl-fields1 field-names (cdar lst))
                   (fetch-dcl-fields field-names (cdr lst))))))

(defun fetch-dcl-field (field-name lst)

; Lst satisfies plausible-dclsp, i.e., is the sort of thing you would find
; between the formals and the body of a DEFUN.  Field-name is either in the
; list (comment type ignore ignorable irrelevant) or is one of the symbols in
; the list *xargs-keywords*.  We return the list of the contents of all fields
; with that name.  We assume we will find at most one specification per XARGS
; entry for a given keyword.

; For example, if field-name is :GUARD and there are two XARGS among the
; DECLAREs in lst, one with :GUARD g1 and the other with :GUARD g2 we return
; (g1 g2).  Similarly, if field-name is TYPE and lst contains (DECLARE (TYPE
; INTEGER X Y)) then our output will be (... (INTEGER X Y) ...) where the ...
; are the other TYPE entries.

  (declare (xargs :guard (and (symbolp field-name)
                              (plausible-dclsp lst))))
  (fetch-dcl-fields (list field-name) lst))

(defun with-output-on-off-binding-val (on off summary-p)

; On and off are each either :all or a list of symbols contained in
; *summary-types* if summary-p is true, else contained in *valid-output-names*.
; We return an expression that represents the corresponding value indicated for
; state global inhibited-summary-types or inhibit-output-lst according to
; whether summary-p is true or nil, respectively.

  (declare (xargs :guard (and (or (eq on :all)
                                  (symbol-listp on))
                              (or (eq off :all)
                                  (symbol-listp off)))))
  (let* ((qconst (if summary-p '*summary-types* '*valid-output-names*))
         (global (if summary-p 'inhibited-summary-types 'inhibit-output-lst)))
    (cond
     ((eq on :all)
      (cond
       ((eq off :all) qconst)
       (t `(quote ,off))))
     ((eq off :all)
      `(set-difference-eq ,qconst ',on))
     (t
      `(union-eq ',off
                 (set-difference-eq (f-get-global ',global state)
                                    ',on))))))

(defun with-output-on-off-arg (arg universe)

; Arg is an argument of with-output keyword :on, :off, :summary-on, or
; :summary-off.  We return :all if arg is :all, and otherwise the sublist of
; universe indicated by arg (hence, arg itself unless the car of arg is
; :other-than, in which case the complement of the indicated list in universe).
; Except, we return :fail if arg is illegal.

  (declare (xargs :guard (symbol-listp universe)))
  (cond ((true-listp arg)
         (let* ((flg (eq (car arg) :other-than))
                (lst (if flg (cdr arg) arg)))
           (if (subsetp-eq lst universe)
               (if flg
                   (set-difference-eq universe lst)
                 lst)
             :fail)))
        ((eq arg :all) :all)
        ((member-eq arg universe)
         (list arg))
        (t :fail)))

(defun msgp (x)
  (declare (xargs :guard t))
  (or (stringp x)
      (and (consp x)
           (stringp (car x))
           (character-alistp (cdr x)))))

(defun ctxp (x)
  (declare (xargs :guard t))
  (or (symbolp x)
      (and (consp x)
           (symbolp (car x)))
      (msgp x)))

(defun with-output-fn (ctx0 args off on gag-mode stack summary-on summary-off
                            evisc inhibit-er-hard ctx kwds)
  (declare (xargs :mode :program
                  :guard (and (true-listp args)
                              (or (symbol-listp off)
                                  (eq off :all)
                                  (eq off :all!))
                              (or (symbol-listp on)
                                  (eq on :all))
                              (or (symbol-listp summary-off)
                                  (eq summary-off :all))
                              (or (symbol-listp summary-on)
                                  (eq summary-on :all))
                              (true-listp kwds))))
  (cond
   ((endp args) nil)
   ((keywordp (car args))
    (let ((illegal-value-string
           "~x0 is an illegal value for the keyword ~x1 of WITH-OUTPUT.  See ~
            :DOC with-output."))
      (cond
       ((consp (cdr args))
        (cond
         ((member-eq (car args) kwds)
          (hard-error ctx0
                      "Each keyword for ~x0 may be used at most once, but ~
                       keyword ~x1 is used more than once."
                      (list (cons #\0 'with-output) ; ctx, presumably
                            (cons #\1 (car args)))))
         ((eq (car args) :ctx)
          (cond ((ctxp (cadr args))
                 (with-output-fn ctx0 (cddr args) off on gag-mode stack
                                 summary-on summary-off evisc inhibit-er-hard
                                 (cadr args)
                                 (cons (car args) kwds)))
                (t (hard-error ctx0
                               illegal-value-string
                               (list (cons #\0 (cadr args))
                                     (cons #\1 :ctx))))))
         ((eq (car args) :evisc) ; we leave it to without-evisc to check syntax
          (with-output-fn ctx0 (cddr args) off on gag-mode stack
                          summary-on summary-off (cadr args) inhibit-er-hard
                          ctx
                          (cons (car args) kwds)))
         ((eq (car args) :gag-mode)
          (cond
           ((member-eq (cadr args)
                       '(t :goals nil)) ; keep in sync with set-gag-mode
            (with-output-fn ctx0 (cddr args) off on (cadr args) stack
                            summary-on summary-off evisc inhibit-er-hard ctx
                            (cons (car args) kwds)))
           (t (hard-error ctx0
                          illegal-value-string
                          (list (cons #\0 (cadr args))
                                (cons #\1 :gag-mode))))))
         ((and (eq (car args) :off)
               (eq (cadr args) :all!))
          (with-output-fn ctx0
                          (list* :off :all :gag-mode nil :inhibit-er-hard t
                                 (cddr args))
                          off on gag-mode stack summary-on summary-off
                          evisc inhibit-er-hard ctx kwds))
         ((member-eq (car args) '(:on :off))
          (let ((val (with-output-on-off-arg (cadr args) *valid-output-names*)))
            (cond
             ((eq val :fail)
              (hard-error ctx0
                          illegal-value-string
                          (list (cons #\0 (cadr args))
                                (cons #\1 (car args)))))
             ((eq (car args) :on)
              (with-output-fn ctx0 (cddr args) off val
                              gag-mode stack summary-on summary-off evisc
                              inhibit-er-hard ctx
                              (cons (car args) kwds)))
             (t ; (eq (car args) :off)
              (with-output-fn ctx0 (cddr args) val on
                              gag-mode stack summary-on summary-off evisc
                              inhibit-er-hard ctx
                              (cons (car args) kwds))))))
         ((eq (car args) :stack)
          (cond
           ((member-eq (cadr args) '(:push :pop))
            (with-output-fn ctx0 (cddr args) off on gag-mode (cadr args)
                            summary-on summary-off evisc inhibit-er-hard ctx
                            (cons (car args) kwds)))
           (t (hard-error ctx0
                          illegal-value-string
                          (list (cons #\0 (cadr args))
                                (cons #\1 :stack))))))
         ((member-eq (car args) '(:summary-on :summary-off))
          (let ((val (with-output-on-off-arg (cadr args) *summary-types*)))
            (cond ((eq val :fail)
                   (hard-error ctx0
                               illegal-value-string
                               (list (cons #\0 (cadr args))
                                     (cons #\1 (car args)))))
                  ((eq (car args) :summary-on)
                   (with-output-fn ctx0 (cddr args) off on gag-mode stack
                                   val summary-off evisc inhibit-er-hard ctx
                                   (cons (car args) kwds)))
                  (t ; (eq (car args) :summary-off)
                   (with-output-fn ctx0 (cddr args) off on gag-mode stack
                                   summary-on val evisc inhibit-er-hard ctx
                                   (cons (car args) kwds))))))
         ((eq (car args) :inhibit-er-hard)
          (with-output-fn ctx0 (cddr args) off on gag-mode stack
                          summary-on summary-off evisc (cadr args) ctx
                          (cons (car args) kwds)))
         (t
          (hard-error ctx0
                      "~x0 is not a legal keyword for a call of with-output.  ~
                       See :DOC with-output."
                      (list (cons #\0 (car args)))))))
       (t (hard-error ctx0
                      "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 ctx0
             "Illegal with-output form.  See :DOC with-output."
             nil))
   (t
    (let* ((ctx-p (member-eq :ctx kwds))
           (evisc-p (member-eq :evisc kwds))
           (inhibit-er-hard-p (member-eq :inhibit-er-hard kwds))
           (gag-p (member-eq :gag-mode kwds))
           (on-p (member-eq :on kwds))
           (off-p (member-eq :off kwds))
           (on-off-p (or on-p off-p))
           (summary-on-p (member-eq :summary-on kwds))
           (summary-off-p (member-eq :summary-off kwds))
           (summary-on-off-p (or summary-on-p summary-off-p))
           (form
            `(state-global-let*
              (,@
               (and ctx-p
                    `((global-ctx ,ctx)))
               ,@
               (and inhibit-er-hard-p
                    `((inhibit-er-hard ,inhibit-er-hard)))
               ,@
               (and (or gag-p
                        (eq stack :pop))
                    `((gag-mode (f-get-global 'gag-mode state)
                                set-gag-mode-fn)))
               ,@
               (and (or on-off-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-on-off-p
                    '((inhibited-summary-types
                       (f-get-global 'inhibited-summary-types state)))))
              (er-progn
               ,@(and summary-on-off-p
                      `((set-inhibited-summary-types
                         ,(with-output-on-off-binding-val summary-on
                                                          summary-off
                                                          t))))
               ,@(and stack
                      `((pprogn ,(if (eq stack :pop)
                                     '(pop-inhibit-output-lst-stack state)
                                   '(push-inhibit-output-lst-stack state))
                                (value nil))))
               ,@(and gag-p
                      `((pprogn (set-gag-mode ,gag-mode)
                                (value nil))))
               ,@(and on-off-p
                      `((set-inhibit-output-lst
                         ,(with-output-on-off-binding-val on off nil))))
               ,(car args)))))
      (cond (evisc-p `(with-evisc-tuple ,form ,@evisc))
            (t form))))))

(defun with-output!-fn (args)
  (declare (xargs :guard (true-listp args)
                  :mode :program))
  `(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

; If val is nil, then we have presumably already aborted with an error.  But
; just to be robust here we explicitly cause an error (in case we are wrong
; about being able to reach this point).

            (illegal 'with-output
                     "Macroexpansion of ~q0 failed."
                     (list (cons #\0 (cons 'with-output args))))))))

(defmacro with-output! (&rest args)
  (with-output!-fn args))

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

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

; Warning: If you change this definition, make the corresponding change in the
; definition of macroexpand1-cmp!

  (with-output!-fn args))

(defun defun-nx-dcls (form dcls)
  (declare (xargs :guard (consp form)))
  (if (plausible-dclsp dcls)
      (let ((ruler-extenders (fetch-dcl-field :ruler-extenders dcls)))
        (cond ((and (consp ruler-extenders)
                    (null (cdr ruler-extenders))
                    (true-listp (car ruler-extenders))
                    (not (member-eq 'return-last (car ruler-extenders))))
               (cons `(declare (xargs :ruler-extenders
                                      (return-last ,@(car ruler-extenders))))
                     (strip-dcls '(:ruler-extenders) dcls)))
              (t dcls)))
    (hard-error (car form)
                "The declarations are ill-formed for the form,~%~x0."
                (list (cons #\0 form)))))

(defun defun-nx-form (form)
  (declare (xargs :guard (and (true-listp form)
                              (true-listp (caddr form))
                              (member-eq (car form) '(defun-nx defund-nx)))
                  :mode :program))
  (let ((defunx (if (eq (car form) 'defun-nx) 'defun 'defund))
        (name (cadr form))
        (formals (caddr form))
        (rest (cdddr form)))
    `(,defunx ,name ,formals
       (declare (xargs :non-executable t :mode :logic))
       ,@(defun-nx-dcls form (butlast rest 1))
       (prog2$ (throw-nonexec-error ',name (list ,@formals))
               ,@(last rest)))))

(defun defun-nx-fn (form)
  (declare (xargs :guard (and (true-listp form)
                              (true-listp (caddr form))
                              (member-eq (car form) '(defun-nx defund-nx)))
                  :mode :program))
  `(with-output :stack :push :off :all
       (progn (encapsulate
                ()
                (logic)
                (set-state-ok t)
                (with-output :stack :pop
                  ,(defun-nx-form form))
                (with-output :stack :pop :off summary
                  (in-theory (disable (:e ,(cadr form))))))
              (with-output :stack :pop :off summary
                (value-triple
                 ',(event-keyword-name (car form) (cadr form)))))))

(defmacro defun-nx (&whole form &rest rest)
  (declare (xargs :guard (and (true-listp form)
                              (true-listp (caddr form))))
           (ignore rest))
  (defun-nx-fn form))

(defmacro defund-nx (&whole form &rest rest)
  (declare (xargs :guard (and (true-listp form)
                              (true-listp (caddr form))))
           (ignore rest))
  (defun-nx-fn form))

(defun update-mutual-recursion-for-defun-nx-1 (defs)
  (declare (xargs :guard (mutual-recursion-guardp defs)
                  :mode :program))
  (cond ((endp defs)
         nil)
        ((eq (caar defs) 'defun-nx)
         (cons (defun-nx-form (car defs))
               (update-mutual-recursion-for-defun-nx-1 (cdr defs))))
        ((eq (caar defs) 'defund-nx)
         (cons (defun-nx-form (car defs))
               (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)
                  :mode :program))
  (cond ((or (assoc-eq 'defun-nx defs)
             (assoc-eq 'defund-nx defs))
         (update-mutual-recursion-for-defun-nx-1 defs))
        (t defs)))

(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)
                  :mode :program))
  (program-declared-p1 (butlast (cddr def) 1)))

(defun some-program-declared-p (defs)
  (declare (xargs :guard (true-list-listp defs)
                  :mode :program))
  (cond ((endp defs) nil)
        (t (or (program-declared-p (car defs))
               (some-program-declared-p (cdr defs))))))

(defun pairlis-x1 (x1 lst)

; Cons x1 onto the front of each element of lst.

  (declare (xargs :guard (true-listp lst)))
  (cond ((endp lst) nil)
        (t (cons (cons x1 (car lst))
                 (pairlis-x1 x1 (cdr lst))))))

(defun pairlis-x2 (lst x2)

; Make an alist pairing each element of lst with x2.

  (declare (xargs :guard (true-listp lst)))
  (cond ((endp lst) nil)
        (t (cons (cons (car lst) x2)
                 (pairlis-x2 (cdr lst) x2)))))

(defmacro append? (x y)

; We use defmacro because defabbrev has not yet been defined at this point in
; the boot-strap.

  `(let ((x ,x) (y ,y))
     (cond ((null y) x)
           (t (append x y)))))

#+acl2-loop-only
(defmacro mutual-recursion (&whole event-form &rest rst0)
  (declare (xargs :guard (mutual-recursion-guardp rst0)))
  (let ((rst (update-mutual-recursion-for-defun-nx rst0)))

; It would be nice to use let* instead of nested let expressions here, but let*
; has not been defined at this point in the file.

    (let ((form (list 'defuns-fn
                      (list 'quote (strip-cdrs rst))
                      'state
                      (list 'quote event-form)
                      #+:non-standard-analysis ; std-p
                      nil)))
      (cond
       ((or (and (assoc-eq 'defund rst0)

; It is of course possible that the default defun-mode is :program and thus no
; definition explicitly declares :program mode.  In that case, we might
; generate in-theory events but they would be skipped because the default
; defun-mode is :program.  Note by the way that all functions introduced by
; mutual-recursion have the same defun-mode, which allows us to avoid thinking
; about mixed defun-mode cases.

                 (not (some-program-declared-p (strip-cdrs rst0))))
            (assoc-eq 'defun-nx rst0)
            (assoc-eq 'defund-nx rst0))
        (let ((in-theory-form
               (list 'in-theory
                     (cons 'disable
                           (append?
                            (collect-cadrs-when-car-member-eq
                             '(defund)
                             rst)
                            (pairlis-x1
                             ':executable-counterpart
                             (pairlis$ (collect-cadrs-when-car-member-eq
                                        '(defun-nx defund-nx)
                                        rst0)
                                       nil)))))))
          (list 'er-progn
                form
                (list
                 'with-output
                 :off :all
                 (if (or (assoc-eq 'defun-nx rst0)
                         (assoc-eq 'defund-nx rst0))
                     `(encapsulate
                        nil
                        (logic)
                        ,in-theory-form)
                   in-theory-form))
                (list 'value-triple
                      (list 'quote (event-keyword-name-lst rst0 nil))))))
       (t
        form)))))

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

(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 maybe-kwote (x)

; Return an untranslated term that represents (quote x).

  (declare (xargs :guard t))
  (cond ((or (acl2-numberp x)
             (stringp x)
             (characterp x)
             (eq x nil)
             (eq x t)
             (keywordp x))
         x)
        (t (kwote 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))

; We originally added the following three defthm forms at the request of Jared
; Davis, who noted that many books 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.
; When we strengthened "make proofs" so that proof were no longer restricted to
; pass 2 of the boot-strap, we found that these lemmas might be necessary
; anyhow.

(encapsulate
 ()
; Prove in pass 1 of initialize-acl2:
(table acl2-defaults-table :defun-mode :logic)

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

; Now we define the weak notion of term that guards metafunctions.

(defmacro len$ (x)

; This variant of len is logically just len, but it executes as length in
; guard-verified and program-mode code.  In such code it should thus be called
; only when x is a true list, but it may be slightly faster than len because
; the Lisp implementation may optimize the definition of length.  The following
; experiment (performed on an Intel-based Mac) showed length to be faster than
; len in CCL and perhaps about the same in SBCL.

; :q ; go into raw Lisp
; (defconstant *c* (loop for i from 1 to 1000 by 10
;                        collect (make-list (* 1000 i))))
; (defun f () (loop for x in *c* when (= (len x) 3) collect x))
; (defun g () (loop for x in *c* when (= (length x) 3) collect x))
; (time (f))
; (time (g))

; At first glance it may appear that x is being evaluated twice below from a
; call of len$.  But in fact, only the :logic or the :exec code will be
; evaluated from a call of len$.

  `(mbe :logic (len ,x)
        :exec (length ,x)))

(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 (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 (len$ (car x)) 3)
                    (eq (car (car x)) 'lambda)
                    (symbol-listp (cadr (car x)))
                    (pseudo-termp (caddr (car x)))
                    (equal (len$ (cadr (car x)))
                           (len$ (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)

(defthm pseudo-termp-consp-forward
    (implies (and (pseudo-termp x)
                  (consp x))
             (true-listp x))
  :hints (("Goal" :expand ((pseudo-termp 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)

; Lambda Object Accessor Functions

; The following functions access the formals, declare statement (if any), and
; body of a well-formed lambda object.  However, they do not assume that their
; arguments are well-formed.  They may return ill-formed results on ill-formed
; ``lambdas''.  See the Essay on Lambda Objects and Lambda$ for some context
; and conventions.  The formals are the *1* cadr of the ``lambda object,'' and
; the dcl and body are either nil and the *1* caddr or the *1* caddr and the
; *1* cadddr, depending on whether the object is a true-list of len 3 or 4.
; The dcl and body are both nil for objects that are not true-lists of len 3 or
; 4.

; More verbosely, there are two forms of well-formed lambda objects (called
; simple and declared), and three ``accessor'' functions:

;                         simple                       declared
;                   (LAMBDA vars body)         (LAMBDA vars dcl body)

; lambda-object-formals     vars                       vars
; lambda-object-dcl         nil                        dcl
; lambda-object-body        body                       body

; Put another way,

; lambda-object-formals     cadr                       cadr
; lambda-object-dcl         nil                        caddr
; lambda-object-body        caddr                      cadddr

; except we always mean the *1*-counterparts of those car/cdr nests so that
; these accessors are guard verified with guards of T.  Insufficient
; cons-structure can make lambda-object-dcl and lambda-object-body return nil.
; A nil dcl is interpreted as though we'd seen a simple lambda with no dcl.
; But a nil body is an ill-formed answer because nil is not a term.

; Lambda-object-formals is always *1*cadr.  But lambda-object-dcl and
; lambda-object-body have to decide whether an ill-formed lambda object, x, is
; supposed to be treated like a simple lambda or a declared one.  The answer is
; if it's a true-list of len 3, it's simple, if it's a true-list of len 4, it's
; declared, and otherwise we return nil.

(defun lambda-object-formals (x)

; If x is a well-formed lambda object, e.g., something of the form (LAMBDA vars
; dcl body) or (LAMBDA vars body), we return vars.  But x is not necessarily
; well-formed and there is no guarantee that the answer is well-formed.  See
; the discussion above.

; This function has a guard of T so that it can be used without an ec-call in
; apply$-lambda-logical and elsewhere.

  (declare (xargs :guard t))

; We could have defined this as indicated by the thm below, but we wanted to be
; more efficient and guard-verified.

; (thm (equal (lambda-object-formals x)
;             (cadr x)))

  (if (and (consp x)
           (consp (cdr x)))
      (cadr x)
      nil))

(defun lambda-object-dcl (x)

; If x is a well-formed lambda object, e.g., something of the form (LAMBDA vars
; dcl body) or (LAMBDA vars body), we return the dcl or nil if there's no dcl.
; But x is not necessarily well-formed and there is no guarantee that the
; answer is well-formed.  See the discussion above.

; This function has a guard of T so that it can be used without an ec-call in
; apply$-lambda-logical and elsewhere.

; On Performance: One wonders whether this function would be faster if we
; avoided repeated cdrs by let-binding.  We tried variations of this function
; in which we bound temp successively to the cdr of temp in the obvious way so
; as to avoid duplicated computations of cdr expressions.  We then compared
; them on a billion well-formed lambdas of both lengths 3 and 4.  This was the
; fastest.  The lesson: cdr is faster than let-binding/variable lookup.

  (declare (xargs :guard t))

; We could have used this definition:
; (thm (equal (lambda-object-dcl x)
;             (cond ((and (true-listp x) (= (len x) 3)) nil)
;                   ((and (true-listp x) (= (len x) 4)) (caddr x))
;                   (t nil))))
; By the way, arithmetic-5/top and (equal (equal (len x) 0) (atom x)) are
; needed to prove the thm above.

  (cond ((and (consp x)               ; (= (len x) 4)
              (consp (cdr x))
              (consp (cddr x))
              (consp (cdddr x))
              (null (cddddr x)))
         (caddr x))
        (t nil)))

(defun lambda-object-body (x)

; If x is a well-formed lambda object, e.g., something of the form (LAMBDA vars
; dcl body) or (LAMBDA vars body), we return the body.  But x is not
; necessarily well-formed and there is no guarantee that the answer is
; well-formed.  See the discussion above.

; This function has a guard of T so that it can be used without an ec-call in
; apply$-lambda-logical and elsewhere.

  (declare (xargs :guard t))

; We could have used this definition:
; (thm (equal (lambda-object-body x)
;             (cond
;              ((and (true-listp x) (= (len x) 3)) (caddr x))
;              ((and (true-listp x) (= (len x) 4)) (cadddr x))
;              (t nil))))
; By the way, arithmetic-5/top and (equal (equal (len x) 0) (atom x)) are
; needed to prove the thm above.

  (cond ((and (consp x)               ; (>= (len x) 3)
              (consp (cdr x))
              (consp (cddr x)))
         (cond ((atom (cdddr x))      ; (= (len x) 3)
                (if (null (cdddr x)) (caddr x) nil))
               ((null (cddddr x))     ; (= (len x) 4)
                (cadddr x))
               (t nil)))
        (t nil)))

(defun lambda-object-shapep (fn)
  (declare (xargs :guard t))
  (and (consp fn)
       (eq (car fn) 'lambda)
       (consp (cdr fn))
       (consp (cddr fn))
       (or (null (cdddr fn))
           (and (consp (cdddr fn))
                (null (cddddr fn))))))

(defun make-lambda-object (formals dcl body)
  (declare (xargs :guard t))
  `(lambda ,formals
     ,@(if dcl (list dcl) nil)
     ,body))

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

(defun fargn1 (x n)
  (declare (xargs :guard (and (integerp n)
                              (> n 0))))
  (cond ((mbe :logic (or (zp n) (eql n 1))
              :exec (eql n 1))
         (list 'cdr x))
        (t (list 'cdr (fargn1 x (- n 1))))))

(defmacro fargn (x n)
  (declare (xargs :guard (and (integerp n)
                              (> n 0))))
  (list 'car (fargn1 x n)))

(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 chk-no-stobj-index-aliasing (producers others)

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

; At one time we checked that producers and others satisfy eqlable-listp,
; presumably because we also used no-duplicatesp and intersectp in place of
; no-duplicatesp-equal and intersectp-equal, respectively.  But that was when
; hash tables did not contain stobjs, so that indexed accesses in stobj-let
; were only for array indices, which are numbers, not hash-table indices, which
; might be arbitrary.

  (declare (xargs :guard (and (true-listp producers)
                              (no-duplicatesp-equal producers)
                              (true-listp others)
                              (not (intersectp-equal producers others))))
           (ignore producers others))
  nil)

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

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

(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 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 *base-10-chars* 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 *base-10-chars* 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))

; 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))
    (mbe :logic (fix acc) :exec acc))
   (t (position-ac-eq-exec item (cdr lst) (1+ acc)))))

(defthm natp-position-ac-eq-exec
  (implies (natp acc)
           (or (natp (position-ac-eq-exec item lst acc))
               (equal (position-ac-eq-exec item lst acc) nil)))
  :rule-classes :type-prescription)

(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))
    (mbe :logic (fix acc) :exec acc))
   (t (position-ac-eql-exec item (cdr lst) (1+ acc)))))

(defthm natp-position-ac-eql-exec
  (implies (natp acc)
           (or (natp (position-ac-eql-exec item lst acc))
               (equal (position-ac-eql-exec item lst acc) nil)))
  :rule-classes :type-prescription)

(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))
    (mbe :exec acc :logic (fix acc)))
   (t (position-equal-ac item (cdr lst) (1+ acc)))))

(defthm natp-position-equal-ac
  (implies (natp acc)
           (or (natp (position-equal-ac item lst acc))
               (equal (position-equal-ac item lst acc) nil)))
  :rule-classes :type-prescription)

(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 acc)
              :exec  (position-ac-eq-exec item lst acc)))
   ((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 ,acc))))

; 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 (x seq)
  (or (stringp seq)
      (and (true-listp seq)
           (or (eqlablep x)
               (eqlable-listp seq))))
  (if (stringp seq)
      (position-ac x (coerce seq 'list) 0)
    (position-ac x seq 0)))

(defun position-equal (x seq)
  (declare (xargs :guard (or (stringp seq) (true-listp seq))))
  #-acl2-loop-only ; for assoc-eq, Jared Davis found native assoc efficient
  (position x seq :test #'equal)
  #+acl2-loop-only
  (if (stringp seq)
      (position-ac x (coerce seq 'list) 0)
    (position-equal-ac x seq 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))))

#+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 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 (characterp c)
           (equal (code-char (char-code c)) c)))

(defaxiom char-code-code-char-is-identity
  (implies (and (integerp n)
                (<= 0 n)
                (< 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 ~
                       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)

; See the Essay on Unwind-Protect.  See also acl2-unwind-protect-alt.

; 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 'nil hints-p)
                                (guard-debug 'nil guard-debug-p)
                                (guard-simplify 't guard-simplify-p)
                                otf-flg)

; 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 hints-p)
       (list 'quote otf-flg)
       (list 'quote guard-debug) (list 'quote guard-debug-p)
       (list 'quote guard-simplify) (list 'quote guard-simplify-p)
       (list 'quote event-form)))

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

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

(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 *base-10-chars* str-args))
        (severity-name (symbol-name severity)))
    (cond ((equal severity-name "SOFT")
           (list 'error1 context nil 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 *base-10-chars* str-args))
        (severity-name (symbol-name severity)))
    (cond ((equal severity-name "SOFT")
           (list 'error1@par context nil 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 defthmd-fn (event-form name rst)
  (declare (xargs :mode :program))
  (let ((tmp (member :rule-classes rst)))
    (cond
     ((and tmp
           (cdr tmp)
           (eq (cadr tmp) nil))
      (er hard (cons 'defthmd name)
          "It is illegal to specify :rule-classes nil with ~x0, since there ~
           is no rule to disable."
          'defthmd))
     (t (list 'with-output
              :stack :push
              :off :all

; The following allows reporting of macroexpansion errors.

              :on 'error
              (list 'progn
                    (list 'with-output
                          :stack :pop
                          (cons 'defthm (cdr event-form)))
                    (list 'with-output
                          :stack :pop

; We never want to see the summary here.  But we do want to see a redundancy
; message, which is printed in stop-redundant-event with (io? event ...) --
; unless event output is inhibited at the start of the defthmd call.

                          :off 'summary
                          (list 'in-theory
                                (list 'disable name)))
                    (list 'value-triple
                          (list 'quote (event-keyword-name 'defthmd name))
                          :on-skip-proofs t)))))))

#+acl2-loop-only
(defmacro defthmd (&whole event-form
                          name term
                          &rest rst)
  (declare (xargs :guard t)
           (ignore term))
  (defthmd-fn event-form name rst))

#+(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 you change this definition, make the corresponding change in the
; definition of macroexpand1-cmp!

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

(defmacro partial-encapsulate (sigs supporters &rest cmd-lst)

; We considered instead allowing an event like (make-unknown-constraint fn),
; rather than providing partial-encapsulate as an interface to encapsulate with
; an invocation of set-unknown-constraints-supporters.  But that would make it
; too easy for users to introduce unsoundness with trust tags (always a
; possibility, but as a courtesy we'd like to encourage sound use of trust
; tags!).  Consider for example this book.

;   (in-package "ACL2")
;   (defstub f (x) t)
;   (local (make-unknown-constraint f))
;   (include-raw "f-raw")

; After including the book, f no longer has unknown-constraints, yet if
; f-raw.lsp provides a way to compute with f, we can now prove theorems that
; don't follow from the (trivial) axioms of f.  A proof of nil with functional
; instantiation would not be far behind!

; So instead, we insist that unknown-constraints are put on the function as
; part of the encapsulate that introduces it.

  (declare (xargs :guard (symbol-listp supporters)))
  (cond
   ((null cmd-lst)
    (er hard 'partial-encapsulate
        "There must be at least one event form following the supporters in a ~
         call of partial-encapsulate."))
   (t `(encapsulate ,sigs
         ,@cmd-lst
         (set-unknown-constraints-supporters ,@supporters)))))

(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
                             save-event-data)

; 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.  We have these two key goals regarding redundancy.

; + We prefer to recognize redundancy without having to execute events in the
;   encapsulate.

; + If an encapsulate form is redundant with an earlier form that is local, and
;   thus including the book causes only the latter form to be processed, then
;   the resulting event stored at include-book time should agree logically with
;   the event stored at certification time.

; The latter 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
; second encapsulate in bar.lisp to be redundant during book certification.
; Then the event logically represented by the second encapsulate must be 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 encapsulate, in the
; :expansion-alist of the .cert file.  But how do we expand a non-redundant
; encapsulate?  We expand it by replacing every sub-event by its expansion (if
; it has an expansion).  Then, we may recognize a subsequent encapsulate as
; redundant with this one if their signatures are equal; they have the same
; length; and each of the subsequent encapsulate's events, ev2, is either the
; same as the corresponding event ev1 of the old encapsulate, stored as the
; first argument of a record-expansion call, or their expansions match up.
; Note that two local events always "match up" in this sense when each is under
; an encapsulate or in a book.  See corresponding-encaps, which explains a
; subtle reason why we do not consider the first argument of a record-expansion
; call when including a book.

; We elide local forms arising from make-event expansions when writing
; expansion-alists 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.

; Finally, here is an outline of how we handle save-event-data.  We exempt the
; symbol, save-event-data, from membership in the list
; *protected-system-state-globals*, so that its global value will persist after
; make-event expansion.  Then in print-summary we ensure that this global value
; is preserved after printing the make-event summary.

  (declare (xargs :guard t))
; Keep this in sync with the -acl2-loop-only definition.
  `(make-event-fn ',form
                  ',expansion?
                  ',check-expansion
                  ',on-behalf-of
                  ',save-event-data
                  ',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 though 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
        '(or (member-eq (ld-skip-proofsp state)
                        '(include-book initialize-acl2))
             (f-get-global 'ld-always-skip-top-level-locals state))
        '(mv nil nil state)
        (list 'state-global-let*
              '((in-local-flg t))
              (list 'when-logic "LOCAL" x))))

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

; It may be tempting to allow defattach events to be redundant.  There is at
; least one good reason not to do so: the value of keyword :attach is not
; stored in the world, at least not in an easily accessible way.  It seems
; possible that there are such issues with the :skip-checks keyword too.

; We could add a new macro, (defattach? f g), which skips the defattach when g
; is already attached to f, regardless of keywords.  But more generally, we
; would want to support (defattach? (f1 g1) ... (fn gn)), in which case thought
; would need to be given to the case that some, but not all, fi already have gi
; as an attachment.  Whatever the decision in that case, the result could be
; confusing to some.  Also confusing could be the issue described above, of
; keywords not being checked.  On a more mundane level, attention might be
; needed to ensure that errors and warnings reference "defattach?" rather than
; "defattach".

; So, at least until a reasonably convincing case is presented for why
; redundancy is important for defattach events, we leave things as they are.

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

; Warning: It may be important in add-trip that set-attachment-symbol-form
; generates a defparameter whose form is quoted.  See the comment about this in
; the attachment case in add-trip.

  `(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 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 (hons-get sym fgetprop-stats))
;           (key-entry (hons-get key (cdr sym-entry))))
;      (cond (key-entry (setf (cdr key-entry) (1+ (cdr key-entry))))
;            (sym-entry (setf (cdr sym-entry)
;                             (hons-acons key 1 (cdr sym-entry))))
;            (t (setq fgetprop-stats
;                     (hons-acons sym
;                                 (hons-acons key 1 nil)
;                                 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))))))

; Remove1-assoc

(defun-with-guard-check remove1-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) (remove1-assoc-eq-exec key (cdr alist))))))

(defun-with-guard-check remove1-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) (remove1-assoc-eql-exec key (cdr alist))))))

(defun remove1-assoc-equal (key alist)
  (declare (xargs :guard (alistp alist)))
  (cond ((endp alist) nil)
        ((equal key (caar alist)) (cdr alist))
        (t (cons (car alist) (remove1-assoc-equal key (cdr alist))))))

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

(defthm remove1-assoc-eq-exec-is-remove1-assoc-equal
  (equal (remove1-assoc-eq-exec key lst)
         (remove1-assoc-equal key lst)))

(defthm remove1-assoc-eql-exec-is-remove1-assoc-equal
  (equal (remove1-assoc-eql-exec key lst)
         (remove1-assoc-equal key lst)))

(defmacro remove1-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 (remove1-assoc-equal key alist)
              :exec  (remove1-assoc-eq-exec key alist)))
   ((equal test ''eql)
    `(let-mbe ((key ,key) (alist ,alist))
              :logic (remove1-assoc-equal key alist)
              :exec  (remove1-assoc-eql-exec key alist)))
   (t ; (equal test 'equal)
    `(remove1-assoc-equal ,key ,alist))))

(defun-with-guard-check remove-assoc-eq-exec (x alist)
  (if (symbolp x)
      (alistp alist)
    (symbol-alistp alist))
  (cond ((endp alist) nil)
        ((eq x (car (car alist))) (remove-assoc-eq-exec x (cdr alist)))
        (t (cons (car alist)
                 (remove-assoc-eq-exec x (cdr alist))))))

(defun-with-guard-check remove-assoc-eql-exec (x alist)
  (if (eqlablep x)
      (alistp alist)
    (eqlable-alistp alist))
  (cond ((endp alist) nil)
        ((eql x (car (car alist))) (remove-assoc-eql-exec x (cdr alist)))
        (t (cons (car alist) (remove-assoc-eql-exec x (cdr alist))))))

(defun remove-assoc-equal (x alist)
  (declare (xargs :guard (alistp alist)))
  (cond ((endp alist) nil)
        ((equal x (car (car alist))) (remove-assoc-equal x (cdr alist)))
        (t (cons (car alist) (remove-assoc-equal x (cdr alist))))))

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

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

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

(defmacro remove-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 (remove-assoc-equal x alist)
              :exec  (remove-assoc-eq-exec x alist)))
   ((equal test ''eql)
    `(let-mbe ((x ,x) (alist ,alist))
              :logic (remove-assoc-equal x alist)
              :exec  (remove-assoc-eql-exec x alist)))
   (t ; (equal test 'equal)
    `(remove-assoc-equal ,x ,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)
                   (remove1-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)))

(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 conjoin-untranslated-terms (l)

; This function is analogous to conjoin, but where the terms need not be
; translated.  Normally we expect that the result will be translated; but as a
; courtesy to those who might want to use this utility, we attempt to return a
; "pretty" untranslated term.

  (declare (xargs :guard (true-listp l)))
  (cond ((or (member nil l :test 'eq)
             (member *nil* l :test 'equal))
         nil)
        (t (let* ((l2 (if (member t l :test 'eq)
                          (remove t l :test 'eq)
                        l))
                  (l3 (if (member *t* l2 :test 'equal)
                          (remove *t* l2 :test 'equal)
                        l2)))
             (cond ((null l3) t)
                   ((null (cdr l3)) (car l3))
                   (t (cons 'and l3)))))))

(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.
; Note:  If you really want a term EQUAL to (OR t1 t2) see disjoin?!

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

; In the following tflg = T means we return a fully translated term; else
; we are free to use abbreviations like AND, OR, T, NIL, and 23.

(defun kwote? (tflg evg)
  (declare (xargs :guard t))
  (if tflg (kwote evg) evg))

(defun conjoin? (tflg lst)
  (declare (xargs :guard (true-listp lst)))
  (cond
   (tflg (conjoin lst))
   ((null lst) T)
   ((null (cdr lst)) (car lst))
   (t (cons 'and lst))))

(defun <=? (tflg x y)
  (declare (xargs :guard t))
  (if tflg
      `(NOT (< ,y ,x))
      `(<= ,x ,y)))

(defun >? (tflg x y)
  (declare (xargs :guard t))
  (if tflg
      `(< ,y ,x)
      `(> ,x ,y)))

(defun disjoin? (tflg lst)

; We return a term that is EQUAL to (OR . lst).  If tflg is nil, the result is
; not necessarily in translated form -- it may actually have the OR macro in
; it.  If tflg is t, we return an IF-term instead of using OR.

  (declare (xargs :guard (true-listp lst)))
  (cond
   (tflg (or-macro lst))
   ((null lst) NIL)
   ((null (cdr lst)) (car lst))
   (t (cons 'or lst))))

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

; Use of the word ``translate'' in the names of the next few functions is a bit
; misleading since the results can be UNtranslated terms if tflg is nil.  We
; should have, perhaps, used the word ``transform''!

(defun translate-declaration-to-guard/integer-gen (lo var hi tflg)

; See get-guards2 for a discussion of tflg.

  (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 (conjoin? tflg
                                (list
                                 (list 'integerp var)
                                 (<=? tflg var (kwote? tflg upper-bound)))))))
                 (t (cond
                     ((eq upper-bound '*)
                      (conjoin? tflg
                                (list
                                 (list 'integerp var)
                                 (<=? tflg (kwote? tflg 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.)

                      (conjoin?
                       tflg
                       (list
                        (list 'integerp var)
                        (<=? tflg (kwote? tflg lower-bound) var)
                        (<=? tflg var (kwote? tflg upper-bound)))))))))
          (t nil))))

(defun translate-declaration-to-guard/integer (lo var hi)

; This is just the special case of translate-declaration-to-guard/integer-gen
; for tflg = nil, for backwards compatibility.  See get-guard2 for a discussion
; of tflg.

  (declare (xargs :guard t
                  :mode :program))
  (translate-declaration-to-guard/integer-gen lo var hi 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-gen (x var tflg wrld)

; Wrld is either an ACL2 logical world or a symbol; see
; translate-declaration-to-guard.  If tflg is t we return a fully translated
; term; else we return a user level term possibly containing the macros AND and
; OR and unquoted Ts and NILs and numbers.  See get-guards2 for a discussion of
; tflg.

; Implicit in this whole design is the presumption that when tflg = nil all of
; the macros introduced in our results are ``hygenic'' in the sense used by
; Felleisen et. al, and the result of this function is at least a pseudo-termp
; so that we can find all the variables that occur in the macroexpansion by
; looking for variables in the result produced here.  That way, if we produce
; an untranslated result like (<= var '23) and want to rename var to var1, we
; can do so in the unexpanded result, producing (<= var1 '23), knowing that the
; macroexpansion of that would be the same as renaming var to var in the
; macroexpansion of (<= var '23).

  (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-gen (cadr x) var
                                                     (caddr x) tflg))
        ((eq x 'rational) (list 'rationalp var))
        ((eq x 'real) (list 'real/rationalp var))
        ((eq x 'double-float) (list 'dfp var))
        ((eq x 'complex) (list 'complex/complex-rationalp var))
        ((eq x 'number) (list 'acl2-numberp 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 (conjoin?
                    tflg
                    (list
                     (list 'rationalp var)
                     (cond ((consp upper-bound)
                            (list '< var (kwote? tflg (car upper-bound))))
                           (t (<=? tflg var (kwote? tflg upper-bound)))))))))
              (t (cond
                  ((eq upper-bound '*)
                   (conjoin?
                    tflg
                    (list
                     (list 'rationalp var)
                     (cond ((consp lower-bound)
                            (list '< (kwote? tflg (car lower-bound)) var))
                           (t (<=? tflg (kwote? tflg lower-bound) var))))))
                  (t (conjoin?
                      tflg
                      (list
                       (list 'rationalp var)
                       (cond
                        ((consp lower-bound)
                         (list '< (kwote? tflg (car lower-bound)) var))
                        (t (<=? tflg (kwote? tflg lower-bound) var)))
                       (cond
                        ((consp upper-bound)
                         (>? tflg (kwote? tflg (car upper-bound)) var))
                        (t (<=? tflg var (kwote? tflg 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 (conjoin?
                    tflg
                    (list
                     (list 'real/rationalp var)
                     (cond ((consp upper-bound)
                            (list '< var (kwote? tflg (car upper-bound))))
                           (t (<=? tflg var (kwote? tflg upper-bound)))))))))
              (t (cond
                  ((eq upper-bound '*)
                   (conjoin?
                    tflg
                    (list
                     (list 'real/rationalp var)
                     (cond ((consp lower-bound)
                            (list '< (kwote? tflg (car lower-bound)) var))
                           (t (<=? tflg (kwote? tflg lower-bound) var))))))
                  (t (conjoin?
                      tflg
                      (list
                       (list 'real/rationalp var)
                       (cond
                        ((consp lower-bound)
                         (list '< (kwote? tflg (car lower-bound)) var))
                        (t (<=? tflg (kwote? tflg lower-bound) var)))
                       (cond
                        ((consp upper-bound)
                         (>? tflg (kwote? tflg (car upper-bound)) var))
                        (t (<=? tflg var (kwote? tflg upper-bound)))))))))))
            (t nil))))
        ((eq x 'bit) (disjoin? tflg
                               (list
                                (list 'equal var (kwote? tflg 1))
                                (list 'equal var (kwote? tflg 0)))))
        ((and (consp x)
              (eq (car x) 'mod)
              (true-listp x)
              (equal (length x) 2)
              (integerp (cadr x)))
         (translate-declaration-to-guard/integer-gen 0 var
                                                     (1- (cadr x)) tflg))
        ((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 (kwote? tflg (cadr x)) var))
        ((eq x 'unsigned-byte)
         (translate-declaration-to-guard/integer-gen 0 var '* tflg))
        ((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 (kwote? tflg (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 (kwote? tflg nil)))
        ((eq x 'ratio) (conjoin? tflg
                                 (list
                                  (list 'rationalp var)
                                  (list 'not (list 'integerp var)))))
        ((eq x 'standard-char) (list 'standard-char-p+ 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))
         (conjoin? tflg
                   (list
                    (list 'stringp var)
                    (list 'equal
                          (list 'length var)
                          (kwote? tflg (cadr x))))))
        ((eq x 'symbol) (list 'symbolp var))
        ((eq x 't) (kwote? tflg t))
        ((and (weak-satisfies-type-spec-p x)
              (or (symbolp wrld)
; The next line uses len instead of length for the sake of guard verification.
                  (eql (len (getpropc (cadr x) 'formals nil wrld))
                       1)))
         (list (cadr x) var))
        ((and (consp x)
              (eq (car x) 'member)
              (eqlable-listp (cdr x)))
         (list (if tflg 'member-equal 'member) var (list 'quote (cdr x))))
        (t nil)))

(defun translate-declaration-to-guard1 (x var wrld)

; This is just the special case of translate-declaration-to-guard1-gen for tflg
; = nil, for backwards compatibility.  See get-guards2 for a discussion of
; tflg.

  (declare (xargs :guard (or (symbolp wrld)
                             (plist-worldp wrld))
                  :mode :program))
  (translate-declaration-to-guard1-gen x var nil wrld))

(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-gen (x var tflg 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 either an
; untranslated term or a translated term about var (depending on tflg), except
; that we return nil if x is seen not to be a valid type-spec for ACL2.  See
; get-guards2 for a discussion of tflg.

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

;                  :measure (acl2-count x)
                  ))
  (cond ((atom x) (translate-declaration-to-guard1-gen x var tflg wrld))
        ((eq (car x) 'not)
         (cond ((and (true-listp x)
                     (equal (length x) 2))
                (let ((term (translate-declaration-to-guard-gen
                             (cadr x)
                             var
                             tflg
                             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-gen-lst
                                      (cdr x)
                                      var
                                      tflg
                                      wrld)))
                           (cond (args (conjoin? tflg 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-gen-lst
                                      (cdr x)
                                      var
                                      tflg
                                      wrld)))
                           (cond (args (disjoin? tflg args))
                                 (t nil))))))
               (t nil)))
        ((eq (car x) 'complex)
         (cond ((and (consp (cdr x))
                     (null (cddr x)))
                (let ((r (translate-declaration-to-guard-gen
                          (cadr x)
                          (list 'realpart var)
                          tflg
                          wrld))
                      (i (translate-declaration-to-guard-gen
                          (cadr x)
                          (list 'imagpart var)
                          tflg
                          wrld)))
                  (cond ((and r i)
                         (conjoin?
                          tflg
                          (list (list 'complex/complex-rationalp var) r i)))
                        (t nil))))
               (t nil)))
        (t (translate-declaration-to-guard1-gen x var tflg wrld))))

(defun translate-declaration-to-guard-gen-lst (l var tflg wrld)

; Wrld is an ACL2 logical world or a symbol; see
; translate-declaration-to-guard-gen.

  (declare (xargs ; :measure (acl2-count l)
            :guard (and (true-listp l)
                        (consp l)
                        (or (symbolp wrld)
                            (plist-worldp wrld)))
            :mode :program))
  (and (consp l)
       (let ((frst (translate-declaration-to-guard-gen
                    (car l)
                    var
                    tflg
                    wrld)))
         (cond ((null frst)
                nil)
               ((endp (cdr l))
                (list frst))
               (t (let ((rst (translate-declaration-to-guard-gen-lst
                              (cdr l)
                              var
                              tflg
                              wrld)))
                    (cond ((null rst) nil)
                          (t (cons frst rst)))))))))

 )

(defun translate-declaration-to-guard (x var wrld)
  (declare (xargs :guard (or (symbolp wrld)
                             (plist-worldp wrld))
                  :mode :program

; See the comment above translate-declaration-to-guard/integer-gen.

;                  :measure (acl2-count x)
                  ))

; This is just the special case of translate-declaration-to-guard-gen for tflg
; = nil for backwards compatibility.  See get-guards2 for a discussion of tflg.

  (translate-declaration-to-guard-gen x var nil wrld))

(defun translate-declaration-to-guard-lst (l var wrld)
  (declare (xargs ; :measure (acl2-count l)
            :guard (and (true-listp l)
                        (consp l)
                        (or (null wrld)
                            (plist-worldp wrld)))
            :mode :program))

; This is just the special case of translate-declaration-to-guard-gen-lst for
; tflg = nil for backwards compatibility.  See get-guards2 for a discussion of
; tflg.

  (translate-declaration-to-guard-gen-lst l var nil wrld))

(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-gen, 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: ~x0."
                    (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.  Don't be concerned that
; (or t ,x) carries no restriction on the type -- the type declaration is only
; for the syntactic check mentioned above, not for efficiency (since after all,
; THE only generates this code in the logic, not in raw Lisp).

; 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*.  We make an exception for the
; case that x is DOUBLE-FLOAT, as we consider that case to be a logical no-op
; other than to enforce :DF tracking by translate.  See :DOC the.

  (declare (xargs :guard (translate-declaration-to-guard x 'var nil)))
  (if (eq x 'double-float)
      y
    (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 (including the DOUBLE-FLOAT exception).

  (declare (xargs :guard (and (symbolp y)
                              (translate-declaration-to-guard x y nil))))
  (if (eq x 'double-float)
      y
    (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.

; Essay on Fixnum Declarations

; Below are values of the largest fixnums in 64-bit Lisps as of April, 2024.

; Values of most-positive-fixnum in 64-bit Lisps:
; GCL:       9223372036854775807 ; (1- (expt 2 63))
; Allegro:   1152921504606846975 ; (1- (expt 2 60))
; CMUCL:     [apparently available only in 32-bit Lisp]
; SBCL:      4611686018427387903 ; (1- (expt 2 62))
; CCL:       1152921504606846975 ; (1- (expt 2 60))
; Lispworks: 1152921504606846975 ; (1- (expt 2 60))

; The remainder of this Essay gives historical perspective in ACL2's use of
; fixnum arithmetic.  It was written when 32-bit Lisps were still common.  The
; discussion carries over to 64-bit Lisps, where now we make type declarations
; using #.*fixnum-type* rather than, as discussed below, (signed-byte 30).  To
; get the previous behavior, use a 32-bit Lisp like CMUCL or set environment
; variable ACL2_SMALL_FIXNUMS to a non-empty value.

; To the best of our knowledge, the values of most-positive-fixnum in various
; 32-bit lisps are as follows, so we feel safe in using (signed-byte 30) and
; hence (unsigned-byte 29) to represent fixnums.  At worst, if a lisp is used
; for which (signed-byte 30) is not a subtype of fixnum, a compiler may simply
; fail to create efficient code.  Note:

; (the (signed-byte 30) 536870911) ; succeeds
; (the (signed-byte 30) 536870912) ; fails
; (the (unsigned-byte 29) 536870911) ; succeeds
; (the (unsigned-byte 29) 536870912) ; fails

; Values of most-positive-fixnum in 32-bit Lisps:
; GCL:        2147483647
; Allegro:    536870911
; Lucid:      536870911
; CMUCL:      536870911
; SBCL:       536870911
; CCL:        536870911
; MCL:        268435455 ; not supported after ACL2 Version_3.1
; CLISP:       16777215
; Lispworks:  536870911 [version 6.0.1; but observed 8388607 in versions 4.2.0
;                        and 4.4.6]

; We have made many type declarations in the sources of (signed-byte 30).
; Performance could be seriously degraded if these were not fixnum
; declarations.  If the following check fails, then we should consider lowering
; 30.  However, clisp has 24-bit fixnums.  Clisp maintainer Sam Steingold has
; assured us that "CLISP has a very efficient bignum implementation."  Lispworks
; Version 4.2.0 on Linux, 32-bit, had most-positive-fixnum = 8388607 and
; most-negative-fixnum = -8388608; and we have been informed (email 10/22/02)
; that "this is an architectural limit on this platform and the LispWorks fixnum
; size cannot be reconfigured."  But Lispworks 6 is back to supporting larger
; fixnums.

(defconst *fixnum-bits*
  #+acl2-small-fixnums 30
  #-acl2-small-fixnums 61)
(defconst *fixnat-bits* (1- *fixnum-bits*))
(defconst *fixnum-type* `(signed-byte ,*fixnum-bits*))
(defmacro the-fixnum (n)
  (list 'the *fixnum-type* n))
(defmacro fixnum-bound ()
; This has been the value of most-positive-fixnum in some 32-bit Lisps.
  (1- (expt 2 *fixnat-bits*)))

(defun fixnat-alistp (x) ; used in the guards of some system functions
  (declare (xargs :guard t))
  (cond ((atom x) (eq x nil))
        (t (and (consp (car x))
                (natp (car (car x)))
                (<= (car (car x)) (fixnum-bound))
                (fixnat-alistp (cdr x))))))

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

; Essay on 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 #(6 2 a).  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 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.  Note that the :maximum-length value must exceed the
; dimension, to accommodate the header in the alist.

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

(defmacro array-maximum-length-bound ()

; See the Essay on Efficient Applicative Arrays.

; This value is the upper bound for the maximum-length of an ACL2 array.  It
; needs to be a fixnum, not only so that array dimensions will be fixnums, but
; also because in compress1, the variable num is declared to have type (integer
; 0 #.*array-maximum-length-bound*) and num can be as large as the
; maximum-length of an array.

; This 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."  But we now make a potentially stronger
; requirement based on the array-total-size-limit and array-dimension-limit of
; the underlying Common Lisp implementation, as enforced by make-array$, and
; also a potentially weaker requirement, as follows.

  (fixnum-bound))

(defconst *array-maximum-length-bound*

; This is just the value provided by array-maximum-length-bound.  The macro
; is useful because it avoids a special variable value lookup at runtime,
; and this constant is useful because #.array-maximum-length-bound can be used
; in type expressions.

  (array-maximum-length-bound))

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

; Here is a summary of the above constants in various lisps.

; Lisp              array-dimension-limit          array-total-size-limit
; ---------------   ---------------------          ----------------------
; CMUCL 21e                   536870911 [2^29-1]             536870911 [2^29-1]
; SBCL 2.4.3             17592186044416 [2^44]          17592186044416 [2^44]
; GCL 2.5.0         9223372036854775807 [2^63-1]   9223372036854775807 [2^63-1]
; LISPWORKS 8.0.1             536870911 [2^29-1]             536870911 [2^29-1]
; Allegro CL 10.0   1152921504606846975 [2^60-1]   1152921504606846975 [2^60-1]
; CCL 1.12.1-22       72057594037927936 [2^56]       72057594037927936 [2^56]

; 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 compress 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, (k . x), where each k is
; either :header or a nonnegative integer less than n.

  (declare (xargs :guard (posp n)))
  (cond ((atom l) (null l))
        (t (and (consp (car l))
                (let ((key (caar l)))
                  (and (or (eq key :header)
                           (and (integerp key)
                                (>= 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)

; Warning: If you change this definition, make the corresponding change in the
; definition of macroexpand1-cmp!

  (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* ((state *the-live-state*)
           (wrld (w state))
           (ctx 'check-proposed-imports)
           (project-dir-alist (project-dir-alist wrld))
           (old-book-path (package-entry-book-path package-entry))
           (current-book-path
            (append (strip-cars (symbol-value 'acl2::*load-compiled-stack*))
                    (global-val 'include-book-path wrld)))
           (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 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 book in 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 book in 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)
       (book-name-lst-to-filename-lst (reverse old-book-path)
                                      project-dir-alist
                                      ctx)
       (if current-book-path 1 0)
       (book-name-lst-to-filename-lst (reverse current-book-path)
                                      project-dir-alist
                                      ctx)
       (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
               (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 (array-maximum-length-bound))
                     (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))))
                    (array-maximum-length-bound))
                (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))))
                    (array-maximum-length-bound))))
  :rule-classes ((:linear :match-free :all)))

(defun bounded-integer-alistp2 (l i j)
  (declare (xargs :guard (and (posp i)
                              (posp j))))
  (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)
                                       (>= 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
                                (array-maximum-length-bound))
                            (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))))
                    (array-maximum-length-bound))
                (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))))
                    (array-maximum-length-bound))))
  :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)

; See the Essay on Efficient Applicative Arrays.

  #+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 (integer 0 #.*array-maximum-length-bound*) 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)

; See the Essay on Efficient Applicative Arrays.

; 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 (integer 0 #.*array-maximum-length-bound*) ...) below rely
; on the array1p guard.  These declarations almost surely assist efficiency in
; GCL; they might or might not make a difference in other Lisps.

  #+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 t)
         (num ; to be the number of elements in the compressed alist
          1))
    (declare (type (integer 0 #.*array-maximum-length-bound*) num))

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

; Determine whether l is already in normal form (header first, strictly ordered
; keys, no default values, no extra header.)

    (when order
      (cond ((eq (caar l) :header)

; When l consists only of the header, it is in order so we can skip the checks
; below.  And as the code below is written, we need to skip the checks, because
; (equal (cdr (car tl)) default) can be true when tl = (cdr l) = default = nil.

             (when (consp (cdr l))
               (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) ; see comment above
                          (setq in-order nil)
                          (return nil))
                         ((null (cdr tl)) (return nil))
                         ((if (eq order '>)
                              (<= (the (integer 0
                                                #.*array-maximum-length-bound*)
                                       (caar tl))
                                  (the (integer 0
                                                #.*array-maximum-length-bound*)
                                       (car (cadr tl))))
                            (>= (the (integer 0 #.*array-maximum-length-bound*)
                                     (caar tl))
                                (the (integer 0 #.*array-maximum-length-bound*)
                                     (car (cadr tl)))))
                          (setq in-order nil)
                          (return nil))))))
            (t (setq in-order nil))))

; Get an array that is completely filled with default or the special mark
; *invisible-array-mark*, depending on whether or not the alist is ordered,
; i.e., in order after the initial header (we actually also require that the
; header does not appear in the cdr) and where order is < or > (i.e., not nil).
; In that ordered case we write the default value, skipping the extra pass for
; writing *invisible-array-mark*, which is justified since there are no
; duplicate indices in the alist.

    (let ((init (if (and in-order order) default *invisible-array-mark*)))
      (cond ((and old
                  (= 1 (array-rank (cadr old)))

; Through Version_8.3 we required equality in the following comparison.  But
; Eric Smith suggested that we might re-use an array whose length exceeds what
; is needed, simply ignoring the extra elements.  That's what we do now, in the
; hope that it speeds up applications like his Axe prover in which the same
; array is to be reused many times; now, we avoid paying the price of
; initializing at indices beyond the intended length.

                  (>= (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 (integer -1 #.*array-maximum-length-bound*) i))
                 (setf (svref ar i) init)))
            (t (setq ar (make-array$ length :initial-element init)))))

; Store the value of each pair under its key.  However, if there may be
; duplicate keys in the cdr of the alist, then we must avoid storing the value
; when it is covered by an earlier pair with the same key.  We can avoid that
; consideration if the alist is ordered as discussed above, since in that case
; there are no duplicate keys (and in that case, we have populated the array
; using default rather than *invisible-array-mark*).

    (cond
     ((and in-order order) ; just do the writes, as indicated above
      (do ((tl (cdr l) (cdr tl))) ; note: by in-order, no header is in (cdr l)
; The following termination test is true immediately if l consists only of the
; header.
          ((null tl))
          (setf (svref ar (caar tl))
                (cdar tl)))
      (setq num (length (cdr l))))
     (t
      (do ((tl l (cdr tl)))
; The following termination test is true immediately if l consists only of the
; header (but we can only be in that case here if order is nil).
          ((null tl))
          (let ((index (caar tl)))
            (cond ((eq index :header) nil)
                  ((eq *invisible-array-mark* (svref ar index))
                   (setf (svref ar index)
                         (cdar tl))))))))

    (let (x max-ar)

;  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.  Except:
;  in the ordered case we skip the latter two steps, since defaults are already
;  in the array and num is already set .

      (cond ((and in-order order) ; array and num have already been updated
             (setq x l))
            (in-order ; hence order is nil
             (do ((i (1- length) (1- i))) ((< i 0))
                 (declare (type (integer -1 #.*array-maximum-length-bound*) i))
                 (let ((val (svref ar i)))
                   (cond
                    ((eq *invisible-array-mark* val)
                     (setf (svref ar i) default))
                    (t (setq num
                             (the (integer 0 #.*array-maximum-length-bound*)
                                  (1+ num)))))))
             (setq x l))
            ((eq order '>)
             (do ((i 0 (1+ i))) ((int= i length))
                 (declare (type (integer 0 #.*array-maximum-length-bound*) 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 (integer 0 #.*array-maximum-length-bound*)
                                  (1+ num)))))))
             (setq x (cons header x)))
            (t ; (eq order '<)
             (do ((i (1- length) (1- i))) ((< i 0))
                 (declare (type (integer -1 #.*array-maximum-length-bound*) 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 (integer 0 #.*array-maximum-length-bound*)
                                  (1+ num)))))))
               (setq x (cons header x))))
      (cond
       (old (setq max-ar (caddr old))
            (setf (aref (the (array (integer 0 #.*array-maximum-length-bound*)
                                    (*))
                             max-ar)
                        0)
                  (the (integer 0 #.*array-maximum-length-bound*)
                       (- maximum-length num))))
       (t (setq max-ar
                (make-array$ 1
                             :initial-contents
                             (list (- maximum-length num))
                             :element-type
                             '(integer 0 #.*array-maximum-length-bound*)))))
      (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)

; See the Essay on Efficient Applicative Arrays.

  #+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 (integer 0 #.*array-maximum-length-bound*) 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 (integer 0 #.*array-maximum-length-bound*)
                                (*))
                         (caddr prop))
                    0)))
        (declare (type (integer 0 #.*array-maximum-length-bound*) to-go)
                 (simple-vector ar))
        (cond
         ((eql (the (integer 0 #.*array-maximum-length-bound*) 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 (integer 0 #.*array-maximum-length-bound*)
                           num length))
            (declare (type (integer 0 #.*array-maximum-length-bound*)
                           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 (integer 0 #.*array-maximum-length-bound*)
                         i))
                  (let ((val (svref ar
                                    (the (integer
                                          0
                                          #.*array-maximum-length-bound*)
                                         i))))
                    (cond ((equal val default) nil)
                          (t (push (cons i val) x)
                             (setq num
                                   (the (integer
                                         0
                                         #.*array-maximum-length-bound*)
                                        (1+ num))))))))
             (t
              (do ((i (1- length) (1- i)))
                  ((< i 0))
                  (declare
                   (type
                    (integer -1 #.*array-maximum-length-bound*)
                    i))
                  (let ((val
                         (svref ar
                                (the (integer 0
                                              #.*array-maximum-length-bound*)
                                     i))))
                    (cond ((equal val default) nil)
                          (t (push (cons i val) x)
                             (setq num
                                   (the (integer
                                         0
                                         #.*array-maximum-length-bound*)
                                        (1+ num)))))))))
            (setq x (cons header x))
            (setf (aref (the (array (integer 0 #.*array-maximum-length-bound*)
                                    (*))
                             (caddr prop)) 0)
                  (the (integer 0 #.*array-maximum-length-bound*)
                       (- 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 (integer 0
                                               #.*array-maximum-length-bound*)
                                      (*))
                               (caddr prop))
                          0)
                    (the (integer 0 #.*array-maximum-length-bound*)
                         (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 aset1-trusted (name l n val)

; This is an untouchable version of aset1 that doesn't have invariant-risk (see
; *boot-strap-invariant-risk-alist*).  It is untouchable for a good reason --
; invariant risk may be missed for functions that call aset1-trusted.  See :DOC
; aset1-trusted.

  (declare (xargs :guard (and (array1p name l)
                              (integerp n)
                              (>= n 0)
                              (< n (car (dimensions name l))))))
  (aset1 name l n val))

(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 (integer 0 #.*array-maximum-length-bound*) 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 (integer _ #.*array-maximum-length-bound*) ...) below rely
; on the array1p guard.  These declarations almost surely assist efficiency in
; GCL; they might or might not make a difference in other Lisps.

  (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 (>= (array-dimension (cadr old) 0) dimension1)
                     (>= (array-dimension (cadr old) 1) dimension2)))
           (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 (integer -1 #.*array-maximum-length-bound*) i))
                 (do ((j (1- dimension2) (1- j))) ((< j 0))
                     (declare (type (integer -1 #.*array-maximum-length-bound*) 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 (integer 0 #.*array-maximum-length-bound*)
                                  (car index))
                             (the (integer 0 #.*array-maximum-length-bound*)
                                  (cdr index))))
                   (setf (aref ar
                               (the (integer 0 #.*array-maximum-length-bound*)
                                    (car index))
                               (the (integer 0 #.*array-maximum-length-bound*)
                                    (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 (integer 0 #.*array-maximum-length-bound*)
                               (caaar tl))
                          (the (integer 0 #.*array-maximum-length-bound*)
                               (caaadr tl)))
                       (and (= (the (integer 0 #.*array-maximum-length-bound*)
                                    (caaar tl))
                               (the (integer 0 #.*array-maximum-length-bound*)
                                    (caaadr tl)))
                            (> (the (integer 0 #.*array-maximum-length-bound*)
                                    (cdaar tl))
                               (the (integer 0 #.*array-maximum-length-bound*)
                                    (cdaadr tl)))))
                   (setq in-order nil)
                   (return nil)))))
            (t (setq in-order nil)))
      (let ((x nil) (num 1) max-ar)
        (declare (type (integer 0 #.*array-maximum-length-bound*) 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 (integer -1 #.*array-maximum-length-bound*) i))
              (do ((j (1- dimension2) (1- j)))
                  ((< j 0))
                  (declare (type (integer -1 #.*array-maximum-length-bound*) j))
                  (let ((val (aref ar i j)))
                    (cond
                     ((eq *invisible-array-mark* val)
                      (setf (aref ar i j) default))
                     (t
                      (setq num (the (integer 0 #.*array-maximum-length-bound*)
                                     (1+ num))))))))
          (setq x l))
         (t (do ((i (1- dimension1) (1- i)))
                ((< i 0))
                (declare (type (integer -1 #.*array-maximum-length-bound*) i))
                (do ((j (1- dimension2) (1- j)))
                    ((< j 0))
                    (declare (type (integer -1 #.*array-maximum-length-bound*) 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 (integer 0 #.*array-maximum-length-bound*)
                                     (1+ num))))))))
            (setq x (cons header x))))
        (cond
         (old (setq max-ar (caddr old))
              (setf (aref (the (array
                                (integer 0 #.*array-maximum-length-bound*)
                                (*))
                               max-ar)
                          0)
                    (the (integer 0 #.*array-maximum-length-bound*)
                         (- maximum-length num))))
         (t (setq max-ar
                  (make-array$ 1
                               :initial-contents
                               (list (- maximum-length num))
                               :element-type
                               '(integer 0 #.*array-maximum-length-bound*)))))
        (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 (integer 0 #.*array-maximum-length-bound*) 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
                                (integer 0 #.*array-maximum-length-bound*)
                                (*))
                           (caddr prop))
                          0)))
        (declare (type (integer 0 #.*array-maximum-length-bound*) to-go))
        (declare (type (array * (* *)) ar))
        (cond
         ((eql (the (integer 0 #.*array-maximum-length-bound*) 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 (integer 0 #.*array-maximum-length-bound*)
                           num d1 d2 maximum-length))
            (do ((i (1- d1) (1- i)))
                ((< i 0))
                (declare (type (integer -1 #.*array-maximum-length-bound*) i))
                (do ((j (1- d2) (1- j)))
                    ((< j 0))
                    (declare (type (integer -1 #.*array-maximum-length-bound*) j))
                    (let ((val
                           (aref ar
                                 (the (integer 0
                                               #.*array-maximum-length-bound*)
                                      i)
                                 (the (integer 0
                                               #.*array-maximum-length-bound*)
                                      j))))
                      (cond
                       ((equal val default) nil)
                       (t
                        (push (cons (cons i j) val) x)
                        (setq num (the (integer 0
                                                #.*array-maximum-length-bound*)
                                       (1+ num))))))))
            (setq x (cons header x))
            (setf (aref (the (array (integer 0 #.*array-maximum-length-bound*)
                                    (*))
                             (caddr prop))
                        0)
                  (the (integer 0 #.*array-maximum-length-bound*)
                       (- 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 (integer 0
                                               #.*array-maximum-length-bound*)
                                      (*))
                           (caddr prop))
                          0)
                    (the (integer 0 #.*array-maximum-length-bound*)
                         (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))

(defun maybe-flush-and-compress1 (name ar)
  (declare (xargs :guard (array1p name ar)))
  #+acl2-loop-only
  (compress1 name ar)
  #-acl2-loop-only
  (let ((old (get-acl2-array-property name)))
    (cond
     ((null old)
      (compress1 name ar))
     ((eq (car old) ar)
      ar)
     (t (prog2$ (flush-compress name)
                (compress1 name ar))))))

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

(defun cdrn (x i)
  (declare (xargs :guard (and (integerp i)
                              (<= 0 i))))
  (cond ((zp i) x)
        (t (cdrn (list 'cdr x) (- i 1)))))

#+acl2-loop-only
(defun mv-list (input-arity x)
  (declare (xargs :guard t
                  :mode :logic)
           (ignore input-arity))
  x)

#-acl2-loop-only
(defmacro mv-list (input-arity x)
  (declare (ignore input-arity))
  `(multiple-value-list ,x))

(defmacro swap-stobjs (x y)

; The call (swap-stobjs st1 st2) logically swaps two input stobjs st1 and st2,
; but with the same stobjs-out as (mv st1 st2).  See translate11

; Note that since there are no duplicate live stobjs, it should be fine to call
; this macro even if one or both inputs are locally-bound (by with-local-stobj,
; with-global-stobj, or stobj-let).  Ultimately, the user-stobj-alist is put
; right by the calls of latch-stobjs in raw-ev-fncall.

; Trans-eval does not itself manage the user-stobj-alist, so we disallow the
; use of swap-stobjs at the top level; see translate11 and macroexpand1*-cmp.
; Before implementing that restriction, the following example illustrated that
; the user-stobj-alist wasn't being suitably updated by top-level calls.

;   (defstobj st1 fld1)
;   (defstobj st2 fld2 :congruent-to st1)
;   (defun foo (st1 st2)
;     (declare (xargs :stobjs (st1 st2)))
;     (swap-stobjs st1 st2))
;   (update-fld1 3 st1)
;   (update-fld1 4 st2)
;   (swap-stobjs st1 st2)
;   (fld1 st1) ; ERROR: 3, but should be 4
;   (fld1 st2) ; ERROR: 4, but should be 3
;   (foo st1 st2)
;   (fld1 st1) ; 4, now as expected
;   (fld1 st2) ; 3, now as expected

  `(mv ,y ,x))

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

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

; 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 idates (st)
  (declare (xargs :guard (true-listp st)))
  (nth 3 st))

(defun update-idates (x st)
  (declare (xargs :guard (true-listp st)))
  (update-nth 3 x st))

(defun acl2-oracle (st)
  (declare (xargs :guard (true-listp st)))
  (nth 4 st))

(defun update-acl2-oracle (x st)
  (declare (xargs :guard (true-listp st)))
  (update-nth 4 x st))

(defun file-clock (st)
  (declare (xargs :guard (true-listp st)))
  (nth 5 st))

(defun update-file-clock (x st)
  (declare (xargs :guard (true-listp st)))
  (update-nth 5 x st))

(defun readable-files (st)
  (declare (xargs :guard (true-listp st)))
  (nth 6 st))

(defun written-files (st)
  (declare (xargs :guard (true-listp st)))
  (nth 7 st))

(defun update-written-files (x st)
  (declare (xargs :guard (true-listp st)))
  (update-nth 7 x st))

(defun read-files (st)
  (declare (xargs :guard (true-listp st)))
  (nth 8 st))

(defun update-read-files (x st)
  (declare (xargs :guard (true-listp st)))
  (update-nth 8 x st))

(defun writeable-files (st)
  (declare (xargs :guard (true-listp st)))
  (nth 9 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 10 st))

(defun update-user-stobj-alist1 (x st)
  (declare (xargs :guard (true-listp st)))
  (update-nth 10 x st))

(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 *initial-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*
    comp-fn ; compile-uncompiled-defuns
    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-step-3+
    certify-book-fn
    translate11-local-def ; 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
    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
    times-mod-m31 ; gcl has raw code
    #+acl2-devel iprint-ar-aref1
    prove ; #+write-arithmetic-goals
    make-event-fn
    oops-warning
    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
    chk-return-last-entry-coda
    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
    fix-stobj-hash-table-type
    fix-stobj-table-type
    set-gc-threshold$-fn
    certify-book-finish-complete
    chk-absstobj-invariants
    get-stobj-creator
    iprint-oracle-updates@par
    brr-evisc-tuple-oracle-update@par
    print-brr-status
    set-brr-evisc-tuple1
    ld-fix-command
    update-enabled-structure-array
    update-enabled-structure
    #+acl2-devel apply$-lambda
    #+acl2-devel apply$-prim
    fchecksum-obj2
    check-sum-obj
    verify-guards-fn1 ; to update *cl-cache*
    ev-fncall+-w
    extend-current-theory
    defstobj-fn ; might be avoidable; see comment in that definition
    apply-user-stobj-alist-or-kwote ; no raw code but ill-guarded; see comments
    accp-info
    read-file-iterate-safe
    #+acl2-devel plist-worldp-with-formals ; *the-live-state* (performance)
    set-cbd-fn1
    read-hons-copy-lambda-object-culprit ; reads wormhole data from oracle
    #+acl2-devel ilks-plist-worldp
    defstobj-field-fns-raw-defs ; CCL bug #446
    chk-certificate-file
    get-cert-obj-and-cert-filename
    include-book-raw-error
    add-global-stobj remove-global-stobj
    translate-stobj-type-to-guard
    ))

(defconst *initial-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-persistent-whs                     ; *WORMHOLE-STATUS-ALIST*
    sync-ephemeral-whs-with-persistent-whs ; *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*
    fmt-to-comment-window!       ; *THE-LIVE-STATE*
    fmt-to-comment-window+       ; *THE-LIVE-STATE*
    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* (performance)
    #-acl2-devel plist-worldp-with-formals ; *the-live-state* (performance)
    wormhole-p                             ; *WORMHOLEP*
    may-need-slashes-fn ;*suspiciously-first-numeric-array* ...
    has-propsp          ; EQ, GET, ...
    hard-error          ; *HARD-ERROR-RETURNS-NILP*, FUNCALL, ...
    abort! p!           ; THROW
    flush-compress      ; SETF [may be critical for correctness]
    maybe-flush-and-compress1
    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 put-global close-input-channel
    makunbound-global open-input-channel open-input-channel-p1 boundp-global1
    global-table-cars1 close-output-channel write-byte$ get-global read-char$
    open-output-channel open-output-channel-p1 princ$ read-object
    peek-char$ read-run-time read-byte$ read-idate
    print-object$-fn 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 ; redefined from partial-encapsulate

    doppelganger-badge-userfn  ; redefined from partial-encapsulate
    doppelganger-apply$-userfn ; redefined from partial-encapsulate

    ev-fncall-w-guard1

; Found in apply-raw so users can see the *cl-cache*:

    print-cl-cache-fn

; 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             ; redefined from partial-encapsulate
    mfc-relieve-hyp-fn    ; redefined from partial-encapsulate
    mfc-relieve-hyp-ttree ; redefined from partial-encapsulate
    mfc-rw+-fn            ; redefined from partial-encapsulate
    mfc-rw+-ttree         ; redefined from partial-encapsulate
    mfc-rw-fn             ; redefined from partial-encapsulate
    mfc-rw-ttree          ; redefined from partial-encapsulate
    mfc-ts-fn             ; redefined from partial-encapsulate
    mfc-ts-ttree          ; redefined from partial-encapsulate
    magic-ev-fncall       ; redefined from partial-encapsulate
    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
    retract-stobj-tables
    get-cpu-time get-real-time
    increment-file-clock
    #-acl2-devel apply$-lambda
    #-acl2-devel apply$-prim
    #-acl2-devel ilks-plist-worldp

; Brr-evisc-tuple-oracle-update is logically defined in terms of
; read-acl2-oracle but actually returns the value of the raw Lisp variable
; *wormhole-brr-evisc-tuple*.  Iprint-oracle-updates has an analogous
; treatment.

    brr-evisc-tuple-oracle-update
    iprint-oracle-updates
    #-acl2-devel iprint-ar-aref1
    #-acl2-devel brr-near-missp

; Double-float functions:

    binary-df*
    binary-df+
    binary-df-log
    binary-df/
    df-abs-fn
    df-acos-fn
    df-acosh-fn
    df-asin-fn
    df-asinh-fn
    df-atan-fn
    df-atanh-fn
    df-cos-fn
    df-cosh-fn
    df-exp-fn
    df-expt-fn
    df-pi
    df-rationalize
    df-string
    df-sin-fn
    df-sinh-fn
    df-sqrt-fn
    df-tan-fn
    df-tanh-fn
    dfp
    from-df
    to-df
    unary-df-
    unary-df/
    unary-df-log
    df<-fn
    df=-fn
    df/=-fn
    ))

(defconst *initial-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-dwp!
    set-rw-cache-state! set-induction-depth-limit!
    attach-stobj 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! set-inhibit-er! defthm mv
    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
    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
    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
    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
    loop$
    our-with-terminal-input
    trust-mfc
    with-global-stobj
    with-cbd
    with-current-package
    ec-call
    ))

(defun untouchable-marker (mac)

; See :doc defmacro-untouchable.

  (declare (ignore mac)
           (xargs :guard t))
  t)

(defmacro defmacro-untouchable (mac args &rest rest)
  (declare (xargs :guard (and (symbolp mac)

; Warning: Keep this in sync with :doc defmacro-untouchable (in community book
; books/system/doc/acl2-doc.lisp).

; A better (stronger) conjunct here would be (macro-args-structurep args), but
; that hasn't been defined yet.  We'll just let defmacro report bad arguments.

                              (true-listp args)
                              (consp rest))))
  `(defmacro ,mac ,args
     ,@(butlast rest 1)
     (let ((form ,(car (last rest))))
       (list 'prog2$
             (list 'untouchable-marker (list 'quote ',mac))
             form))))

(defmacro-untouchable 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.  (That statement was
; written some time ago and may now be out of date.)  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-ld-special-bindings*

; Warning: Keep this in sync with f-get-ld-specials,
; chk-acceptable-ld-fn1-pair, *initial-ld-special-bindings*, ld-alist-raw,
; wormhole, and ld.

; 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.  There are no entries for current-package or useless-runes, even
; though these correspond to LD keyword arguments, because they are not LD
; specials.

  `((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-always-skip-top-level-locals . nil)
    (ld-pre-eval-filter . :all)
    (ld-pre-eval-print . nil)
    (ld-post-eval-print . :command-conventions)
    (ld-evisc-tuple . nil)
    (ld-error-triples . t)
    (ld-error-action . :continue)
    (ld-query-control-alist . nil)
    (ld-verbose . "Project-dir-alist:~|~xb.~|Type :help for help.~%Type ~
                   (quit) to quit completely out of ACL2.~|~%")
    (ld-user-stobjs-modified-warning . nil)))

(defconst *initial-global-table-1*

; When you add a new state global to this table, consider whether to modify
; *protected-system-state-globals*.

; No key of this alist should also be a key of *initial-ld-special-bindings*.

; We break this into an append of smaller lists, to avoid a GCL error reported
; by Camm Maguire related to call-arguments-limit.  In case this list is
; expanded later, we play it safe by breaking, initially, into sub-lists of
; length 50.

  (append
   `((abbrev-evisc-tuple . :default)
     (abort-soft . t)
     (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.6

; 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-gcl in
; acl2-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.6"
                                 #+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)
     (brr-evisc-tuple . :default) ; see About brr-evisc-tuple and Its Mirror
     (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)
     (event-data-fal . nil)
     (evisc-hitp-without-iprint . nil)
     (eviscerate-hide-terms . nil)
     (fast-cert-status . 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
     (giant-lambda-object . nil)
     (global-ctx . nil)
     (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
     (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-progn-fn1 . 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-history . nil)
     (ld-level . 0)
     (ld-okp . :default) ; see :DOC calling-ld-in-bad-contexts
     (logic-fns-with-raw-code . ,*initial-logic-fns-with-raw-code*)
     (macros-with-raw-code . ,*initial-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-info . nil) ; set in LP
     (pc-output . nil)
     (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 . ,*initial-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)
     (protect-memoize-statistics . 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 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-array-action . :break)  ; set to :warning in exit-boot-strap-mode
     (splitter-output . t)
     (step-limit-record . nil)
     (system-attachments-cache . nil) ; see modified-system-attachments
     (temp-touchable-fns . nil)
     (temp-touchable-vars . nil)
     (term-evisc-tuple . :default)
     (timer-alist . nil)
     (tmp-dir . nil)               ; initialized by initialize-state-globals
     (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-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.

     (useless-runes . nil)
     (user-home-dir . nil)) ; set first time entering lp
   '((verbose-theory-warning . t)
     (verify-termination-on-raw-program-okp
      .
      (apply$-lambda apply$-prim plist-worldp-with-formals ilks-plist-worldp
                     iprint-ar-aref1))
     (walkabout-alist . nil)
     (warnings-as-errors . nil)    ; nil or a warnings-as-errors record
     (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))))

(defun merge-symbol-alistp (a1 a2)
  (declare (xargs :mode :program))
  (cond ((endp a1) a2)
        ((endp a2) a1)
        ((symbol< (caar a1) (caar a2))
         (cons (car a1)
               (merge-symbol-alistp (cdr a1) a2)))
        (t
         (cons (car a2)
               (merge-symbol-alistp a1 (cdr a2))))))

(defun merge-sort-symbol-alistp (alist)
  (declare (xargs :mode :program))
  (cond ((endp (cdr alist)) alist)
        ((endp (cddr alist))
         (cond ((symbol< (car (car alist)) (car (cadr alist)))
                alist)
               (t (list (cadr alist) (car alist)))))
        (t (let* ((n (length alist))
                  (a (ash n -1)))
             (merge-symbol-alistp
              (merge-sort-symbol-alistp (take a alist))
              (merge-sort-symbol-alistp (nthcdr a alist)))))))

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

; Note that check-state-globals-initialized insists that all state globals that
; are bound by the build are bound in this alist.

  (merge-sort-symbol-alistp (append *initial-ld-special-bindings*
                                    *initial-global-table-1*)))

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

(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 channel-headerp (header)
  (declare (xargs :guard t))
  (and (true-listp header)
       (equal (length header) 4)
       (eq (car header) :header)
       (member-eq (cadr header) *file-types*)
       (stringp (caddr header))
       (integerp (cadddr header))))

(defun open-channel1 (l)
  (declare (xargs :guard t))
  (and (true-listp l)
       (consp l)
       (let ((header (car l)))
         (and (channel-headerp 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) 11)
       (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))))
       (print-base-p (cdr (assoc 'print-base (global-table x))))
       (known-package-alistp
        (getpropc 'known-package-alist 'global-value nil
                  (cdr (assoc 'current-acl2-world (global-table 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))
       (symbol-alistp (user-stobj-alist1 x))))

(defthm state-p1-forward
  (implies (state-p1 x)
           (and
            (true-listp x)
            (equal (length x) 11)
            (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))))
            (print-base-p (cdr (assoc 'print-base (nth 2 x))))
            (known-package-alistp
             (getpropc 'known-package-alist 'global-value nil
                       (cdr (assoc 'current-acl2-world (nth 2 x)))))
            (integer-listp (nth 3 x))
            (true-listp (nth 4 x))
            (file-clock-p (nth 5 x))
            (readable-files-p (nth 6 x))
            (written-files-p (nth 7 x))
            (read-files-p (nth 8 x))
            (writeable-files-p (nth 9 x))
            (symbol-alistp (nth 10 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 print-base-p
                    known-package-alistp true-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))

(defthm all-boundp-preserves-assoc-equal
  (implies (and (all-boundp tbl1 tbl2)
                (assoc-equal x tbl1))
           (assoc-equal x tbl2))
  :rule-classes nil)

(defthm all-boundp-initial-global-table

; This is disabled by default near the end of the boot-strap, to avoid the
; possibility of slowing down the rewriter, since otherwise it would have to
; look at this rule for every assoc-equal call.  But quite possibly that
; slowdown is trivial, so perhaps this rule could reasonably be left enabled.
; It is left enabled until near the end of the boot-strap to help with proofs,
; such as the guard conjecture for debugger-enable.

  (implies (and (state-p1 state)
                (assoc-eq x *initial-global-table*))
           (assoc-equal 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))))

; 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, 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
        idates acl2-oracle
        (file-clock '1) readable-files written-files
        read-files writeable-files 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 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 user-stobj-alist)))

(defconst *default-state*
  (list nil nil
        *initial-global-table*
        4000000 nil nil 1 nil nil nil nil nil))

(defun build-state1 (open-input-channels
   open-output-channels global-table
   idates acl2-oracle file-clock readable-files written-files
   read-files writeable-files user-stobj-alist)
  (declare (xargs :guard (state-p1 (list open-input-channels
   open-output-channels global-table
   idates acl2-oracle file-clock readable-files written-files
   read-files writeable-files 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
               idates acl2-oracle
               file-clock readable-files written-files
               read-files writeable-files 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 (remove1-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-untouchable 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))

(defun inhibit-er-hard (state)
  (declare (xargs :stobjs state :mode :program))
  (and (f-get-global 'inhibit-er-hard state)
       (member-eq 'error
                  (f-get-global 'inhibit-output-lst state))))

; We now define state-global-let*, which lets us "bind" state
; globals.

(defun always-boundp-global (x)
  (declare (xargs :guard (symbolp x)))
  (assoc-eq x *initial-global-table*))

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

(defconst *state-global-let*-untouchable-alist*

; Each entry in this alist is of the form (var . fn), where var is a state
; global and the approved way to set it, given a value x, is with (fn x state).
; Although the resulting value is generally x, that need not be exactly the
; case; in particularly, set-iprint calls compress1.

; This constant supports the use of state-global-let* to bind certain built-in
; untouchable variables without a translate error.  It was computed by
; evaluating the form (state-global-let*-untouchable-alist) in raw Lisp and
; checking manually that the functions are indeed appropriate.  We check in
; check-built-in-constants that this value is still equal to
; (state-global-let*-untouchable-alist).  We considered including macros as
; well, but that only added checkpoint-summary-limit and a few macros for
; controlling ACL2(p), so we avoid the (minor) extra complication of handling
; macros here.

  '((ABBREV-EVISC-TUPLE . SET-ABBREV-EVISC-TUPLE-STATE)
    (COMPILER-ENABLED . SET-COMPILER-ENABLED)
    (CURRENT-PACKAGE . SET-CURRENT-PACKAGE-STATE)
    (FMT-HARD-RIGHT-MARGIN . SET-FMT-HARD-RIGHT-MARGIN)
    (FMT-SOFT-RIGHT-MARGIN . SET-FMT-SOFT-RIGHT-MARGIN)
    (GAG-MODE-EVISC-TUPLE . SET-GAG-MODE-EVISC-TUPLE-STATE)
    (INHIBIT-OUTPUT-LST . SET-INHIBIT-OUTPUT-LST-STATE)
    (INHIBITED-SUMMARY-TYPES . SET-INHIBITED-SUMMARY-TYPES-STATE)
    (LD-EVISC-TUPLE . SET-LD-EVISC-TUPLE-STATE)
    (PPR-FLAT-RIGHT-MARGIN . SET-PPR-FLAT-RIGHT-MARGIN)
    (PRINT-BASE . SET-PRINT-BASE) (PRINT-CASE . SET-PRINT-CASE)
    (PRINT-LENGTH . SET-PRINT-LENGTH) (PRINT-LEVEL . SET-PRINT-LEVEL)
    (PRINT-LINES . SET-PRINT-LINES)
    (PRINT-RIGHT-MARGIN . SET-PRINT-RIGHT-MARGIN)
    (PROOFS-CO . SET-PROOFS-CO-STATE)
    (SERIALIZE-CHARACTER . SET-SERIALIZE-CHARACTER)
    (SERIALIZE-CHARACTER-SYSTEM . SET-SERIALIZE-CHARACTER-SYSTEM)
    (STANDARD-CO . SET-STANDARD-CO-STATE)
    (TEMP-TOUCHABLE-FNS . SET-TEMP-TOUCHABLE-FNS)
    (TEMP-TOUCHABLE-VARS . SET-TEMP-TOUCHABLE-VARS)
    (TERM-EVISC-TUPLE . SET-TERM-EVISC-TUPLE-STATE)))

(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
; :DOC 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)
   ((let ((binding (car bindings)))

; Case-match isn't defined yet; otherwise we'd write the following code.

;    (case-match binding
;      ((var ('f-get-global ('quote var) 'state))
;       (and (symbolp var)
;            (assoc-eq var *initial-global-table*)))
;      (& nil))

; That expression is easily proved equal to the one below by first evaluating
; events
;   (include-book "arithmetic/top" :dir :system)
; and
;   (defthm len-0 (equal (equal 0 (len x)) (atom x)))
; and then replacing the (or (assoc-eq ...) ...) expressions with a fresh
; variable, say, foo.

      (and (true-listp binding)
           (= (length binding) 2)
           (let ((var (car binding))
                 (expr (cadr binding)))
             (and (symbolp var)
                  (true-listp expr)
                  (= (length expr) 3)
                  (eq (car expr) 'f-get-global)
                  (eq (caddr expr) 'state)
                  (let ((qvar (cadr expr)))
                    (and (true-listp qvar)
                         (= (length qvar) 2)
                         (eq (car qvar) 'quote)
                         (eq (cadr qvar) var)))
                  (assoc-eq var *initial-global-table*)))))
    (state-global-let*-put-globals (cdr bindings)))
   (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
              (let ((x (assoc-eq (caar bindings)
                                 *state-global-let*-untouchable-alist*)))
                 (cond
                  (x ; e.g., (PRINT-CASE . SET-PRINT-CASE)
                   `(,(cdr x) ,val-form 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 :DOC 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))
                    (t
                     (let ((x (assoc-eq
                               (car (car bindings))
                               *state-global-let*-untouchable-alist*)))
                       (cond
                        (x ; e.g., (PRINT-CASE .  SET-PRINT-CASE)
                         `(,(cdr x)
                           (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)))))

(defun state-global-let*-fn (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)))))

(defmacro state-global-let* (bindings body)
  (state-global-let*-fn bindings body))

; With state-global-let* defined, we are now able to use LOCAL.

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

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

; The following lemma is probably useful not only for the verify-termination
; call just below but also for guard proofs for make-input-channel and
; make-output-channel, and for verify-termination-boot-strap[+guards] for
; packn-pos and related functions in boot-strap-pass-2-a.lisp where
; character-listp-explode-atom is proved.

(local
 (defthm character-listp-explode-nonnegative-integer
   (implies (character-listp z)
            (character-listp (explode-nonnegative-integer x y z)))))

(verify-termination-boot-strap make-var-lst1)

(verify-termination-boot-strap make-var-lst)

(encapsulate
  ()

  (local
   (defthm
     take-guard-lemma-1
     (equal (first-n-ac i l ac)
            (revappend ac (take i l)))))

  (verify-guards take))

(verify-termination-boot-strap butlast)
(verify-termination-boot-strap defun-nx-form)
(verify-termination-boot-strap defun-nx-fn)
(verify-termination-boot-strap update-mutual-recursion-for-defun-nx-1)
(verify-termination-boot-strap update-mutual-recursion-for-defun-nx)
(verify-termination-boot-strap program-declared-p)
(verify-termination-boot-strap some-program-declared-p)
(verify-termination-boot-strap parse-args-and-test)

#-acl2-loop-only
(progn

; At one time, the mv implementation returned only the first value and saving
; the other values in globals.  These forms were included to deal with that
; implementation of mv.

(defmacro our-multiple-value-prog1 (form &rest other-forms)

; This is just multiple-value-prog1 now; see comment above about the mv
; implementation.

  `(multiple-value-prog1 ,form ,@other-forms))

(eval `(mv ,@(make-list *number-of-return-values* :initial-element 0)))

(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 -- which is no longer an issue (see comment above about
; the mv implementation).

  (declare (ignore multiplicity))
  `(progn ,form 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 #-acl2-loop-only code.
; See also state-free-global-let*-safe for a safer, but probably less
; efficient, alternative.

; WARNING 1: This macro probably needs to be avoided when a 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 may be restored from *acl2-unwind-protect-stack* after an abort during
; that evaluation.

; WARNING 2: If this macro is used when state accessible in body, then in body,
; the value read for a state global bound in bindings may not be justified
; logically.  State should not be accessible in body unless 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)
   ((not (symbol-doublet-listp bindings))

; This this is a raw Lisp Function, it is reasonable to call error here rather
; than to use (er hard ...).  This way we avoid depending on the value of
; global *hard-error-is-error* for an error to be signaled.

    (error "The first argument of state-free-global-let* must be a true ~%~
            list of entries of the form (sym val) where sym is a symbol.~%~
            The argument ~s is thus illegal."
           bindings))
   (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)

; This variant of state-free-global-let* deals properly with the
; *acl2-unwind-protect-stack* when inside the ACL2 loop, thus avoiding
; restoration of state globals to incorrect values after an error if
; state-global-let* is used within body.  But like state-free-global-let*, it
; should be used with care if state is accessible in body.  See
; state-free-global-let* (a more efficient alternative when state globals are
; not set inside body) for relevant comments, including warnings.  Note that if
; body returns multiple values then this returns only the first value when in
; the ACL2 loop; that's unimportant of course if this function is called only
; for side-effect or if body returns only one value.

  (cond
   ((not (symbol-doublet-listp bindings))
; See comment at error call in state-free-global-let*.
    (error "The first argument of state-free-global-let*-safe must be a ~%~
            true list of entries of the form (sym val) where sym is a ~%~
            symbol.  The argument ~s is thus illegal."
           bindings))
   (t `(if #-acl2-par *acl2-unwind-protect-stack* #+acl2-par nil
           (with-live-state
            (mv-let (erp val state)
              (state-global-let* ,bindings (value ,body))
              (declare (ignore erp state))
              val))
           (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.

; We considered Alessandro Coglio's suggestion to fix the first two arguments,
; specifically by changing the body to the following.

;   (mbe :logic (and (integerp x)
;                    (<= (ifix lower) x)
;                    (< x (ifix upper)))
;        :exec (and (integerp x)
;                   (<= lower x)
;                   (< x upper))))

; However, that caused at least 19 regression failures, and we quickly found
; one that looked awkward to fix.  So we are abandoning that idea, at least for
; now.

  (declare (type integer lower 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)

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

; The theorem symbol-equality is useful in verifying the guards of getprops,
; so we deal with it next.

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

(defthm symbol-equality
   (implies (and (or (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))))))

; 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 (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 (or (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-remove1-assoc-eq
   (implies (ordered-symbol-alistp l)
            (ordered-symbol-alistp (remove1-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 (plist-worldp w)
            (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.

#+acl2-loop-only
(defmacro logand (&rest args)
  (cond
   ((null args)
    -1)
   ((null (cdr args))
    `(the integer ,(car args)))
   (t (xxxjoin 'binary-logand args))))

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

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

#+acl2-loop-only
(defmacro logxor (&rest args)
  (cond
   ((null args)
    0)
   ((null (cdr args))
    `(the integer ,(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*

; Warning: Keep this in sync with print-control-alistp.

  `((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 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 (atom 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))
        ((symbolp x) (coerce (symbol-name x) 'list))
        (t (coerce "SOME BAD ATOM" '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 (atom 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))))))))

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

(defmacro set-table-guard (name guard &key topic show coda)
  `(table ,name nil nil
          :guard
          (if ,guard
              (mv t nil)
            (mv nil
                (msg "The TABLE :guard for ~x0 disallows the combination of ~
                      key ~x1 and value ~x2.~#3~[  ~@4~/~]  See :DOC ~
                      ~x5.~@6"
                     ',name key val
                     ,(if show 0 1)
                     ,(and show ; optimization
                           `(msg "The :guard requires ~x0." ',guard))
                     ',(or topic name)
                     (let ((coda ,coda))
                       (if coda
                           (msg "  ~@0" coda)
                         "")))))))

(set-table-guard
 acl2-defaults-table

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

 (cond
  ((eq key :defun-mode)
   (member-eq val '(:logic :program)))
  ((eq key :verify-guards-eagerness)
   (member val '(0 1 2 3)))
  ((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 *fixnat-bits* 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)

; At one time we disallowed :SYSTEM as a key.  Now, we check at
; add-include-book-dir time that :SYSTEM isn't bound to a directory that
; conflicts with the value in the project-dir-alist.  Note that the
; :include-book-dir-alist entry of the acl2-defaults-table can only be set by
; way of add-include-book-dir; see the use of state global
; modifying-include-book-dir-alist in chk-table-guard.

   (include-book-dir-alistp val (os world)))
  ((eq key :ruler-extenders)
   (or (eq val :all)
       (chk-ruler-extenders val hard 'acl2-defaults-table world)))
  ((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)))))
  ((eq key :register-invariant-risk)
   (or (eq val t)
       (and (eq val nil)
            (or (null (get-register-invariant-risk-world world))
                (ttag world)))))
  ((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))
  ((eq key :in-theory-redundant-okp)
   (booleanp val))
  (t nil))
 :coda (and (member-eq key '(:check-invariant-risk
                             :register-invariant-risk))
            (null val)
            (msg "Note that an active trust tag is required for setting the ~
                  ~x0 key to nil in the acl2-defaults-table."
                 key)))

; (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 check-print-case (print-case ctx)
  (declare (xargs :guard t :mode :logic))
  (if (or (eq print-case :upcase)
          (eq print-case :downcase))
      nil
    (hard-error ctx
                "The value ~x0 is illegal as an ACL2 print-case, which must ~
                 be :UPCASE or :DOWNCASE."
                (list (cons #\0 print-case)))))

(defun set-print-case (case state)
  (declare (xargs :guard (and (or (eq case :upcase) (eq case :downcase))
                              (state-p state))))
  (prog2$ (check-print-case case 'set-print-case)
          (f-put-global 'print-case case state)))

(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 :mode :logic))
  (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)))

(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 var)
  (declare (xargs :guard t :mode :logic))
  (or (null n)
      (natp n)
      (hard-error 'check-null-or-natp
                  "The value of ~x0 must be ~x1 or a positive integer, but ~
                   ~x2 is neither."
                  (list (cons #\0 var)
                        (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 '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 '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 '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 '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*)))

(defun raw-print-vars-alist (print-control-defaults-tail)

; At the top level, print-control-defaults-tail is *print-control-defaults*.

  (declare (xargs :guard (symbol-alistp print-control-defaults-tail)))
  (cond
   ((endp print-control-defaults-tail) nil)
   (t
    (cons (let ((sym (caar print-control-defaults-tail)))
            (cons (intern (concatenate 'string "*" (symbol-name sym) "*")
                          "ACL2")
                  sym))
          (raw-print-vars-alist (cdr print-control-defaults-tail))))))

(defconst *raw-print-vars-alist*

; We use this value in the definition of with-print-controls.  To avoid some
; code duplication, we compute it from *print-control-defaults*.

; Note that *print-lines* is only defined when #+cltl2.  But we always set
; feature :cltl2 now, so that's OK.

; 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
; including (*print-pprint-dispatch* nil . nil).  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!

  (raw-print-vars-alist *print-control-defaults*))

#-acl2-loop-only
(defun with-print-controls-defaults (bindings body)
  `(let ,(loop for pair in *raw-print-vars-alist*
               when (not (assoc-eq (car pair) bindings))
               collect
               (let ((lisp-var (car pair))
                     (acl2-var (cdr pair)))
                 (list lisp-var
                       (cadr (assoc-eq acl2-var
                                       *print-control-defaults*)))))
     ,@body))

#-acl2-loop-only
(defun with-print-controls-alist (alist bindings body)

; Alist takes priority over bindings.

  (let ((var (gensym)))
    `(let ((,var ,alist)
           ,@(loop for pair in *raw-print-vars-alist*
                   when (not (assoc-eq (car pair) bindings))
                   collect
                   (let ((lisp-var (car pair))
                         (acl2-var (cdr pair)))
                     (list lisp-var
                           `(f-get-global ',acl2-var *the-live-state*)))))
       (progv (strip-cars ,var)
              (strip-cdrs ,var)
              ,@body))))

#-acl2-loop-only
(defmacro with-print-controls (default bindings &rest body)

; Default is either the symbol, :DEFAULTS, or else an expression whose value is
; a pair whose car is a duplicate-free list of keys contained in the keys of
; *print-control-defaults* and whose cdr is a corresponding list of legal
; values for those keys.

; Warning; If you bind *print-base* to value pb (in bindings), then you should
; strongly consider binding *print-radix* to nil if pb is 10 and to t
; otherwise.

  (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*)
           (*package* (find-package-fast (current-package state)))
           #+cltl2 (*print-miser-width* nil)
           #+cltl2 (*read-eval* nil) ; to print without using #.
           ,@bindings)
       ,(cond ((equal default :DEFAULTS)
               (with-print-controls-defaults bindings body))
              (t
               (with-print-controls-alist default bindings 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)))

; Define support for the partial-encapsulate below.

(defun all-function-symbolps (fns wrld)
  (declare (xargs :guard (plist-worldp wrld)))
  (cond ((atom fns) (equal fns nil))
        (t (and (symbolp (car fns))
                (function-symbolp (car fns) wrld)
                (all-function-symbolps (cdr fns) wrld)))))

(defconst *unknown-constraints*

; This value must not be a function symbol, because functions may need to
; distinguish conses whose car is this value from those consisting of function
; symbols.

  :unknown-constraints)

(defun non-trivial-encapsulate-ee-entries (embedded-event-lst)
  (declare (xargs :mode :program))
  (cond ((endp embedded-event-lst)
         nil)
        ((and (eq (caar embedded-event-lst) 'encapsulate)
              (cadar embedded-event-lst))
         (cons (car embedded-event-lst)
               (non-trivial-encapsulate-ee-entries (cdr embedded-event-lst))))
        (t (non-trivial-encapsulate-ee-entries (cdr embedded-event-lst)))))

(defun unknown-constraints-table-guard (key val wrld)
  (declare (xargs :mode :program))
  (let ((er-msg "The proposed attempt to add unknown-constraints is illegal ~
                 because ~@0.  See :DOC partial-encapsulate."))
    (cond
     ((eq key :supporters)
      (let ((ee-entries (non-trivial-encapsulate-ee-entries
                         (global-val 'embedded-event-lst wrld))))
        (cond
         ((null ee-entries)
          (mv nil
              (msg er-msg
                   "it is not being made in the scope of a non-trivial ~
                    encapsulate")))
         ((cdr ee-entries)
          (mv nil
              (msg er-msg
                   (msg "it is being made in the scope of nested non-trivial ~
                         encapsulates.  In particular, an enclosing ~
                         encapsulate introduces function ~x0, while an ~
                         encapsulate superior to that one introduces function ~
                         ~x1"
                        (caar (cadr (car ee-entries)))
                        (caar (cadr (cadr ee-entries)))))))
         ((not (all-function-symbolps val wrld))
          (mv nil
              (msg er-msg
                   (msg "the value, ~x0, is not a list of known function ~
                         symbols"
                        val))))
         ((not (subsetp-equal (strip-cars (cadr (car ee-entries)))
                              val))
          (mv nil
              (msg er-msg
                   (msg "the value, ~x0, does not include all of the ~
                         signature functions of the partial-encapsulate"
                        val))))
         (t (mv t nil)))))
     (t (mv nil nil)))))

(table unknown-constraints-table nil nil
       :guard
       (unknown-constraints-table-guard key val world))

(defmacro set-unknown-constraints-supporters (&rest fns)
  `(table unknown-constraints-table
          :supporters

; Notice that by including the newly-constrained functions in the supporters,
; we are guaranteeing that this table event is not redundant.  To see this,
; first note that we are inside a non-trivial encapsulate (see
; trusted-cl-proc-table-guard), and for that encapsulate to succeed, the
; newly-constrained functions must all be new.  So trusted-cl-proc-table-guard
; would have rejected a previous attempt to set to these supporters, since they
; were not function symbols at that time.

          (let ((ee-entries (non-trivial-encapsulate-ee-entries
                             (global-val 'embedded-event-lst world))))
            (union-equal (strip-cars (cadr (car ee-entries)))
                         ',fns))))

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

(defun chk-inhibit-output-lst-msg (lst)
  (declare (xargs :guard t))
  (cond ((not (true-listp lst))
         (msg "The argument to set-inhibit-output-lst must evaluate to a ~
               true-listp, unlike ~x0."
              lst))
        ((not (subsetp-eq lst *valid-output-names*))
         (msg "The argument to set-inhibit-output-lst must evaluate to a ~
               subset of the list ~X01, but ~x2 contains ~&3."
              *valid-output-names*
              nil
              lst
              (set-difference-eq lst *valid-output-names*)))
        (t nil)))

(defun set-inhibit-output-lst-state (lst state)
  (declare (xargs :guard t))
  (let ((msg (chk-inhibit-output-lst-msg lst)))
    (cond (msg (prog2$ (er hard? 'set-inhibit-output-lst "~@0" msg)
                       state))
          (t (f-put-global 'inhibit-output-lst
                           (if (member-eq 'warning! lst)
                               (add-to-set-eq 'warning lst)
                             lst)
                           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)

(encapsulate
  ()

; We introduce models for the behaviors of alpha-char-p and character case
; functions on the non-standard characters.  Note that there are typically
; characters other than standard characters that are treated as upper case or
; lower case.  For example, (upper-case-p (code-char (+ 128 65))) is true in
; CCL, and char-downcase is not the identity on (code-char (+ 128 65)).
; However, Lisp implementations can differ on these functions; see :DOC
; soundness.

; Our models -- that is, the defthm events below -- are based on the following
; principles.  Note that unlike alpha-char-p in Common Lisp, these functions
; are total; in particular, the three recognizers return nil on non-character
; inputs.

; - Alpha-char-p-non-standard is a Boolean recognizer for the alphabetic
;   characters (as defined in the HyperSpec; see below).
; - Upper-case-p-non-standard and lower-case-p-non-standard are Boolean
;   recognizer for the upper-case and lower-case characters, respectively.
; - Char-downcase-non-standard and char-upcase-non-standard model the
;   implementation's behavior of char-downcase and char-upcase (respectively)
;   on character inputs, and they return an arbitrary character on
;   non-character inputs.

; We need the partial-encapsulate below to be executed in logic mode during the
; first pass of the boot-strap so that it will be redundant in the second pass
; of the boot-strap.

  (logic)

; The following passages from the Common Lisp HyperSpec support the axioms
; exported below.

;   Function ALPHA-CHAR-P

;   Returns true if character is an alphabetic[1] character; otherwise, returns
;   false.

;   13.1.4.3 Characters With Case

;   The characters with case are a subset of the alphabetic[1] characters. A
;   character with case has the property of being either uppercase or
;   lowercase. Every character with case is in one-to-one correspondence with
;   some other character with the opposite case.

;   Function CHAR-UPCASE, CHAR-DOWNCASE

;   If character is a lowercase character, char-upcase returns the
;   corresponding uppercase character. Otherwise, char-upcase just returns the
;   given character.

;   If character is an uppercase character, char-downcase returns the
;   corresponding lowercase character. Otherwise, char-downcase just returns
;   the given character.

;   13.1.4.3.4 Case of Implementation-Defined Characters

;   An implementation may define that other implementation-defined graphic
;   characters have case. Such definitions must always be done in pairs---one
;   uppercase character in one-to-one correspondence with one lowercase
;   character.

; Here is definition [1] of "alphabetic" in the HyperSpec, referenced above.

;   alphabetic n., adj. 1. adj. (of a character) being one of the standard
;   characters A through Z or a through z, or being any implementation-defined
;   character that has case, or being some other graphic character defined by
;   the implementation to be alphabetic[1].

; We start by putting standard-char-p in logic mode, so that during the first
; pass of the boot-strap, the partial-encapsulate below can process the defthm
; events that mention it.

  (verify-termination-boot-strap member-eql-exec)
  (verify-termination-boot-strap standard-char-p)

  (partial-encapsulate
   (((alpha-char-p-non-standard *)  => * :formals (x))
    ((upper-case-p-non-standard *)  => * :formals (x))
    ((lower-case-p-non-standard *)  => * :formals (x))
    ((char-downcase-non-standard *) => * :formals (x))
    ((char-upcase-non-standard *)   => * :formals (x)))
   ()
   (local (defun alpha-char-p-non-standard (x)
            (declare (ignore x))
            nil))
   (local (defun upper-case-p-non-standard (x)
            (declare (ignore x))
            nil))
   (local (defun lower-case-p-non-standard (x)
            (declare (ignore x))
            nil))
   (local (defun char-upcase-non-standard (x)
            (if (characterp x) x #\c)))
   (local (defun char-downcase-non-standard (x)
            (if (characterp x) x #\c)))
   (defthm booleanp-alpha-char-p-non-standard
     (booleanp (alpha-char-p-non-standard x))
     :rule-classes :type-prescription)
   (defthm booleanp-upper-case-p-non-standard
     (booleanp (upper-case-p-non-standard x))
     :rule-classes :type-prescription)
   (defthm booleanp-lower-case-p-non-standard
     (booleanp (lower-case-p-non-standard x))
     :rule-classes :type-prescription)
   (defthm characterp-char-upcase-non-standard
     (characterp (char-upcase-non-standard x))
     :rule-classes :type-prescription)
   (defthm characterp-char-downcase-non-standard
     (characterp (char-downcase-non-standard x))
     :rule-classes :type-prescription)
   (defthm upper-case-p-non-standard-implies-alpha-char-p-non-standard
     (implies (upper-case-p-non-standard x)
              (alpha-char-p-non-standard x))
     :rule-classes :forward-chaining)
   (defthm lower-case-p-non-standard-implies-alpha-char-p-non-standard
     (implies (lower-case-p-non-standard x)
              (alpha-char-p-non-standard x))
     :rule-classes :forward-chaining)
   (defthm alpha-char-p-non-standard-implies-characterp
     (implies (alpha-char-p-non-standard x)
              (characterp x))
     :rule-classes :forward-chaining)
   (defthm char-upcase-maps-non-standard-to-non-standard
; Supported by the "Checks on character case" in acl2-check.lisp.
     (implies (characterp x)
              (equal (standard-char-p (char-upcase-non-standard x))
                     (standard-char-p x))))
   (defthm char-downcase-maps-non-standard-to-non-standard
; Supported by the "Checks on character case" in acl2-check.lisp.
     (implies (characterp x)
              (equal (standard-char-p (char-downcase-non-standard x))
                     (standard-char-p x))))
   (defthm lower-case-p-non-standard-char-downcase-non-standard
     (implies (upper-case-p-non-standard x)
              (lower-case-p-non-standard (char-downcase-non-standard x))))
   (defthm upper-case-p-non-standard-char-upcase-non-standard
     (implies (lower-case-p-non-standard x)
              (upper-case-p-non-standard (char-upcase-non-standard x))))
   (defthm lower/upper-case-p-non-standard-disjointness
     (not (and (lower-case-p-non-standard x)
               (upper-case-p-non-standard x)))
     :rule-classes nil)
   (defthm char-upcase/downcase-non-standard-inverses
; Supported by the "Checks on character case" in acl2-check.lisp.
     (implies (characterp x)
              (and (implies (upper-case-p-non-standard x)
                            (equal (char-upcase-non-standard
                                    (char-downcase-non-standard x))
                                   x))
                   (implies (lower-case-p-non-standard x)
                            (equal (char-downcase-non-standard
                                    (char-upcase-non-standard x))
                                   x)))))))

#+acl2-loop-only
(defun alpha-char-p (x)
  (declare (xargs :guard (characterp x)))
  (cond
   ((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))
   (t (alpha-char-p-non-standard x))))

#+acl2-loop-only
(defun upper-case-p (x)
  (declare (xargs :guard (characterp x)))
  (cond
   ((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))
   (t (upper-case-p-non-standard x))))

#+acl2-loop-only
(defun lower-case-p (x)
  (declare (xargs :guard (characterp x)))
  (cond
   ((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))
   (t (lower-case-p-non-standard x))))

#+acl2-loop-only
(defun char-upcase (x)

; The guard characterp is required by p. 231 of CLtL.

  (declare (xargs :guard (characterp x)))
  (cond
   ((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))
            (t x))))
   (t (char-upcase-non-standard x))))

#+acl2-loop-only
(defun char-downcase (x)

; See comments in char-upcase.

  (declare (xargs :guard (characterp x)))
  (cond
   ((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))
            (t x))))
   (t (char-downcase-non-standard x))))

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

(defthm upper-case-p-forward-to-alpha-char-p
  (implies (upper-case-p x)
           (alpha-char-p x))
  :hints (("Goal" :in-theory (enable lower-case-p alpha-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)

(defthm lower-case-p-char-downcase
  (implies (upper-case-p x)
           (lower-case-p (char-downcase x)))
  :hints (("Goal"
           :in-theory (enable upper-case-p char-upcase char-downcase)
           :cases ((standard-char-p x)))))

(defthm upper-case-p-char-upcase
  (implies (lower-case-p x)
           (upper-case-p (char-upcase x)))
  :hints (("Goal"
           :in-theory (enable lower-case-p char-upcase char-downcase)
           :cases ((standard-char-p x)))))

(defun string-downcase1 (l)
  (declare (xargs :guard (character-listp l)))
  (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 (stringp x)))

; 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 (character-listp l)))
  (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 (stringp x)))
    (coerce (string-upcase1 (coerce x 'list)) 'string))

#+acl2-loop-only
(defun char-equal (x y)
  (declare (xargs :guard (and (characterp x)
                              (characterp y))))
  (eql (char-downcase x)
       (char-downcase y)))

(defun string-equal1 (str1 str2 i maximum)
  (declare (xargs :guard (and (stringp str1)
                              (stringp 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)
                              (stringp 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)
                              (string-listp lst))
                  :mode :program))
  (cond
   ((endp lst) nil)
   (t (or (string-equal str (car lst))
          (member-string-equal str (cdr lst))))))

(defun string-alistp (x)
  (declare (xargs :guard t))
  (cond
   ((atom x) (eq x nil))
   (t (and (consp (car x))
           (stringp (car (car x)))
           (string-alistp (cdr x))))))

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

(defun assoc-string-equal (str alist)
  (declare
   (xargs :guard (and (stringp str)
                      (string-alistp alist))
          :mode :program))
  (cond ((endp alist) nil)
        ((string-equal str (car (car alist)))
         (car alist))
        (t (assoc-string-equal str (cdr alist)))))

(encapsulate
  ()
  (local (defthm hack
           (implies (integerp i)
                    (equal (+ -1 1 i)
                           i))))

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

; The following rule has been here for a long time.  It is probably no longer
; needed for the build but we leave it since it's perhaps used in books.
(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 nth 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)

; We disable the following functions in order to protect people from getting
; burned by their explosive definitions.  In the case of print-base-p at least,
; an added benefit is to allow state-p1-forward to infer it.
(in-theory (disable alpha-char-p upper-case-p lower-case-p
                    char-upcase char-downcase print-base-p))

; ?? (v. 1.8) I'm not going to look at many, or any, of the skip-proofs
; events on this pass.

(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 (atom 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))
            ((characterp x) ; faster write as for strings; see comment above
             (write-char x stream)
             (when (eql x #\Newline)
               (force-output 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))))
           (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)

(defun w (state)
  (declare (xargs :guard (state-p state)

; The following comment explains how this definition was located here back when
; hons-enabledp was defined (before its elimination in August 2021, since after
; that it would always return t).

;   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
;   than 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 get-serialize-character (state)
  (declare (xargs :guard t))
  (f-get-global 'serialize-character state))

(defun set-serialize-character-fn (c system-p state)
  (declare (xargs :verify-guards nil ; originally waited for hons-enabledp
                  :guard (and (state-p state)
                              (or (null c)
                                  (member c '(#\Y #\Z))))))
  (let ((caller (if system-p
                    'serialize-character-system
                  'serialize-character)))
    (cond
     ((or (null c)
          (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$
       (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 ; originally waited for hons-enabledp
                  :guard (and (state-p state)
                              (or (null c)
                                  (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 ; originally waited for hons-enabledp
                  :guard (and (state-p state)
                              (or (null c)
                                  (member c '(#\Y #\Z))))))
  (set-serialize-character-fn c t state))

(defun print-object$+-alist (x)
  (declare (xargs :guard (keyword-value-listp x)))
  (cond ((endp x) nil)
        ((eq (car x) ':header)
         (print-object$+-alist (cddr x)))
        ((eq (car x) ':serialize-character)
         (print-object$+-alist (cddr x)))
        (t (let ((sym (car (rassoc-eq (intern$ (symbol-name (car x)) "ACL2")
                                      *raw-print-vars-alist*))))
             (prog2$
              (or sym
                  (hard-error 'print-object$+
                              "The symbol ~x0 is not a legal keyword for ~x1"
                              (list (cons #\0 (car x))
                                    (cons #\1 'print-object$+))))
              `(acons ',sym
                      ,(cadr x)
                      ,(print-object$+-alist (cddr x))))))))

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

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

(defun make-input-channel (file-name clock)
  (declare (xargs :guard (and (rationalp clock)
                              (stringp file-name))))
  (intern (coerce
           (append (coerce file-name 'list)
                   (cons '#\-
                         (explode-atom clock 10)))
           'string)
          "ACL2-INPUT-CHANNEL"))

(defun make-output-channel (file-name clock)
  (declare (xargs :guard (and (rationalp clock)
                              (or (eq file-name :string)
                                  (stringp file-name)))))
  (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 GCL, 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.

  (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
(defvar *read-file-into-string-alist*

; In this alist, each key is a filename (in the native OS, as discussed further
; below) whose value is a pair (str . pos), where: str is initially a character
; stream str for that file but may be replaced by nil; and pos is the position
; of the first character not read, except pos may be nil if the entire file was
; read.  The entry will be deleted (essentially, garbage collected) when the
; file-clock advances (see increment-file-clock), since at that point there is
; no restriction on using read-file-into-string on the given filename and no
; stream to re-use.

; NOTE: We do not define macros for the two fields, because we want to update
; them destructively using setf (and defining suitable setf expanders seems
; like overkill).  Instead we just use car and cdr for the str and pos
; components that are discussed above.

; We use this variable to protect our logical story on filenames.  Recall that
; (open-input-channels state) is logically an alist that is extended by
; function open-input-channel, by reading (readable-files state) --
; specifically, by looking up the key (list file-name typ (file-clock state)).
; Then (again, logically) read-char$ picks off characters from the suitable
; entry in that extended value of (open-input-channels state).  The concern
; here stems from the use of open-input-channel in
; read-file-into-string2-logical.  Suppose (file-clock state) is fc.  Then by
; using open-input-channel, read-file-into-string2-logical reads
; (open-input-channels state) at key (list file-name :character fc+1).  Two
; successive calls of read-file-into-string2-logical on file-name with the same
; state (hence same file-clock) should give the same result, but that won't
; happen if the file has changed inbetween the calls.  Note that the
; fundamental problem here is that read-file-into-string2-logical does not
; return state, so (file-clock state) remains unchanged after the call.  There
; can be a similar conflict between a call of read-file-into-string2-logical
; and a subsequent ordinary call of open-input-channel; see the call of
; check-against-read-file-into-string-alist in open-input-channel.  (The other
; way around, namely open-input-channel followed by
; read-file-into-string2-logical, isn't a concern, because when
; open-input-channel is called in read-file-into-string2-logical, that updates
; the file-clock.)  Note that a key in *read-file-into-string-alist* is based
; on fc, not fc+1.

; Recall that we key on the filename in the native OS.  It would also be fine
; to key on the Unix filename, but our code just developed this way.  It's fine
; though: if we encounter the same Unix filename twice, then of course we'd
; encounter the same OS filename twice, which would catch the problem we're
; trying to catch.

  nil)

#-acl2-loop-only
(declaim (inline increment-file-clock-raw))
#-acl2-loop-only
(defun increment-file-clock-raw ()
  (loop for pair in *read-file-into-string-alist*
        when (car (cdr pair)) ; stream
        do (close (car (cdr pair))))
  (setq *read-file-into-string-alist* nil)
  (incf *file-clock*))

(local
 (defthm state-p1-implies-ordered-symbol-alistp-open-input-channels
   (implies (state-p1 state-state)
            (ordered-symbol-alistp (car state-state)))
   :hints (("Goal" :expand ((NTH 0 STATE-STATE))
            :in-theory '(state-p1 open-input-channels open-channels-p zp)))))

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

(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

; 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*))
                 (pair (and (eq typ :character)
                            (assoc-equal os-file-name
                                         *read-file-into-string-alist*))))
            (when pair
              (let ((stream (car (cdr pair))))
                (when stream
                  (setf (car (cdr pair)) nil)
                  (close stream)))
              (error "An attempt to open an input channel to file ~s is ~
                      illegal~%because of a call of ~s on that file.~%Execute ~
                      ~s to avoid this error.~%See :DOC read-file-into-string."
                     file-name
                     'read-file-into-string.
                     '(increment-file-clock 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)

; We allow the :element-type to default to character in the following call of
; safe-open.  That may seem surprising when typ is :object.  But read-object
; calls read, and the CL HyperSpec doesn't impose any requirements on the
; stream when calling read.  So we prefer to leave :element-type as the
; default.

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

(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-raw)
            (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
                (remove1-assoc-eq channel (open-input-channels state-state))
                state-state)))
          state-state)))))

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

; We allow the :element-type to default to character in the following call of
; safe-open.  That may seem surprising when typ is :object.  But read-object
; calls read, and the CL HyperSpec doesn't impose any requirements on the
; stream when calling read.  So we prefer to leave :element-type as the
; default.

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

(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 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 (all-boundp alist1 alist2)
           (all-boundp alist1 (add-pair sym val alist2))))

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

(local
  (defthm state-p1-put-global
    (implies (and (state-p1 state)
                  (symbolp key)
                  (not (equal key 'current-acl2-world))
                  (not (equal key 'timer-alist))
                  (not (equal key 'print-base)))
             (state-p1 (put-global key value state)))
    :hints (("Goal" :do-not '(generalize eliminate-destructors)
             :in-theory (e/d (put-global state-p1)
                             (all-boundp true-listp))))))

(local
  (defthm open-channel-listp-add-pair
    (implies (and (open-channel1 value)
                  (open-channel-listp l))
             (open-channel-listp (add-pair key value l)))
    :hints (("Goal" :in-theory (e/d (add-pair) (open-channel1))))))

(local
  (defthm len-cons
    (equal (len (cons a b))
           (+ 1 (len b)))))

(local
  (defthm state-p1-mv-nth-1-open-output-channel
    (implies (and (stringp file-name) ; could allow :string
                  (member-eq typ *file-types*)
                  (state-p1 state-state))
             (state-p1 (mv-nth 1 (open-output-channel file-name
                                                      typ
                                                      state-state))))
    :hints (("Goal" :in-theory (e/d (state-p1 open-channels-p)
                                    (all-boundp
                                     len
                                     open-channel-listp
                                     true-listp
                                     ordered-symbol-alistp))))))

(defun open-output-channel! (file-name typ state)
  (declare (xargs :guard (and (stringp file-name)
                              (member-eq typ *file-types*)
                              (state-p state))
                  :guard-hints (("Goal" :in-theory (disable
                                                     open-output-channel
                                                     state-p
                                                     put-global
                                                     get-global)))))
  (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)
  `(prog2$ (or ,test
               (er hard? 'assert$?
                   "Assertion failed:~%~x0"
                   '(assert$? ,test ,form)))
           ,form))

(defmacro assert* (test form)
  `(and (mbt* ,test)
        ,form))

(defun comment-window-co ()

; This function provides an interface to *standard-co* that can be redefined
; with a trust tag, as in support of community book
; books/demos/brr-free-variables-book.lisp.

  (declare (xargs :guard t))
  *standard-co*)

#-acl2-loop-only
(defun fmt-to-comment-window-raw (str alist col evisc-tuple print-base-radix
                                      bangp inhibitp
                                      &aux (state *the-live-state*))

; This function is evaluated for side effect only.

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

  (cond
   ((and inhibitp
         (member-eq 'comment (f-get-global 'inhibit-output-lst state)))
    nil)
   ((null print-base-radix) ; common case
    (cond
     (bangp
      (fmt1! str alist col (comment-window-co) state evisc-tuple))
     (t
      (fmt1  str alist col (comment-window-co) state evisc-tuple))))
   (t
    (mv-let (new-print-base new-print-radix state)
      (cond ((consp print-base-radix)
             (mv (car print-base-radix)
                 (cdr print-base-radix)
                 state))
            (t (mv print-base-radix
                   (if (eql print-base-radix 10)
                       nil
                     t)
                   state)))
      (state-global-let*
       ((print-base (f-get-global 'print-base state))
        (print-radix new-print-radix))
       (pprogn
        (set-print-base new-print-base state)
        (mv-let (col state)
          (cond (bangp
                 (fmt1! str alist col (comment-window-co) state evisc-tuple))
                (t
                 (fmt1  str alist col (comment-window-co) state evisc-tuple)))
          (value col))))))))

(defun fmt-to-comment-window (str alist col evisc-tuple print-base-radix)
  (declare (xargs :guard t)
           #+acl2-loop-only
           (ignore str alist col evisc-tuple print-base-radix))
  #-acl2-loop-only
  (fmt-to-comment-window-raw str alist col evisc-tuple print-base-radix
                             nil t)
  nil)

(defun fmt-to-comment-window! (str alist col evisc-tuple print-base-radix)
  (declare (xargs :guard t)
           #+acl2-loop-only
           (ignore str alist col evisc-tuple print-base-radix))
  #-acl2-loop-only
  (fmt-to-comment-window-raw str alist col evisc-tuple print-base-radix
                             t t)
  nil)

(defun fmt-to-comment-window+ (str alist col evisc-tuple print-base-radix)
  (declare (xargs :guard t)
           #+acl2-loop-only
           (ignore str alist col evisc-tuple print-base-radix))
  #-acl2-loop-only
  (fmt-to-comment-window-raw str alist col evisc-tuple print-base-radix
                             nil nil)
  nil)

(defun fmt-to-comment-window!+ (str alist col evisc-tuple print-base-radix)
  (declare (xargs :guard t)
           #+acl2-loop-only
           (ignore str alist col evisc-tuple print-base-radix))
  #-acl2-loop-only
  (fmt-to-comment-window-raw str alist col evisc-tuple print-base-radix
                             t nil)
  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)

; 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 *base-10-chars* (list ,@args))
                          0 nil nil))

(defmacro cw! (str &rest args)
  `(fmt-to-comment-window! ,str
                           (pairlis2 *base-10-chars* (list ,@args))
                           0 nil nil))

(defmacro cw+ (str &rest args)
  `(fmt-to-comment-window+ ,str
                           (pairlis2 *base-10-chars* (list ,@args))
                           0 nil nil))

(defmacro cw!+ (str &rest args)
  `(fmt-to-comment-window!+ ,str
                            (pairlis2 *base-10-chars* (list ,@args))
                            0 nil nil))

(defmacro cw-print-base-radix (print-base-radix str &rest args)

; WARNING: Keep this in sync with cw.

  `(fmt-to-comment-window ,str
                          (pairlis2 *base-10-chars* (list ,@args))
                          0 nil
                          ,print-base-radix))

(defmacro cw-print-base-radix! (print-base-radix str &rest args)

; WARNING: Keep this in sync with cw.

  `(fmt-to-comment-window! ,str
                           (pairlis2 *base-10-chars* (list ,@args))
                           0 nil
                           ,print-base-radix))

(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 *output-lock*) ; Keep in sync with :DOC with-output-lock.
(deflock *local-state-lock*)

(local
  (defthm typed-io-listp-of-character
    (equal (typed-io-listp l ':character)
           (character-listp l))))

(local
  (defthm character-listp-cdr-when-open-channel1
    (implies (and (open-channel1 chan)
                  (equal (cadr (car chan)) ':character))
             (character-listp (cdr chan)))))

(local
  (defthm len-cdr-car-when-open-channel1
    (implies (open-channel1 chan)
             (equal (len (cdr (car chan)))
                    3))))

; We use defthm just above and in-theory just below, since it's too early in
; the boot-strap to use defthmd.
(local (in-theory (disable len-cdr-car-when-open-channel1)))

(local
  (defthm not-equal-string-nth-2-car-when-open-channel1
    (implies (open-channel1 chan)
             (not (equal (nth 2 (car chan)) :string)))))

; We use defthm just above and in-theory just below, since it's too early in
; the boot-strap to use defthmd.
(local (in-theory (disable not-equal-string-nth-2-car-when-open-channel1)))

(local
  (defthm open-channel1-cdr-assoc-equal-when-open-channels-p
    (implies (and (open-channels-p channels)
                  (assoc-equal channel channels))
             (open-channel1 (cdr (assoc-equal channel channels))))
    :hints (("Goal" :in-theory (e/d (open-channels-p) (open-channel1))))))

(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))
             :guard-hints
             (("Goal" :in-theory
               (enable len-cdr-car-when-open-channel1
                       not-equal-string-nth-2-car-when-open-channel1)))))
  #-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-raw)
            (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
                (remove1-assoc-eq channel (open-output-channels state-state))
                state-state)))
          state-state)))))

(defun maybe-finish-output$ (channel state)

; Allegro 6.0 needs explicit calls of finish-output in order to flush to
; standard output when *print-pretty* is nil.  SBCL 1.0 and 1.0.2 have
; exhibited this requirement during a redef query, for example:

; (defun foooooooooooooooooooooooooooo (x) x)
; :redef
; (defun foooooooooooooooooooooooooooo (x) (+ 1 x))

  (declare (xargs :guard (and (symbolp channel)
                              (state-p state)
                              (open-output-channel-any-p channel state)))
           (ignorable channel state))
  #+(and (not acl2-loop-only)
         (or sbcl allegro))
  (finish-output (get-output-stream-from-channel channel))
  nil)

#-acl2-loop-only
(defmacro legal-acl2-character-p (x)

; This predicate guarantees that two ACL2 characters with the same char-code
; are identical (eql).  In fact, a legal character is an 8-bit character that
; is ``canonical,'' in the sense that it's the character returned by code-char
; on its character code.

  (let ((ch (gensym)))
    `(let* ((,ch ,x)
            (code (char-code ,ch)))
       (and (integerp code)
            (<= 0 code)
            (< code 256)
            (eql (the character ,ch)
                 (the character (code-char code)))))))

(defun read-char$ (channel state-state)

; read-char$ differs from read-char in several ways.  It returns an
; mv-list of two values, the second being state.  There are no eof
; args.  Rather, nil is returned instead of character if there is no
; more input.

; Wart: We use state-state instead of state because of a bootstrap problem.

  (declare (xargs :guard (and (state-p1 state-state)
                              (symbolp channel)
                              (open-input-channel-p1
                               channel :character state-state))))
  #-acl2-loop-only
  (cond ((live-state-p state-state)
         (cond ((and *wormholep*
                     (not (eq channel *standard-ci*)))
                (wormhole-er 'read-char$ (list channel))))
         (return-from
          read-char$
          (let ((ch (read-char
                     (get-input-stream-from-channel channel) nil nil)))
            (cond ((and ch (not (legal-acl2-character-p ch)))
                   (interface-er "Illegal character read: ~x0 with code ~x1."
                                ch (char-code ch)))
                  (t (mv ch
                         *the-live-state*)))))))
  (let ((entry (cdr (assoc-eq channel (open-input-channels state-state)))))
    (mv (car (cdr entry))
        (update-open-input-channels
         (add-pair channel
                   (cons (car entry) (cdr (cdr entry)))
                   (open-input-channels state-state))
         state-state))))

(defun peek-char$ (channel state-state)

; Wart: We use state-state instead of state because of a bootstrap problem.

  (declare (xargs :guard (and (state-p1 state-state)
                              (symbolp channel)
                              (open-input-channel-p1
                               channel :character state-state))))

  #-acl2-loop-only
  (cond ((live-state-p state-state)
         (cond ((and *wormholep*
                     (not (eq channel *standard-ci*)))
                (wormhole-er 'peek-char$ (list channel))))
         (return-from
          peek-char$
          (let ((ch (peek-char nil (get-input-stream-from-channel channel)
                               nil nil)))
            (cond ((and ch (not (legal-acl2-character-p ch)))
                   (interface-er
                    "Illegal character peeked at: ~x0 with code ~x1."
                                 ch (char-code ch)))
                  (t ch))))))
  (let ((entry (cdr (assoc-eq channel (open-input-channels state-state)))))
    (car (cdr entry))))

(defun read-byte$ (channel state-state)

; read-byte$ differs from read-byte in several ways.  It returns an
; mv-list of two values, the second being state.  There are no eof
; args.  Rather, nil is returned instead if there is no more input.

; Wart: We use state-state instead of state because of a bootstrap problem.

  (declare (xargs :guard (and (state-p1 state-state)
                              (symbolp channel)
                              (open-input-channel-p1
                               channel :byte state-state))))
  #-acl2-loop-only
  (cond ((live-state-p state-state)
         (cond (*wormholep*
                (wormhole-er 'read-byte$ (list channel))))
         (return-from
          read-byte$
          (mv (read-byte (get-input-stream-from-channel channel) nil nil)
              *the-live-state*))))
  (let ((entry (cdr (assoc-eq channel (open-input-channels state-state)))))
    (mv (car (cdr entry))
        (update-open-input-channels
         (add-pair channel
                   (cons (car entry) (cdr (cdr entry)))
                   (open-input-channels state-state))
         state-state))))

#-acl2-loop-only
(defparameter *acl2-read-suppress* nil)

(defun raw-mode-p (state)
  (declare (xargs :guard t))
  (f-get-global 'acl2-raw-mode-p 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)))

; We thank Jared Davis for permission to adapt his function true-list-fix (and
; supporting function true-list-fix-exec), below.  See :DOC note-8-2 for
; further credits and explanation.

(defun true-list-fix-exec (x)
  (declare (xargs :guard t :mode :logic))
  (if (consp x)
      (cons (car x)
            (true-list-fix-exec (cdr x)))
    nil))

(defun true-list-fix (x)
  (declare (xargs :guard t
                  :mode :logic
                  :verify-guards nil))
  (mbe :logic
       (if (consp x)
           (cons (car x)
                 (true-list-fix (cdr x)))
         nil)
       :exec
       (if (true-listp x)
           x
         (true-list-fix-exec x))))

(defmacro fix-true-list (x) `(true-list-fix ,x))

(encapsulate
  ()

  (local (defthm true-list-fix-true-listp
           (implies (true-listp x)
                    (equal (true-list-fix x) x))
           :hints (("Goal" :expand ((true-list-fix x))))))

  (local (defthm true-list-fix-exec-removal
           (equal (true-list-fix-exec x)
                  (true-list-fix x))
           :hints(("Goal" :in-theory (enable true-list-fix)))))

  (verify-guards true-list-fix
    :hints (("Goal" :expand ((true-list-fix x)))))
  )

(in-theory (disable true-list-fix-exec))

(defthm pairlis$-true-list-fix
  (equal (pairlis$ x (true-list-fix y))
         (pairlis$ x y)))

(defthm state-p1-read-acl2-oracle
    (implies (state-p1 state)
             (state-p1 (mv-nth 2 (read-acl2-oracle state))))
  :hints (("Goal" :in-theory (enable state-p1 read-acl2-oracle))))

#-acl2-loop-only
(defvar *iprint-read-state*

; Possible values are:

; nil      - no requirement on current iprint index
; t        - either all indices must exceed iprint-last-index, or none does
; (n . <=) - n, already read, is <= iprint-last-index; index must be too
; (n .  >) - n, already read, is  > iprint-last-index; index must be too

; The value is initially nil.  At a top-level read, it is set to nil if
; iprint-fal is nil, else to t.  For the first index i that is read when the
; value is t, we set the value to <= if (<= i iprint-last-index) and to >
; otherwise.

  nil)

#-acl2-loop-only
(defun iprint-oracle-updates-raw (state)

; Warning: Keep in sync with iprint-oracle-updates.

; See the discussion of wormholes in the Essay on Iprinting.

  (let* ((ar *wormhole-iprint-ar*))
    (when ar
      (f-put-global 'iprint-ar (compress1 'iprint-ar ar) state)
      (f-put-global 'iprint-fal *wormhole-iprint-fal* state)
      (f-put-global 'iprint-hard-bound *wormhole-iprint-hard-bound* state)
      (f-put-global 'iprint-soft-bound *wormhole-iprint-soft-bound* state)
      (setq *wormhole-iprint-ar* nil))

; We are presumably not in the middle of a read, from the standpoint of
; reading, we are at the top level.  So it is fine to set *iprint-read-state*
; to t or nil.

    (setq *iprint-read-state*
          (if (f-get-global 'iprint-fal state)
              t
            nil)))
  state)

(defun iprint-last-index* (iprint-ar)
  (declare (xargs :guard (array1p 'iprint-ar iprint-ar)))
  (let ((x (aref1 'iprint-ar iprint-ar 0)))
    (if (consp x) ; iprinting is disabled
        (car x)
      x)))

(defun iprint-array-p (ar max)

; Ar is an iprint-array, hence an array1p.  This predicate checks that the
; non-zero keys are positive integers less than max until the header is
; reached.

  (declare (xargs :guard (and (alistp ar)
                              (posp max))))
  (cond ((or (endp ar)
             (eq (caar ar) :HEADER))
         t)
        ((eql (caar ar) 0)
         (iprint-array-p (cdr ar) max))
        (t (and (posp (caar ar))
                (< (caar ar) max)
                (iprint-array-p (cdr ar) max)))))

(defun iprint-falp (x)
  (declare (xargs :guard t))
  (cond ((atom x) (symbolp x))
        (t (and (consp (car x))
                (posp (cdar x))
                (iprint-falp (cdr x))))))

(encapsulate ()

; This is an ugly proof but it gets the job done quickly (when doing "make
; proofs").

(local
 (defthm state-p1-update-nth-2-add-pair-1
   (implies (and (state-p1 st1)
                 (state-p1 st2)
                 (symbolp sym1)
                 (not (member-eq sym1 '(timer-alist
                                        current-acl2-world
                                        print-base))))
            (state-p1 (update-nth 2
                                  (add-pair
                                   sym1 val1
                                   (nth 2 st1))
                                  st2)))
   :hints (("Goal" :in-theory (enable state-p1)))))

(local
 (defthm state-p1-update-nth-2-add-pair-2
   (implies (and (state-p1 st1)
                 (state-p1 st2)
                 (symbolp sym1)
                 (symbolp sym2)
                 (not (member-eq sym1 '(timer-alist
                                        print-base
                                        current-acl2-world)))
                 (not (member-eq sym2 '(timer-alist
                                        print-base
                                        current-acl2-world))))
            (state-p1 (update-nth 2
                                  (add-pair
                                   sym1 val1
                                   (add-pair
                                    sym2 val2
                                    (nth 2 st1)))
                                  st2)))
   :hints (("Goal" :in-theory (enable state-p1)))))

(local
 (defthm state-p1-update-nth-2-add-pair-3
   (implies (and (state-p1 st1)
                 (state-p1 st2)
                 (symbolp sym1)
                 (symbolp sym2)
                 (symbolp sym3)
                 (not (member-eq sym1 '(timer-alist
                                        print-base
                                        current-acl2-world)))
                 (not (member-eq sym2 '(timer-alist
                                        print-base
                                        current-acl2-world)))
                 (not (member-eq sym3 '(timer-alist
                                        print-base
                                        current-acl2-world))))
            (state-p1 (update-nth 2
                                  (add-pair
                                   sym1 val1
                                   (add-pair
                                    sym2 val2
                                    (add-pair
                                     sym3 val3
                                     (nth 2 st1))))
                                  st2)))
   :hints (("Goal" :in-theory (enable state-p1)))))

(local (in-theory (disable acl2-oracle read-acl2-oracle)))

(defun iprint-oracle-updates (state)

; Warning: Keep in sync with iprint-oracle-updates-raw.

; See the discussion of wormholes in the Essay on Iprinting.  Also see
; comments at the call of iprint-oracle-updates in read-object.

  (declare (xargs :stobjs state))
  #-acl2-loop-only
  (when (live-state-p state)
    (return-from iprint-oracle-updates
                 (iprint-oracle-updates-raw state)))
  (mv-let (erp val state)
    (read-acl2-oracle state)
    (declare (ignore erp))
    (let* ((val (true-list-fix val))
           (iprint-ar (nth 0 val))
           (iprint-hard-bound (1+ (nfix (nth 1 val))))
           (iprint-soft-bound (1+ (nfix (nth 2 val))))
           (iprint-fal (nth 3 val)))
      (cond
       ((and (array1p 'iprint-ar iprint-ar)
             (natp (iprint-last-index* iprint-ar))
             (iprint-array-p iprint-ar (1+ (iprint-last-index* iprint-ar)))
             (< iprint-hard-bound

; Quoting the Essay on Iprinting:
; "We maintain the invariant that the dimension of state global 'iprint-ar
; exceeds the hard bound."

                (car (dimensions 'iprint-ar iprint-ar)))
             (= (maximum-length 'iprint-ar iprint-ar)
                (* 4 (car (dimensions 'iprint-ar iprint-ar))))
             (<= (* 4 (1+ iprint-hard-bound))
; See init-iprint-ar; this is necessary for array1p to hold of the new array.
                 (array-maximum-length-bound))
             (iprint-falp iprint-fal)

; The following condition is probably not logically necessary.  However, it
; does actually hold, and it makes some proofs easier since compress1 is the
; identity for such arrays.

             (equal (array-order (header 'iprint-ar iprint-ar))
                    nil))
        (pprogn (f-put-global 'iprint-ar iprint-ar state)
                (f-put-global 'iprint-hard-bound iprint-hard-bound state)
                (f-put-global 'iprint-soft-bound iprint-soft-bound state)
                (f-put-global 'iprint-fal iprint-fal state)))
       (t 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 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))))

  (let ((state-state ; avoid pprogn here because of the use of state-state

; The following call of iprint-oracle-updates is necessary even with the calls
; of iprint-oracle-updates? in eviscerate-top and eviscerate-stobjs-top.  To
; see why, consider the following example.

;   (set-iprint t)
;   (monitor! 'nth t)
;   (thm (equal (nth n (cons x y)) z))
;   (fmx "~X01~%" (make-list 10) (evisc-tuple 3 4 nil nil))
;   (a!)
;   (quote #@1#)

; The fmx call is made in the brr wormhole, and it prints #@1#.  Without the
; following call of iprint-oracle-updates, the final form results in the error,
; "Out-of-bounds index in #@1#."

; The following example is perhaps even more persuasive of the need to call
; iprint-oracle-updates.

;   (set-iprint t)
;   (prog2$ (cw "~X01~|" (make-list 10) (evisc-tuple 2 3 nil nil))
;           (read-standard-oi state))

; The cw output is (NIL NIL NIL . #@1#), and then we are prompted for input.
; Input of #@1# will yield the expected object, (NIL NIL NIL NIL NIL NIL NIL);
; but what is the logical explanation?  Iprint-oracle-updates supplies logical
; updates to the iprint structures that explain the ability to read #@1#.

         #-acl2-loop-only
         (iprint-oracle-updates state-state)
         #+acl2-loop-only

; In the logic, iprint-oracle-updates takes state; but state is not a parameter
; here (see *super-defun-wart-table* and relevant comments).  Since we don't
; expect to execute the #+acl2-loop-only code, it seems appropriate to solve
; that problem by using non-exec here.

         (non-exec (iprint-oracle-updates 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*))
                   (stream (get-input-stream-from-channel channel))
                   (obj
                    (cond
                     #+(and mcl (not ccl))
                     ((eq channel *standard-oi*)
                      (ccl::toplevel-read))

; We formerly called a function hons-read here when (f-get-global 'hons-read-p
; *the-live-state*) was true (in ACL2 versions that supported hons).  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 ((consp (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 *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.

; We break this into an append of smaller lists, to avoid a GCL error reported
; by Camm Maguire related to call-arguments-limit.  In case this list is
; expanded later, we play it safe by breaking, initially, into sub-lists of
; length 50.

  (append
   (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))
   (list (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))
   (list (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 223) (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)))))

(local
  (defthm state-p1-update-open-output-channels
    (implies (state-p1 state)
             (equal (state-p1 (update-open-output-channels x state))
                    (open-channels-p x)))
    :hints (("Goal" :in-theory (e/d (state-p1)
                                    (open-channels-p all-boundp))))))

(local (in-theory (disable channel-headerp)))

(local
  (defthm open-channel1-of-cons
    (equal (open-channel1 (cons header vals))
           (and (channel-headerp header)
                (typed-io-listp vals (cadr header))))
    :hints (("Goal" :in-theory (enable channel-headerp)))))

(local
  (defthm channel-headerp-cadr-assoc-equal-when-open-channels-p
    (implies (and (open-channels-p channels)
                  (assoc-equal channel channels))
             (channel-headerp (cadr (assoc-equal channel channels))))
    :hints (("Goal" :in-theory (e/d (open-channels-p) (open-channel1))))))

(local
  (defthm open-channel-listp-nth-1
    (implies (state-p1 state)
             (open-channel-listp (nth 1 state)))
    :hints (("Goal" :in-theory (enable state-p1)))))

(local
  (defthm character-listp-expode-atom
    (character-listp (explode-atom x print-base))))

(local
  (defthm character-listp-expode-atom+
    (character-listp (explode-atom+ x print-base print-radix))
    :hints (("Goal" :in-theory (disable explode-atom)))))

(local
  (defthm state-p1-princ$
    (implies (and (atom x)
                  (state-p1 state-state)
                  (symbolp channel)
                  (open-output-channel-p1 channel
                                          :character state-state))
             (state-p1 (princ$ x channel state-state)))
    :hints (("Goal" :in-theory (e/d (open-channels-p open-channel-listp)
                                    (update-open-output-channels
                                     string-downcase explode-atom
                                     open-channel1))))))

(local
  (defthm open-output-channel-p1-princ$
    (implies (and (atom x)
                  (state-p1 state-state)
                  (symbolp channel)
                  (open-output-channel-p1 channel :character state-state))
             (open-output-channel-p1
               channel
               :character (princ$ x channel state-state)))
    :hints (("Goal" :in-theory (e/d (open-channel-listp)
                                    (string-downcase explode-atom
                                     open-channel1
                                     len))))))

(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))
                  :guard-hints (("Goal" :in-theory
                                 (disable princ$ open-output-channel-p1)))))
  (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)))))

(local
  (defthm state-p1-prin1-with-slashes1
    (implies (and (character-listp l)
                  (characterp slash-char)
                  (state-p state)
                  (symbolp channel)
                  (open-output-channel-p channel :character state))
             (state-p1 (prin1-with-slashes1 l slash-char channel state)))
    :hints (("Goal" :in-theory (disable update-open-output-channels
                                        princ$
                                        open-output-channel-p1)))))

(local
  (defthm open-output-channel-p1-prin1-with-slashes1
    (implies (and (character-listp l)
                  (characterp slash-char)
                  (state-p state)
                  (symbolp channel)
                  (open-output-channel-p channel :character state))
             (open-output-channel-p1 channel :character
                                     (prin1-with-slashes1 l
                                                          slash-char
                                                          channel
                                                          state)))
    :hints (("Goal" :in-theory (disable update-open-output-channels
                                        princ$
                                        open-output-channel-p1)))))

(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 all-dots (x i)
  (declare (type string x)
           (type (integer 0 *) i)
           (xargs :guard (<= i (length x))))
  (cond ((zp i) t)
        (t (let ((i (1- i)))
             (and (eql (char x i) #\.)
                  (all-dots x i))))))

(defun may-need-slashes-fn (x print-base)

; Quoting the CL HyperSpec, Section 2.3.4 Symbols as Tokens: "Any token that is
; not a potential number, does not contain a package marker, and does not
; consist entirely of dots will always be interpreted as a symbol."

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

  (or
   (all-dots x (length 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))))
  (and (or (f-get-global 'print-escape state)
           (f-get-global 'print-readably state))
       (may-need-slashes-fn x (print-base))))

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

(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-of-take
    (implies (and (character-listp x)
                  (<= n (length x)))
             (character-listp (take n x)))))

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

#-acl2-loop-only
(defun mswindows-drive (filename state)

; At one time this was admitted in the logic in program mode (without the
; readtime conditional #-acl2-loop-only).  But we changed that when replacing
; (os (w state)) by (get-os), as discussed below.

; We get the drive from filename if possible, else from cbd.

  (declare (xargs :mode :program))
  (or (and (eq (get-os)

; At one time we had (os (w state)) above instead of (get-os).  But we changed
; that when calling this function during the boot-strap, when (w state) was
; still nil.

               :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 the system books directory 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

; At one time the next argument was (os (w state)).  But we changed that when
; calling this function during the boot-strap, when (w state) was still nil.

           (get-os)))
      (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 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
(declaim (inline our-get-internal-run-time))

#-acl2-loop-only
(defun our-get-internal-run-time ()
  #-(and gcl (not gcl-2.7.0+))
  (get-internal-run-time)
  #+(and gcl (not gcl-2.7.0+))
  (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)))

#-acl2-loop-only
(defun get-internal-time ()
  (if (f-get-global 'get-internal-time-as-realtime *the-live-state*)
      (get-internal-real-time)
    (our-get-internal-run-time)))

(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-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 standard-evisc-tuplep (x)
  (declare (xargs :guard t))
  (or (null x)
      (and (true-listp x)
           (= (length x) 4)
           (alistp (car x))
           (or (null (cadr x))
               (integerp (cadr x)))
           (or (null (caddr x))
               (integerp (caddr x)))
           (symbol-listp (cadddr x)))))

(defun brr-evisc-tuple-oracle-update (state)
  (declare (xargs :guard (state-p state)))
  #-acl2-loop-only
  (when (live-state-p state)
    (return-from
     brr-evisc-tuple-oracle-update

; By binding *wormholep* to nil below we prevent the f-put-global from being
; undone when we exit the wormhole (if any) we're in when this assignment takes
; place.  That would be problematic except for the fact that brr-evisc-tuple is
; a ``true global'' (rather than a wormhole status ``local'' whose value is to
; be restored upon exit) and should always have the same value as its mirror.

     (let ((*wormholep* nil))
       (f-put-global 'brr-evisc-tuple *wormhole-brr-evisc-tuple* state))))
  (mv-let (erp val state)
    (read-acl2-oracle state)
    (declare (ignore erp))
    (f-put-global 'brr-evisc-tuple
                  (if (or (eq val :default)
                          (standard-evisc-tuplep val))
                      val
                      :default)
                  state)))

(verify-termination-boot-strap brr-evisc-tuple-oracle-update)

(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)
        #+lispworks
; Martin Simmons mentioned the following example in a 4/9/2024 email:
;   (setf (environment-variable "LANG") "en_US.UTF-8")
; An alternative is probably to use (hcl::setenv str val).
        (setf (lispworks::environment-variable str) val)
        #+(or gcl sbcl ccl)
        (let ((fn
               #+gcl       'si::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)))

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

(defthm all-boundp-initial-global-table-alt
  (implies (and (state-p1 state)
                (assoc-eq x *initial-global-table*))
           (boundp-global1 x state)))

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

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

(defun print-rational-as-decimal (x channel state)
  (declare (xargs :guard (and (rationalp x)
                              (symbolp channel)
                              (equal (print-base) 10)
                              (open-output-channel-p channel :character state))
                  :guard-hints
                  (("Goal" :in-theory (disable princ$
                                               open-output-channel-p1)))))
  (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)))))))

(defun print-timer (name channel state)
  (declare (xargs :guard (and (symbolp name)
                              (symbolp channel)
                              (open-output-channel-p channel :character state)
                              (equal (print-base) 10)
                              (consp (get-timer name state))
                              (rationalp (car (get-timer name state))))))
  (print-rational-as-decimal (car (get-timer name state)) channel state))

(defthm state-p1-update-print-base
  (implies (and (state-p1 state)
                (force (print-base-p val)))
           (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
                                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))
                  :guard-hints (("Goal" :in-theory (enable print-base-p)))))
  (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 (symbolp x)))
  #+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))))

(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 (atom x)
                              (symbolp channel)
                              (open-output-channel-p channel :character state))
                  :guard-hints
                  (("Goal" :in-theory (disable princ$
                                               open-output-channel-p1
                                               all-boundp
                                               needs-slashes)))))
  #-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))))
        ((symbolp x)
         (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)))))
        (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
              print-base-p
              known-package-alistp
              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))

; Note that f-put-global@par, with-live-state, and when-pass-2 are macros,
; hence are not in this list (but are defined using defmacro-untouchable).

  '(coerce-state-to-object
    coerce-object-to-state
    create-state
    user-stobj-alist

    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
    ev-for-trans-eval

    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 init-iprint-fal+
    set-brr-evisc-tuple1
    semi-initialize-brr-status

    untouchable-marker

    stobj-evisceration-alist ; returns bad object
    trace-evisceration-alist ; returns bad object

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

    apply-user-stobj-alist-or-kwote ; extra-logical EQ use; see its comments

; See the Essay on Memoization with Attachments for why
; doppelganger-apply$-userfn and doppelganger-badge-userfn are untouchable.

    doppelganger-apply$-userfn doppelganger-badge-userfn

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

    aset1-trusted ; version of aset1 without invariant-risk
    ))

(defconst *initial-untouchable-vars*
  '(temp-touchable-vars
    temp-touchable-fns

    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
    wormhole-status

    proof-tree
;   proof-tree-ctx  - used in community book books/cli-misc/expander.lisp

    fmt-soft-right-margin
    fmt-hard-right-margin

    inhibit-output-lst
;   inhibit-output-lst-stack ; see pop-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
    useless-runes
    standard-oi
    standard-co
    proofs-co
    trace-co
    ld-prompt
    ld-missing-input-ok
    ld-always-skip-top-level-locals
    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
    ld-level

    ld-history

    writes-okp
    program-fns-with-raw-code
    logic-fns-with-raw-code
    macros-with-raw-code
    dmrp
    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
    brr-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
    system-attachments-cache
    fast-cert-status
    inside-progn-fn1
    warnings-as-errors
    ))

; 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)
  (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 displayed 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)))
                              "")
                             ((null (cdr (package-entry-book-path entry)))
                              (msg "  This package was apparently defined ~
                                    locally by the portcullis of the ~
                                    book ~s0."
                                   (book-name-to-filename-1
                                    (car (package-entry-book-path entry))
                                    (project-dir-alist (w *the-live-state*))
                                    'bad-lisp-atomp)))
                             (t
                              (msg "  This package was apparently defined ~
                                    locally by the portcullis of the last in ~
                                    the following sequence of included books, ~
                                    where each book includes the next.~|~%  ~
                                    ~F0"
                                   (reverse
                                    (book-name-lst-to-filename-lst
                                     (package-entry-book-path entry)
                                     (project-dir-alist (w *the-live-state*))
                                     'bad-lisp-atomp)))))))))))
                (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))))
        ((typep x 'float)
         (cons "A floating-point input, which CLTL displays as ~s0, has been ~
                encountered.  To permit floating-point input, which ACL2 ~
                treats as a rational number, use the prefix #d or #D; see ~
                :DOC df)."
               (list (cons #\0 (format nil "~s" 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))
; The body below was originally
; (or (bad-lisp-objectp (car x))
;     (bad-lisp-objectp (cdr x))))
; but we have rewritten it to avoid an SBCL stack overflow in an example sent
; by Eric Smith to the acl2-help list on 12/17/2021.
  (loop for tail on x thereis (bad-lisp-objectp (car tail))
        finally (return (bad-lisp-atomp tail))))
)

#-acl2-loop-only
(defvar *bad-lisp-object-ok* nil)

#-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*
                 *bad-lisp-object-ok*

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

; 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.  At one
; time, the value returned in raw lisp by (mv x y ...) was x.  That changed
; when mv became values in raw Lisp, rather than using a special return
; mechanism in GCL.  But perhaps we can avoid boxing the fixnum x in GCL by
; suitable declarations and proclamations; we'll just keep the2s around for
; now.

(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 #.*fixnum-type* <body> 2)

; which expands to

; (MV-LET (X0 X1 STATE)
;         <body>
;         (MV (THE #.*FIXNUM-TYPE* X0) X1 STATE))

; A more flexible use is

; (the-mv (v stobj1 state w) #.*fixnum-type* <body>)

; which expands to

; (MV-LET (V STOBJ1 STATE W)
;         <body>
;         (MV (THE #.*FIXNUM-TYPE* 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 state-pos))
  (list 'the
        `(values ,type ,@(make-list (if (integerp vars)
                                        (1- vars)
                                      (length (cdr vars)))
                                    :initial-element t))
        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"
                               (list (cons #\0 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"
                               (list (cons #\0 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)))

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

; This function is no longer used in the sources or community books after March
; 2024.  However, it has long been in *acl2-exports*, so we leave it here.

  (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 get-non-unary-function-symbol (lst wrld)

; See unary-function-symbol-listp for comments on the coding style here, which
; follows that coding style.

; The idea is to return the first member x of lst that is not a known unary
; function symbol of wrld.  However, x might be nil, which is the same result
; when there is no such x.  So we return (mv flg x) where flg is t if x is such
; a member and flg is nil if there is no such x.

  (declare (xargs :guard (and (true-listp lst)
                              (plist-worldp wrld))))
  (cond ((endp lst) (mv nil nil))
        ((and (symbolp (car lst))
              (let ((formals (getpropc (car lst) 'formals nil wrld)))
                (and (consp formals)
                     (null (cdr formals)))))
         (get-non-unary-function-symbol (cdr lst) wrld))
        (t (mv t (car lst)))))

(defun invisible-fns-entryp (key val wrld)
  (declare (xargs :guard (plist-worldp wrld)))
  (and (symbolp key)
       (function-symbolp key wrld)
       (true-listp val)
       (mv-let (flg x)
         (get-non-unary-function-symbol val wrld)
         (declare (ignore x))
         (null flg))))

(set-table-guard invisible-fns-table
                 (invisible-fns-entryp key val world)
                 :show t
                 :coda (msg "Note that the test for ~x0 has failed because ~
                             ~#1~[~x2 is not a symbol~/~x2 is not a known ~
                             function symbol~/~x3 does not satisfy ~x4~/~x5 ~
                             is not a known unary function symbol~]."
                            'invisible-fns-entryp
                            (cond ((not (symbolp key)) 0)
                                  ((not (function-symbolp key world)) 1)
                                  ((not (true-listp val)) 2)
                                  (t 3))
                            key
                            val
                            'true-listp
                            (mv-let (flg x)
                              (get-non-unary-function-symbol val world)
                              (assert$ flg x))))

(set-invisible-fns-table t)

(defmacro add-invisible-fns (top-fn &rest unary-fns)

; See call of (set-guard-msg add-invisible-fns ...) later in the sources.

  (declare (xargs :guard (and (symbolp top-fn)
                              (symbol-listp 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)
              tbl))
          :clear))

(defmacro remove-invisible-fns (top-fn &rest unary-fns)

; See call of (set-guard-msg remove-invisible-fns ...) later in the sources.

  (declare (xargs :guard (and (symbolp top-fn)
                              (symbol-listp 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)
                    (remove1-assoc-eq top-fn tbl)))
              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)

(set-table-guard inhibit-warnings-table
                 (stringp key)
                 :topic set-inhibit-warnings)

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

(defun remove1-assoc-string-equal (key alist)
  (declare (xargs :guard (and (stringp key)
                              (string-alistp alist))))
  (cond ((endp alist) nil)
        ((string-equal key (caar alist)) (cdr alist))
        (t (cons (car alist)
                 (remove1-assoc-string-equal key (cdr alist))))))

(defmacro toggle-inhibit-warning! (str)
  `(table inhibit-warnings-table
          nil
          (let ((inhibited-warnings
                 (table-alist 'inhibit-warnings-table world)))
            (cond ((assoc-string-equal ',str inhibited-warnings)
                   (remove1-assoc-string-equal ',str inhibited-warnings))
                  (t (acons ',str nil inhibited-warnings))))
          :clear))

(defmacro toggle-inhibit-warning (str)
  `(local (toggle-inhibit-warning! ,str)))

#-acl2-loop-only
(defmacro set-inhibit-er! (&rest x)
  (declare (ignore x))
  nil)

(set-table-guard inhibit-ero-table
                 (stringp key)
                 :topic set-inhibit-er)

#+acl2-loop-only
(defmacro set-inhibit-er! (&rest lst)
  (declare (xargs :guard (string-listp lst)))
  `(with-output
     :off (event summary)
     (progn (table inhibit-er-table nil ',(pairlis$ lst nil) :clear)
            (value-triple ',lst))))

(defmacro set-inhibit-er (&rest lst)
  `(local (set-inhibit-er! ,@lst)))

(defmacro toggle-inhibit-er! (str)
  `(table inhibit-er-table
          nil
          (let ((inhibited-er-soft
                 (table-alist 'inhibit-er-table world)))
            (cond ((assoc-string-equal ',str inhibited-er-soft)
                   (remove1-assoc-string-equal ',str inhibited-er-soft))
                  (t (acons ',str nil inhibited-er-soft))))
          :clear))

(defmacro toggle-inhibit-er (str)
  `(local (toggle-inhibit-er! ,str)))

(defun chk-inhibited-summary-types (caller lst)
  (declare (xargs :guard t))
  (cond ((not (true-listp lst))
         (msg
          "The argument to ~x0 must evaluate to a true-listp, unlike ~x1."
          caller lst))
        ((not (subsetp-eq lst *summary-types*))
         (msg
          "The argument to ~x0 must evaluate to a subset of the list ~X12, ~
           but ~x3 contains ~&4."
          caller
          *summary-types*
          nil
          lst
          (set-difference-eq lst *summary-types*)))
        (t nil)))

(defun set-inhibited-summary-types-state (lst state)

; We could consider using defun-for-state to define this function, but then it
; couldn't be in :logic mode because of the call (er soft ...) in
; set-inhibited-summary-types.  Perhaps though it isn't important for this
; function symbol to be in :logic mode.

  (declare (xargs :stobjs state))
  (let ((msg
         (chk-inhibited-summary-types 'set-inhibited-summary-types-state lst)))
    (cond (msg (prog2$ (er hard? 'set-inhibited-summary-types "~@0" msg)
                       state))
          (t (f-put-global 'inhibited-summary-types lst state)))))

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

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

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

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

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

#+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 :idates '?)
        (list :acl2-oracle '?)
        (list :file-clock *file-clock*)
        (list :readable-files '?)
        (list :written-files '?)
        (list :read-files '?)
        (list :writeable-files '?)))

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

(set-table-guard macro-aliases-table
                 (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))
       :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 fix-true-list true-list-fix)
(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 remove1-assoc-eq remove1-assoc-equal)
(add-macro-alias remove1-assoc remove1-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)

; The following, pertaining to delete-assoc, may be deprecated:
(defmacro delete-assoc-eq-exec (key alist)
  `(remove1-assoc-eq-exec ,key ,alist))
(add-macro-alias delete-assoc-eq-exec remove1-assoc-eq-exec)
(defmacro delete-assoc-eql-exec (key alist)
  `(remove1-assoc-eql-exec ,key ,alist))
(add-macro-alias delete-assoc-eql-exec remove1-assoc-eql-exec)
(defmacro delete-assoc-equal (key alist)
  `(remove1-assoc-equal ,key ,alist))
(add-macro-alias delete-assoc-equal remove1-assoc-equal)
(defmacro delete-assoc-eq (key alist)
  `(remove1-assoc-eq ,key ,alist))
(defmacro delete-assoc (key alist)
  `(remove1-assoc ,key ,alist))

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

(set-table-guard nth-aliases-table
                 (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)
                (remove1-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 &key at-end)
  (declare (ignore lst at-end))
  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-dwp (dwp)
  `(local (set-dwp! ,dwp)))

#+acl2-loop-only
(defmacro set-dwp! (dwp)
  `(with-output
     :off (event summary)
     (progn (table dwp-table t ,dwp)
            (table dwp-table t))))

#-acl2-loop-only
(defmacro set-dwp! (dwp)
  (declare (ignore dwp))
  nil)

(defun get-dwp (dwp wrld)
  (declare (xargs :guard (and (plist-worldp wrld)
                              (alistp (table-alist 'dwp-table wrld)))))
  (cond ((eq dwp t) t)
        (t (if (cdr (assoc-eq t (table-alist 'dwp-table wrld)))
               t
             dwp))))

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

(set-table-guard rw-cache-state-table
                 (case key
                   ((t) (member-eq val *legal-rw-cache-states*))
                   (t nil))
                 :topic set-rw-cache-state)

(set-table-guard induction-depth-limit-table
                 (and (eq key t)
                      (or (null val) ; no limit
                          (natp val)))
                 :topic set-induction-depth-limit)

(defconst *induction-depth-limit-default*

; By default, abort if we attempt to induction past 9 levels.  If this constant
; is changed, then change :doc induction-depth-limit.

  9)

(table induction-depth-limit-table t *induction-depth-limit-default*)

#-acl2-loop-only
(defmacro set-induction-depth-limit! (x)
  (declare (ignore x))
  nil)

#+acl2-loop-only
(defmacro set-induction-depth-limit! (val)
  `(with-output
     :off (event summary)
     (progn (table induction-depth-limit-table t ,val)
            (table induction-depth-limit-table t))))

(defmacro set-induction-depth-limit (val)
  `(local (set-induction-depth-limit! ,val)))

; 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)
           *null-char*))
  :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)
                  *null-char*))
  :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)))

(encapsulate
  ()
  (logic)
  (verify-termination-boot-strap make-character-list))

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

;; 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
                  :mode :logic))
  (and (acl2-numberp x)
       (equal (standard-part x) 0)))

(defun i-close (x y)
  (declare (xargs :guard t
                  :mode :logic))
  (and (acl2-numberp x)
       (acl2-numberp y)
       (i-small (- x y))))

(defun i-large (x)
  (declare (xargs :guard t
                  :mode :logic))
  (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 "Time-limit" 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 "Time-limit" 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 for the prover.  But it's a
; cheap test so we include it, for example in case 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)

; As noted in comments above the definition of *acl2-time-limit*, that variable
; is set to 0 to indicate that a proof has been interrupted (see our-abort).
; We check for *interrupt-string* in waterfall-step to record whether the error
; is due to an interrupt or to reaching a time-limit.

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

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

(defun p! ()

; From the perspective of ld, (p!) pops up one level.  But if p! is executed
; inside a brr wormhole break, it just prints a comment message and execution
; stays in the brr wormhole.

; Once upon a time we allowed (indeed, documented and thus encouraged) the use
; of :p! to ``pop up a level'' in brr.  But that was a crock.  If you're
; several levels down in the ``break-rewrite'' abstraction and you throw :pop
; to 'local-top-level (as we were doing) you don't necessary get back to the
; previous break-rewrite level (depth).  Nor does it even stop the prover from
; running on.  For example, suppose you're in the interactive loop of brkpt1 at
; depth 2 about to try some lemma, say BAD.  If you type :p!, thinking you'll
; pop up to whatever the rewriter was doing at depth 1, you'd be wrong.  The
; (old) :p! would throw :pop and the system would exit from brkpt1, the
; rewriter would proceed, and you'd enter brkpt2, at depth 2.  Essentially,
; that version of :p! was equivalent to :ok or :go, modulo printing.

  (declare (xargs :guard t))
  #-acl2-loop-only
  (if (eq (f-get-global 'wormhole-name *the-live-state*) 'brr)
      (cw "~%The p! command is a no-op when you're in the break-rewrite ~
           wormhole.  Exit with :a! or one of the :ok or :go commands of ~
           :doc brr-commands.~%~%")
      (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)))

; The following raw Lisp alist pairs each wormhole name with its
; persistent-whs.

#-acl2-loop-only
(defparameter *wormhole-status-alist* nil)

#-acl2-loop-only
(defparameter *inhibit-wormhole-activityp* nil)

(defmacro bind-acl2-time-limit (form)

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

  #-acl2-loop-only
  `(if *acl2-time-limit-boundp*
       ,form
     (let ((*acl2-time-limit-boundp* t)
           (*acl2-time-limit* *acl2-time-limit*))
       ,form))
  #+acl2-loop-only
  form)

(defmacro our-with-terminal-input (x)

; The comments below were developed with David Rager.

; This identity macro was intended to have the side effect of permitting a
; thread to read from the terminal when another thread already has the lock on
; that.  However, that didn't work out, so it is now truly the identity macro,
; without side effect.

; Consider this CCL page:

; https://ccl.clozure.com/manual/chapter7.5.html#Background-Terminal-Input

; That page notes in particular:

;   This scheme is certainly not bulletproof: imaginative use of
;   PROCESS-INTERRUPT and similar functions might be able to defeat it and
;   deadlock the lisp, and any scenario where several background processes are
;   clamoring for access to the shared terminal input stream at the same time
;   is likely to be confusing and chaotic.

; Perhaps our use of PROCESS-INTERRUPT and THROW to abort subgoal proofs
; qualifies as "imaginative use"; if not, then we may have exposed a heretofore
; unknown CCL bug.  Specifically, if we define this macro to call
; ccl::with-terminal-input, then we reliably see a hang when attempting to
; certify community book books/std/osets/under-set-equiv.lisp.  When we look at
; backtraces, we see that the main thread is waiting either for a future to
; finish or for the wormhole lock, while the worker thread (which we have seen
; can be holding the wormhole lock) is waiting on *terminal-io*.  Rager
; believes that wormhole locks are managed correctly, and the problem is likely
; that some other worker thread is still holding onto the *terminal-io*
; resource.  Consider this recursive lock wait for the worker thread.

; (7FA42D62C318) : 8 (%ACQUIRE-SHARED-RESOURCE #S(CCL::SHARED-RESOURCE :NAME
; "Shared Terminal Input" :LOCK #<RECURSIVE-LOCK [ptr @ #x18FB2C0]
; #x30200437983D> ...) T) 1421

; Rager believes that the underlying CCL issue is present even without the use
; of ccl::with-terminal-input; its use simply slows down execution sufficiently
; to make a hang much more likely.

; If we ever restore the use of ccl::with-terminal-input, then beware that
; other threads that need the *terminal-io* resource will be blocked until the
; caller of our-with-terminal-input completes.

; But for now, we simply make this the identity macro, in case clearer thinking
; on our part or CCL improvements provide a suitable way to invoke
; ccl::with-terminal-input.

; #+(and ccl acl2-par (not acl2-loop-only))
; `(ccl::with-terminal-input ,x)
; #-(and ccl acl2-par (not acl2-loop-only))

  x)

; When the wormhole cleanup form constructed by wormhole1 is evaluated as we
; come out of the wormhole, the following special tells us whether we're
; aborting to the top-level or just exiting politely.

#-acl2-loop-only
(defvar wormhole-cleanup-abort-flg)

(defun wormhole1 (name input form ld-specials)

; Warning: Keep this function in sync with the other functions listed in the
; Essay on the Wormhole Implementation Nexus in axioms.lisp.

; 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
  (our-with-terminal-input
   (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)))

; The form constructed below will be destructively augmented as wormhole
; interactions occur, by splicing new undo forms in where indicated below.
; Then it will be evaluated, either at location [a] or [b] below upon exit from
; this wormhole.  The cond immediately below is always the first of the forms
; to be executed upon exit.

; This is the value of the *wormhole-cleanup-form*, and will be maintained in
; the form (PROGN save-ephemeral-whs form1 ... formk safety-set STATE) even as
; execution from within the coming LD will destructively insert new formi
; immediately after the save-ephemeral-whs form.

              (list 'progn
                    `(cond ((car (quote ,own-cons))
                            (error "Attempt to execute ~
                                    *wormhole-cleanup-form* twice!"))
                           (t (setq *wormhole-status-alist*
                                    (put-assoc-equal
                                     ',name
                                     (if (and wormhole-cleanup-abort-flg
                                              (eq ',name 'brr))

; Note that for all wormholes except brr, when a wormhole is aborted, we
; immediately move the current ephemeral-whs, (f-get-global 'wormhole-status
; state), into the persistent-whs (i.e., *wormhole-status-alist*).  But for brr
; we do something quite brr-specific.  The brr-status is really a stack of
; statuses and we chase down the :brr-previous-status chain to find the status
; of the wormhole when we first entered break-rewrite from the top-level, and
; we store that original status into the persistent-whs.

                                         (top-level-brr-status
                                          (f-get-global 'wormhole-status
                                                        *the-live-state*))
                                         (f-get-global 'wormhole-status
                                                       *the-live-state*))
                                         *wormhole-status-alist*))))

;                  --- new undo forms will be spliced here ---
;                  <most recent undo form>
;                  ...
;                  <oldest undo form>
;                  --- builtin final undo forms ---

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

; [a] cleanup on behalf of an abort
                       (let ((acl-non-special-var
                              `(let ((wormhole-cleanup-abort-flg t))
                                 ,*wormhole-cleanup-form*)))
                         (function
                          (lambda nil (eval acl-non-special-var)))))
                 *acl2-unwind-protect-stack*
                 'wormhole1)

; The f-put-globals about to be performed will be done undoably.

       (f-put-global 'wormhole-name name state)
       (f-put-global 'wormhole-input input state)
       (f-put-global 'wormhole-status
                     (cdr (assoc-equal name *wormhole-status-alist*))
                     state)
       (ld-fn (append
               `((standard-oi . (,form . ,*standard-oi*))
                 (standard-co . ,(comment-window-co))
                 (proofs-co . ,(comment-window-co)))
               ld-specials)
              state
              t)

; [b] cleaning up after polite, normal exit.

       (eval
        `(let ((wormhole-cleanup-abort-flg nil))
           ,*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 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 using
;    a partial-encapsulate, 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!

; The form was obtained by
; (getpropc '|Access REWRITE-CONSTANT record field CURRENT-CLAUSE|
;           'macro-body nil (w state))
; after a redef+ and execution of the new defrec rewrite-constant!

  (CONS 'LET
        (CONS (CONS (CONS 'CURRENT-CLAUSE
                          (CONS CURRENT-CLAUSE 'NIL))
                    'NIL)
              (CONS '(CDR (CAR (CDR (CDR (CDR CURRENT-CLAUSE)))))
                    'NIL))))

(defun record-error (name rec)
  (declare (xargs :guard t :mode :logic))
  (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 3 (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
                  :mode :logic))
  (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))))

; User-level control of rewrite-lambda-object is determined by the
; enabled status of two runes, which we'll abbreviate in this
; discussion by e and d:

; e    (:executable-counterpart rewrite-lambda-modep)
; d    (:definition rewrite-lambda-modep)

; if e is enabled and d is enabled:
;    then rewrite-lambda-object does a a recursive rewrite
;    of the body.

; if e is enabled, but d is disabled,
;    then rewrite-lambda-object just does syntactic cleaning
;    of the body.

; If e is disabled,
;    then rewrite-lambda-object is a no-op.

; These three options could be switched on and off via local
; :in-theory hints:

; Recursive rewriting:
; (e/d ((:e rewrite-lambda-modep) (:d rewrite-lambda-modep)) nil)

; Syntactic cleaning:
; (e/d ((:e rewrite-lambda-modep)) ((:d rewrite-lambda-modep)))

; Hands off:
; (e/d () ((:e rewrite-lambda-modep)))

; If the only theory adjustments you want to make are to these two
; runes, i.e., you don't want to also enable or disable other runes in that
; in-theory event or :in-theory hint, you can use these three macros.

(defmacro rewrite-lambda-objects-theory ()
  '(e/d ((:e rewrite-lambda-modep) (:d rewrite-lambda-modep)) nil))

(defmacro syntactically-clean-lambda-objects-theory ()
  '(e/d ((:e rewrite-lambda-modep)) ((:d rewrite-lambda-modep))))

(defmacro hands-off-lambda-objects-theory ()
  '(e/d () ((:e rewrite-lambda-modep))))

; as in

; :hints (("Subgoal 3.5"
;          :in-theory (syntactically-clean-lambda-objects-theory)))

; End of discussion of user-level control of rewrite-lambda-object.

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

; The following must be in :logic mode for badged-fns-of-world.
 (verify-termination-boot-strap plist-worldp)
 (verify-termination-boot-strap fgetprop)
 (verify-termination-boot-strap sgetprop)
 (verify-termination-boot-strap function-symbolp)
 (verify-termination-boot-strap all-function-symbolps)
 (verify-termination-boot-strap strip-cars)
 (verify-termination-boot-strap assoc-eq-exec$guard-check)
 (verify-termination-boot-strap assoc-eq-exec)
 (verify-termination-boot-strap table-alist)

 )

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

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

(set-table-guard evisc-table
                 (and (not (null key)) ; We don't want to abbreviate nil.
                      (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
; ensure 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)))

(set-table-guard custom-keywords-table

; 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))
                 :topic add-custom-keyword-hint)

#+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)
                (remove1-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))
              t)
             ((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-of-take
    (implies (and (standard-char-listp x)
                  (<= n (len x)))
             (standard-char-listp (take n x)))
    :hints (("Goal" :in-theory (enable standard-char-listp)))))

 (local
  (defthm character-listp-of-take
    (implies (and (character-listp x)
                  (<= n (len x)))
             (character-listp (take n x)))))

 (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-of-take
    (equal (len (take n lst))
           (nfix n))))

 (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 pass of the build:
(verify-termination-boot-strap cpu-core-count)
(verify-termination-boot-strap get-in-theory-redundant-okp)
(verify-termination-boot-strap dumb-occur-var)
(verify-termination-boot-strap trivial-lambda-p)

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

; Warning: Keep this in sync with the generation of time$ calls by untranslate1.

  (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)
                #+lispworks (hcl:total-allocation)
                #-(or ccl sbcl lispworks)
                (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 lispworks)
        (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.

         (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
                        #+gcl-2.7.0+
                        (si::get-internal-run-times)
                        #-gcl-2.7.0+
                        (get-internal-run-time)))
                #+(or ccl sbcl lispworks)
                (,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
                              #+gcl-2.7.0+
                              (si::get-internal-run-times)
                              #-gcl-2.7.0+
                              (get-internal-run-time)))
                      (end-real-time (get-internal-real-time))
                      #+(or ccl sbcl lispworks) ; 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 lispworks)
                              (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 lispworks)
                                              (format nil "~:D" allocated)
                                              #-(or ccl sbcl lispworks)
                                              "[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 lispworks)
                                      "; ~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 sbcl lispworks 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*)
                       nil)))))))))))))

(encapsulate
 ()

 (local
  (defthm true-listp-revappend
    (equal (true-listp (revappend x y))
           (true-listp y))))

 (verify-guards defun-nx-form)
 (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-persistent-whs (name state)
   #+acl2-loop-only
   (declare (xargs :guard (state-p state))
            (ignore name))
   #-acl2-loop-only
   (when (live-state-p state)
     (return-from get-persistent-whs
                  (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$.

  (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)
          (declare (ignore val))
          (mv (null erp)
              state)))

; Next: debugger control

(defun debugger-enable (state)
  (declare (xargs :guard t))
  (f-get-global 'debugger-enable state))

#-acl2-loop-only
(defun break$-raw ()

; See break$.

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

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

  (declare (xargs :guard t))
  #-acl2-loop-only
  (if *wormholep*

; In a wormhole, we need to abort to the top level.  The reason is complicated,
; but the bottom line is that it has to do with otherwise being left in an
; incoherent wormhole state by brkpt1, brkpt2, etc.

      (let ((finished nil))
        (unwind-protect (progn (break$-raw)
                               (setq finished t))
          (when (not finished)
            (format t "~%Aborting to top level from a wormhole break (see ~
                       :DOC wormhole).~%~%")
            (abort!))))
    (break$-raw))
  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 (&aux (state *the-live-state*))

; 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 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 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~%"
              (book-name-to-filename (access certify-book-info
                                             (f-get-global 'certify-book-info
                                                           state)
                                             :full-book-name)
                                     (w state)
                                     'print-call-history))))
  #+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 t))
  (debugger-enabledp-val (f-get-global 'debugger-enable state)))

(defun maybe-print-call-history (state)
  (declare (xargs :guard t))
  (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
                    (e/d (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
                          print-base-p
                          known-package-alistp
                          file-clock-p
                          readable-files-p
                          written-files-p
                          read-files-p
                          writeable-files-p))))))
  #+(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
     er-soft
     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-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
     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$0-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*

; Each cdr is either nil or a msg.  These should all be function symbols in any
; ACL2 world (after the boot-strap is complete).  The macro progn! is
; "spiritually" in this list but is handled separately in translate11.

  `((hons-wash!)
    (hons-clear!)
    (open-output-channel!)
    (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))))
  (or (eq fn 'cons) ; optimization
      (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*

; Warning: If you add to the list below, then modify term-stobjs-out
; accordingly.

  '(if return-last do$ read-user-stobj-alist))

(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 all-nils-or-dfs (lst)
  (declare (xargs :guard (true-listp lst)))
  (cond ((endp lst) t)
        (t (and (or (eq (car lst) nil)
                    (eq (car lst) :df))
                (all-nils-or-dfs (cdr lst))))))

(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 functions symbols in
; *stobjs-out-invalid*.  (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 (eq fn 'do$))
       (not (eq fn 'read-user-stobj-alist))
       (not (assoc-eq fn *ttag-fns*))
       (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-or-dfs 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
        tag))
   ((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*

; Essay on Illegal-states

; An illegal state is one in which ld-pre-eval-filter is :illegal-state; see
; illegal-state-p.  Such a state is entered and exited as explained below.  For
; additional background information see :DOC illegal-state.  Below we start
; with a few orienting remarks, and then we summarize how we manage illegal
; states.

; An abstract stobj export or stobj-let form may update its stobj
; non-atomically, in which case an incomplete update may result in a state
; where that abstract stobj does not satisfy its recognizer.  (See the
; discussion of :protect in :DOC defabsstobj.)  The resulting illegal state is
; marked by ACL2 as an illegal-state, from which continuing is at one's own
; risk.  Moreover, ACL2 requires the user to submit the form,
; (continue-from-illegal-state), before LD will accept further input.

; If an execution is incomplete, there was presumably an error or a call of
; throw that took us out of the execution.  Because we extend the content of
; *inside-absstobj-update* on entry to a non-interruptible abstract stobj
; update (by adding 1 or pushing onto a stack) and revert only on exit, a
; record of that interruption will persist until we clear it.  A key idea is
; that we only transition to an illegal state near the end of book
; certification, to prevent a bogus certificate from being written, and when
; returning control to LD, which allows error messages (for example, from guard
; violations and step-limit violations) to be printed first.

; All that said, here is a more complete and organized summary of how illegal
; states are managed.

; (a) When entering a non-interruptable abstract stobj update, the content of
;     *inside-absstobj-update* is updated correspondingly: either incremented
;     if a natural number, or else pushed onto the stack in the case that
;     set-absstobj-debug has activated debugging.  The value is restored on
;     exit.

; (b) Whenever ACL2 code exits a non-interruptable abstract stobj update before
;     completion, the content of *inside-absstobj-update* will reflect the
;     in-progress status until cleared; chk-absstobj-invariants will notice
;     that status when control is returned to LD.  At that time we can abort to
;     the top level, using (abort!), just to keep things sane.  Note that this
;     evaluation of (abort!) will take us out of any wormhole and avoid
;     re-entry to the proof-builder (see the calls of illegal-state-p in
;     pc-main-loop).

; (c) Ld-read-eval-print runs chk-absstobj-invariants to check whether
;     *inside-absstobj-update* shows that a non-interruptable abstract stobj
;     update didn't complete.  If we are not already at the top level, we will
;     abort to the top level (with (abort!), as mentioned above).  Otherwise
;     ld-pre-eval-filter will be set to :illegal-state and a message will print
;     a failure, with *inside-absstobj-update* cleared out.  Note that
;     ld-pre-eval-filter remains at :illegal-state when popping to lower ld
;     levels; see f-put-ld-specials.

; (d) With ld-pre-eval-filter = :illegal-state, only one input will be
;     accepted: (continue-from-illegal-state).  When that happens,
;     ld-pre-eval-filter will be set to :all (even if a query or REBUILD was
;     aborted).

  (vector

; Warning: Do not use #(0) here in place of (vector 0), because variable
; *inside-absstobj-update* can be destructively modified.  We actually used
; #(0) here through Version_8.3 and did not see a problem with that, but see
; the comment in *fncall-cache* for why we avoid using a constant here.

   0))

(defun set-absstobj-debug-fn (val)

; See :DOC set-absstobj-debug and see *inside-absstobj-update*.

  (declare (xargs :guard t :verify-guards t :mode :logic))
  #-acl2-loop-only
  (let ((temp (svref *inside-absstobj-update* 0)))

; The following assertion should be true because otherwise, ACL2 is accepting
; input in an illegal-state!

    (assert (or (null temp) (eql temp 0)))
    (cond ((eq val :IGNORE)
           (cond ((ttag (w *the-live-state*))
                  (setf (aref *inside-absstobj-update* 0) :IGNORE))
                 (t
                  (er hard 'set-absstobj-debug
                      "It is illegal to supply the value :IGNORE to ~x0 ~
                       unless there is an active trust tag."
                      'set-absstobj-debug))))
          (t (setf (aref *inside-absstobj-update* 0)
                   (cond (val nil)
                         (t 0))))))
  val)

(defmacro set-absstobj-debug (val)

; 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 file books/demos/defabsstobj-example-4-input.lsp 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
;      :foundation 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 t))
  `(value-triple (set-absstobj-debug-fn ,val)
                 :on-skip-proofs t))

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

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

(defconst *expandable-boot-strap-non-rec-fns*

; Warning: Keep this suitably in sync with *bbody-alist*.

  '(not
    implies eq atom eql = /= null endp zerop from-df

; If we ever make 1+ and 1- functions again, they should go back on this list.

    synp plusp minusp listp return-last mv-list cons-with-hint

; We added the-error for Version_4.0 (replaced by the-check after Version_6.1).
; Before that change, but after changing constraint-info to avoid calling
; remove-guard-holders on a definition body (a change in support of
; canonical-ancestors, for use of the Attachment Restriction Lemma in
; justifying attachment to metafunctions and clause-processors,
; cf. chk-evaluator-use-in-rule), the event (defsort :compare< << :prefix <<)
; failed from community book defsort/uniquep.lisp.

    the-check wormhole-eval force case-split double-rewrite))

(defconst *definition-minimal-theory*

; We include mv-nth because of the call of simplifiable-mv-nthp in the
; definition of call-stack, which (as noted there) results in a use of the
; definition of mv-nth without tracking it in a ttree.

  (list* 'mv-nth 'iff *expandable-boot-strap-non-rec-fns*))

(defconst *bbody-alist*

; Warning: Keep this suitably in sync with *expandable-boot-strap-non-rec-fns*.

; This alist associates each function in *definition-minimal-theory* except
; mv-nth with its normalized body.  It is built as follows.  The equality of
; this constant to that expression is checked at the end of the boot-strap.

;   (merge-sort-lexorder
;    (loop for f in *definition-minimal-theory*
;          when (not (eq fn 'mv-nth))
;          collect
;          (cons f (body f t (w *the-live-state*)))))

  '((/= if (equal x y) 'nil 't)
    (= equal x y)
    (atom if (consp x) 'nil 't)
    (case-split . x)
    (cons-with-hint cons x y)
    (double-rewrite . x)
    (endp if (consp x) 'nil 't)
    (eq equal x y)
    (eql equal x y)
    (force . x)
    (from-df . x)
    (iff if p (if q 't 'nil) (if q 'nil 't))
    (implies if p (if q 't 'nil) 't)
    (listp if (consp x) 't (equal x 'nil))
    (minusp < x '0)
    (mv-list . x)
    (not if p 'nil 't)
    (null equal x 'nil)
    (plusp < '0 x)
    (return-last . last-arg)
    (synp quote t)
    (the-check . y)
    (wormhole-eval quote nil)
    (zerop equal x '0)))

(defun bbody-fn (fn)

; This is just (body fn t wrld), where wrld is the boot-strap world, except
; that currently it may only be applied to functions that are keys in
; *bbody-alist*.

  (declare (xargs :guard (assoc-eq fn *bbody-alist*)))
  (let ((pair (assoc-eq fn *bbody-alist*)))
    (cond (pair (cdr pair))
          (t (er hard! 'bbody
                 "Implementation error: Illegal call of bbody: the symbol ~x0 ~
                  is not a key of ~x1."
                 fn
                 *bbody-alist*)))))

(defmacro bbody (fn)
  (cond ((and (consp fn)
              (consp (cdr fn))
              (eq (car fn) 'quote))
         (kwote (bbody-fn (cadr fn))))
        (t `(bbody-fn ,fn))))

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

(defun constant-t-function-arity-0 ()
  (declare (xargs :mode :logic :guard t))
  t)

(defun constant-nil-function-arity-0 ()
  (declare (xargs :mode :logic :guard t))
  nil)

(defun constant-all-function-arity-0 ()
  (declare (xargs :mode :logic :guard t))
  :all)

(encapsulate
  ()

; The following function symbols are used (ancestrally) in the constraints on
; doppelganger-badge-userfn and doppelganger-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$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))

; Start code for read-file-into-string.

(defconst *read-file-into-string-bound*

; We rather arbitrarily set this value to the largest 64-bit CCL fixnum.  It is
; a strict upper bound on the size of a string we are willing to return from
; read-file-into-string, and it serves as a termination bound for our call of
; read-file-into-string1 inside read-file-into-string.

  (1- (ash 1 60)))

(defun read-file-into-string1 (channel state ans bound)

; Channel is an open input character channel.  We read all the characters in
; the file and return the list of them.

  (declare (xargs :stobjs state
                  :guard (and (symbolp channel)
                              (open-input-channel-p channel :character state)
                              (character-listp ans)
                              (natp bound))
                  :measure (acl2-count bound)))
  (cond ((zp bound) ; file is too large
         (mv nil state))
        (t (mv-let
            (val state)
            (read-char$ channel state)
            (cond ((not (characterp val)) ; end of file
                   (mv (coerce (reverse ans) 'string)
                       state))
                  (t (read-file-into-string1 channel state (cons val ans)
                                             (1- bound))))))))

; At one time the following local lemma seemed to be helpful, but it is not
; currently necessary.

;(local
; (defthm stringp-read-file-into-string1
;   (implies (car (read-file-into-string1 channel state ans bound))
;            (stringp (car (read-file-into-string1 channel state ans
;                                                  bound))))))

(defun read-file-into-string2-logical (filename start bytes state)

; This function logically specifies read-file-into-string2.

  (declare (xargs :stobjs state :guard (and (stringp filename)
                                            (natp start)
                                            (or (null bytes)
                                                (natp bytes)))))
  (non-exec
   (mv-let (erp val state)
     (mv-let (chan state)
       (open-input-channel filename :character state)
       (cond
        ((or (null chan)
; The following is to simplify guard verification.
             (not (state-p state)))
         (mv nil nil state))
        (t (mv-let (val state)
             (read-file-into-string1 chan state nil
                                     *read-file-into-string-bound*)
             (pprogn
              (ec-call ; guard verification here seems unimportant
               (close-input-channel chan state))
              (mv nil val state))))))
     (declare (ignore erp state))
     (and (stringp val)

; If the following conjunct is false, then raw Lisp would cause an error; so
; there is no harm in adding it (and, it helps with guard verification).

          (<= start (length val))
          (subseq val
                  start
                  (if bytes
                      (min (+ start bytes)
                           (length val))
                    (length val)))))))

(defun increment-file-clock (state)
  (declare (xargs :stobjs state))
  #-acl2-loop-only
  (progn (increment-file-clock-raw)
         state)
  #+acl2-loop-only
  (let ((state

; We use this rather goofy LET binding so that ACL2
; can establish the proper stobjs-out.

         (non-exec (update-file-clock (1+ (file-clock state)) state))))
    state))

(defun read-file-into-string2 (filename start bytes close state)

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

; This function relies on the default character encoding of :iso-8859-1, as
; noted below.  See acl2-set-character-encoding.

; We want the raw Lisp code below to be consistent with the logical call below
; of read-file-into-string2-logical.

; In error cases we typically close the associated stream, if any.  But in
; these cases we first make updates to avoid having a closed stream in
; *read-file-into-string-alist*.

; Parallelism wart: avoid potential illegal behavior caused by this function.
; A simple but expensive solution is probably to add a lock.  But with some
; thought one might provide for correct parallel evaluations of this function.

  (declare (xargs :stobjs state :guard (and (stringp filename)
                                            (natp start)
                                            (or (null bytes)
                                                (natp bytes))))
           #+acl2-loop-only
           (ignore close))
  #-acl2-loop-only
  (when (live-state-p state) ; perhaps always true because of signature check
    (return-from
     read-file-into-string2
     (let* ((os-filename (pathname-unix-to-os filename state))
            (pair ; nil or (old-stream/nil old-file-write-date . old-file-clock)
             (assoc-equal os-filename *read-file-into-string-alist*))
            (old-stream-or-nil (car (cdr pair)))
            (stream (or old-stream-or-nil
                        (open os-filename
                              :element-type 'character ; the default
                              :direction :input
                              :if-does-not-exist nil))))
       (cond ((null stream)

; The call of open failed.  We return nil just as we would in
; read-file-into-string2-logical.  But consider the converse: if
; read-file-into-string2-logical would return nil because its call of open
; would fail, then what happens here?  We still might have a stream to the file
; (i.e., a non-nil value of old-stream-or-nil) even though it no longer can be
; opened.  Logically, we can imagine that the file actually still exists in
; that case, so that logically it could be opened.

              (return-from read-file-into-string2 nil))
             ((null pair) ; no prior read that could conflict with this one

; We reset pair to be the new pair that we push onto
; *read-file-into-string-alist*.

              (push (setq pair (cons os-filename (cons stream 0)))
                    *read-file-into-string-alist*))
             ((and (not (eql bytes 0))
                   (< start (cdr (cdr pair))))
              (error "The :start value, ~s, specified for a call of ~s,~%~
                      is less than the position ~s after a previous read of ~
                      file~%~s at the same file-clock.~%See :DOC ~
                      read-file-into-string."
                     start 'read-file-into-string (cdr (cdr pair))
                     os-filename)))
       (let* ((file-len (file-length stream))
              (max-bytes (cond ((<= start file-len)
                                (- file-len start))
                               (t
                                (error "The :start value, ~s, specified for a ~
                                        call~%of ~s, exceeds the length ~s of ~
                                        file~%~s."
                                       start 'read-file-into-string file-len
                                       os-filename))))
              (finish-p (if (eq close :default)
                            (or (null bytes)
                                (< max-bytes bytes))
                          close))
              (bytes (if bytes
                         (min bytes max-bytes)
                       max-bytes))
              seq)
         (declare (type (integer 0 *) file-len max-bytes bytes))
         (when (<= bytes *read-file-into-string-bound*)
           (setf (cdr (cdr pair)) (+ start bytes))

; The following #-acl2-loop-only code, minus the WHEN clause, is originally
; based on code found at
; http://www.ymeme.com/slurping-a-file-common-lisp-83.html and was authored by
; @sabetts, who is apparently Shawn Betts.  The URL above presents five
; implementations of file slurping and I found the discussion truly excellent.
; Thank you @sabetts!

; The URL above says ``You can do anything you like with the code.''

           (setq seq (make-string bytes))
           (file-position stream start)

; It's probably important for the following call that the character encoding is
; :iso-8859-1, so that stream is copied into seq one byte at a time.

           (read-sequence (the string seq) stream))
         (when finish-p

; We close the stream, but we leave the entry in *read-file-into-string-alist*
; to prevent inappropriate reads after the file-write-date has changed but the
; *file-clock* has not.

; Note that we close the stream even if pair is a newly-added to
; *read-file-into-string-alist*.

           (setf (car (cdr pair)) nil)
           (close stream))
         seq))))
  (read-file-into-string2-logical filename start bytes state))

(defmacro read-file-into-string (filename &key
                                          (start '0)
                                          bytes
                                          (close ':default))
  `(read-file-into-string2 ,filename ,start ,bytes ,close state))

(defmacro-untouchable 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, because 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))))

#+acl2-loop-only
(defun print-cl-cache-fn (i j)

; -----------------------------------------------------------------
; Reminders about print-cl-cache:

; See the defrec of cl-cache-line for an explanation of the fields.

; The :status of a line is valid ONLY for the current world and its retractions
; represented by the :absolute-event-number in the line.

; To re-validate line i for the current world use

; (PING-CL-CACHE-LINE i)

; in raw Lisp.  That will update the :status but also move the line to the
; front of the cache and increase its :hit count.

; We don't display the world, just its max-absolute-event-number.  To see the
; number of wrld, do (MAX-ABSOLUTE-EVENT-NUMBER wrld).  But remember:
; different worlds can have the same number!

; To access field :x of cache line i use
; (ACCESS CL-CACHE-LINE (NTH i (ACCESS CL-CACHE *CL-CACHE* :ALIST)) :x)

; The cache involves a circular structure containing many worlds.  Do not print
; it directly.

; When (consp *cl-cache*), then the size of the ring is
; (access cl-cache *cl-cache* :size).

; To clear a cache, set it to some natural number greater than 2, e.g.,

; (setq *cl-cache* 5)

; -----------------------------------------------------------------

; We want the user to be able to see the *cl-cache*, which is actually in raw
; Lisp.  So we stub out a constant nil function and will define it in raw Lisp
; in apply-raw.lisp to print the cache.

; Warning: Keep the return values in sync for the logic and raw Lisp.

  (declare (xargs :guard t)
           (ignore i j))
  nil)

(defmacro print-cl-cache (&optional i j)
  `(print-cl-cache-fn ,i ,j))

; We include definitions here of count-keys (from Sol Swords) and thus also
; hons-remove-assoc (from community book
; books/std/alists/hons-remove-assoc.lisp) in support of hash-table fields of
; stobjs.

(defun hons-remove-assoc (k x)
  (declare (xargs :guard t))
  (if (atom x)
      nil
    (if (and (consp (car x))
             (not (equal k (caar x))))
        (cons (car x) (hons-remove-assoc k (cdr x)))
      (hons-remove-assoc k (cdr x)))))

(defun count-keys (al)
  (declare (xargs :guard t))
  (if (atom al)
      0
    (if (consp (car al))
        (+ 1 (count-keys (hons-remove-assoc (caar al) (cdr al))))
      (count-keys (cdr al)))))

(defun get-cpu-time (state)

; We define this function and get-real-time much like we define read-run-time.
; Logically, they are the same, using the oracle field of the state.  In raw
; Lisp, this one uses the runtime, also known as cpu time.

  (declare (xargs :stobjs state))
  #-acl2-loop-only
  (cond ((live-state-p state) ; handle like read-run-time
         (return-from get-cpu-time
                      (mv (/ (our-get-internal-run-time)
                             internal-time-units-per-second)
                          state))))
  (read-run-time state))

(defun get-real-time (state)

; We define this function and get-cpu-time much like we define read-run-time.
; Logically, they are the same, using the oracle field of the state.  In raw
; Lisp, this one uses the real time.

  (declare (xargs :stobjs state))
  #-acl2-loop-only
  (cond ((live-state-p state) ; handle like read-run-time
         (return-from get-real-time
                      (mv (/ (get-internal-real-time)
                             internal-time-units-per-second)
                          state))))
  (read-run-time state))

(defun the-number (x)
  (declare (xargs :guard (acl2-numberp x)))
  (mbe :logic (fix x)
       :exec x))

(defun the-true-list (x)
  (declare (xargs :guard (true-listp x)))
  (mbe :logic (true-list-fix x)
       :exec x))

(defthm acl2-count-car-cdr-linear
  (implies (consp x)
           (equal (acl2-count x)
                  (+ 1 (acl2-count (car x)) (acl2-count (cdr x)))))
  :rule-classes :linear)

; -----------------------------------------------------------------

; (defconst *inline-suffix* "$INLINE") ; moved above ec-call1-raw
(defconst *inline-suffix-len-minus-1* (1- (length *inline-suffix*)))
(defconst *notinline-suffix* "$NOTINLINE")
(defconst *notinline-suffix-len-minus-1* (1- (length *notinline-suffix*)))

(defun number-of-strings (l)
  (declare (xargs :guard (true-listp l)))
  (cond ((endp l) 0)
        ((stringp (car l))
         (1+ (number-of-strings (cdr l))))
        (t (number-of-strings (cdr l)))))

(defun get-string (l)
  (declare (xargs :guard (true-listp l)))
  (cond ((endp l) nil)
        ((stringp (car l)) (list (car l)))
        (t (get-string (cdr l)))))

(defun remove-strings (l)
  (declare (xargs :guard (true-listp l)))
  (cond ((endp l) nil)
        ((stringp (car l))
         (remove-strings (cdr l)))
        (t (cons (car l) (remove-strings (cdr l))))))

(defun defun-inline-form (name formals lst defun-type suffix)

; Defun-type is DEFUN or DEFUND; suffix is *inline-suffix* or
; *notinline-suffix*.

  (declare (xargs :guard (and (symbolp name)
                              (symbol-listp formals)
                              (true-listp lst)
                              lst
                              (<= (number-of-strings (butlast lst 1))
                                  1)
                              (or (eq defun-type 'defun)
                                  (eq defun-type 'defund))
                              (or (equal suffix *inline-suffix*)
                                  (equal suffix *notinline-suffix*)))))
  (let* ((name$inline (add-suffix name suffix))
         (dcls-and-strings (butlast lst 1))
         (strings (get-string dcls-and-strings))
         (dcls (remove-strings dcls-and-strings))
         (body (car (last lst)))
         (macro-formals formals))
    `(progn (defmacro ,name ,macro-formals
              ,@strings
              (list ',name$inline ,@macro-formals))
            (add-macro-fn ,name ,name$inline)
            (,defun-type ,name$inline ,formals ,@dcls ,body))))

(defmacro defun-inline (name formals &rest lst)

; Here is an explanation for why we insist on specific suffices for inlined and
; notinlined functions, following up on remark (2) in :doc defun-inline.

; We insist on a specific suffix for inlined functions, *inline-suffix*,
; because Common Lisp provides no way to undo (declaim (inline foo)).  To see
; why such undoing is relevant, suppose that (defun-inline foo (x) ...) simply
; expanded to:

;   (progn (declaim (inline foo))
;          (defun foo ...))

; Now consider this example:

;   (encapsulate
;     ()
;     (local (defun-inline foo (x) x))
;     ...)
;
;   (defun foo (x) (cons x x))

; When that encapsulate runs, the form (declaim (inline foo)) would be
; generated.  Since there is no way to undo that declaim before starting the
; second pass of the encapsulate, the global (final) definition of foo would
; also be an inline definition, perhaps contrary to intent.  A similar problem
; occurs if (defun-inline foo ...) is in a locally included book.

; (One might ask: why not undo the (declaim (inline foo)) with (declaim
; (notinline foo))?  That also seems unacceptable, because perhaps it would be
; advantageous for the Lisp compiler to inline some definitions of foo and not
; others.  We would really like something like (declaim
; (back-to-no-claims-about-inline foo)), but that's not available.)

; By insisting on a syntactic naming convention for inlined functions --
; namely, their names end in *inline-suffix* (i.e., in "$INLINE") -- we
; avoid this undoing problem.  That is: we don't mind that we can't undo
; the declaim, because every function of that name will be inlined.

; Implementor hint for "(5) Obscure Remark" in :DOC defun-inline: Search for
; ";;; Declaim forms:" in write-expansion-file, and notice the printing just
; below it of a readtime conditional for the host Lisp, so that declaim forms
; are restricted to that Lisp.  This mechanism was probably put into place so
; that declaiming for GCL didn't result in declaiming for Allegro CL, or
; something along those lines.

  (defun-inline-form name formals lst 'defun *inline-suffix*))

(defmacro defund-inline (name formals &rest lst)

; Warning: Keep this in sync with defun-inline.

  (defun-inline-form name formals lst 'defund *inline-suffix*))

(defmacro defun-notinline (name formals &rest lst)

; Warning: Keep this in sync with defund-notinline.

  (defun-inline-form name formals lst 'defun *notinline-suffix*))

(defmacro defund-notinline (name formals &rest lst)

; Warning: Keep this in sync with defun-inline.

  (defun-inline-form name formals lst 'defund *notinline-suffix*))

; -----------------------------------------------------------------

; The constants and utilities below were introduced in support of the
; conversion of fmt and related functions to be :common-lisp-compliant.  We
; defer the definition of functions supporting +f! etc. to basis-a.lisp because
; they use the #. notation on constants below.

(defconst *fixnat-type* `(unsigned-byte ,*fixnat-bits*))

(defun fixnat-guard (val)
  (declare (xargs :guard t))
  (unsigned-byte-p *fixnat-bits* val))

(defmacro the-fixnat (n)
  (list 'the *fixnat-type* n))

(defconst *fixnat-bits+1* (+ 1 *fixnat-bits*))
(defconst *fixnat-bits+2* (+ 2 *fixnat-bits*))

; Next, we introduce two flavors of ``small'' fixnum arithmetic.

; When dealing with types, ``small'' means a little fixnum.  In fact, they are
; sufficiently small that we can add five of them and still stay within fixnum
; arithmetic.  We extend this notion of small fixnum to allow us to also talk
; about small natural fixnums, to which we give the name small-nats.

(defconst *small-bits* (- *fixnum-bits* 3))
(defconst *small-nat-bits* (- *small-bits* 1))
(defconst *small-type* `(signed-byte ,*small-bits*))
(defconst *small-nat-type* `(unsigned-byte ,*small-nat-bits*))
(defconst *small-lo* (- (expt 2 *small-nat-bits*)))
(defconst *small-hi* (- (expt 2 *small-nat-bits*) 1))

(defun small-nat-guard (val)
  (declare (xargs :guard t))
  (and (natp val)
       (<= val *small-hi*)))

(defmacro the-small (flg x)

; (the-small nil x) declares x to be (possibly negative) small fixnum.
; (the-small t x) declares x to be a non-negative small fixnum.  To keep it
; straight in your head, think of nil meaning negative and t meaning positive.

  (declare (xargs :guard (or (eq flg t) (eq flg nil))))
  `(the ,(if flg
             *small-nat-type*
             *small-type*)
        ,x))

(defun-inline round-to-small (flg x)

; (round-to-small nil x) coerces x to be a (possibly negative) small fixnum.
; (round-to-small t x) coerces x to be a non-negative small fixnum.  To keep it
; straight in your head, think of nil meaning negative and t meaning positive.

  (declare (type #.*fixnum-type* x)) ; fixnum
  (let ((lo (if flg 0 *small-lo*)))
    (if (integerp x)
        (if (< x lo)
            lo
          (let ((hi *small-hi*))
            (if (< hi x)
                hi
              x)))
        0)))

(defun make-the-smalls (args)
  (declare (xargs :guard (true-listp args)))
  (cond ((endp args) nil)
        (t (cons `(the-small nil ,(car args))
                 (make-the-smalls (cdr args))))))

(defmacro +g (&rest args)
  (declare (xargs :guard (< (len args) 6)))
  `(round-to-small nil
                   (the-fixnum
                    (+ ,@(make-the-smalls args)))))

(defmacro +g! (&rest args)
  (declare (xargs :guard (< (len args) 6)))
  `(round-to-small t
                   (the-fixnum
                    (+ ,@(make-the-smalls args)))))

(defmacro -g (x &optional y)
  (if y
      `(round-to-small nil
                       (the-fixnum (- ,@(make-the-smalls (list x y)))))
      `(round-to-small nil
                       (the-fixnum (- ,@(make-the-smalls (list x)))))))

(defmacro -g! (x &optional y)
  (if y
      `(round-to-small t
                       (the-fixnum (- ,@(make-the-smalls (list x y)))))
      `(round-to-small t
                       (the-fixnum (- ,@(make-the-smalls (list x)))))))

; So at this point we have four types:
; (signed-byte #.*fixnum-bits*), i.e., #.*fixnum-type*
; (unsigned-byte #.*fixnat-bits*), i.e., #.*fixnat-type*
; (signed-byte #.*small-bits*)
; (unsigned-byte #.*small-nat-bits*)

; There are general theorems relating these, e.g.,

; (include-book "arithmetic-5/top" :dir :system)
; (SET-DEFAULT-HINTS '((NONLINEARP-DEFAULT-HINT STABLE-UNDER-SIMPLIFICATIONP HIST PSPV)))

; (defthm fact1
;   (implies (and (natp n)
;                 (natp k)
;                 (<= n k)
;                 (unsigned-byte-p n x))
;            (unsigned-byte-p k x))
;   :rule-classes nil)

; (defthm fact2
;   (implies (and (natp n)
;                 (natp k)
;                 (< n k)
;                 (unsigned-byte-p n x))
;            (signed-byte-p k x))
;   :hints (("Goal" :use (:instance fact1 (k (- k 1)))))
;   :rule-classes nil)

; (defthm fact3
;   (implies (and (natp n)
;                 (natp k)
;                 (<= n k)
;                 (signed-byte-p n x))
;            (signed-byte-p k x))
;   :rule-classes nil)

; Facts suffice that are proved in books/support/ppr-support.lisp.

; Here are some logic-mode functions to be used later.

(defun >=-len (x n)
  (declare (xargs :guard (and (integerp n) (<= 0 n))
                  :mode :logic))
  (if (= n 0)
      t
      (if (atom x)
          nil
          (>=-len (cdr x) (1- n)))))

(defun all->=-len (lst n)
  (declare (xargs :guard (and (integerp n) (<= 0 n))
                  :mode :logic))
  (if (atom lst)
      (eq lst nil)
      (and (>=-len (car lst) n)
           (all->=-len (cdr lst) n))))

(defun strip-cadrs (x)
  (declare (xargs :guard (all->=-len x 2)
                  :mode :logic))
  (cond ((endp x) nil)
        (t (cons (cadar x) (strip-cadrs (cdr x))))))

(defun strip-cddrs (x)
  (declare (xargs :guard (all->=-len x 2)
                  :mode :logic))
  (cond ((endp x) nil)
        (t (cons (cddar x) (strip-cddrs (cdr x))))))

#-acl2-loop-only
(defun-one-output zpf (x)
  (declare (type #.*fixnat-type* x))
  (eql (the-fixnat x) 0))
#+acl2-loop-only
(defun zpf (x)
; The logic-only definition of zpf needs to come after expt and integer-range-p.
  (declare (type #.*fixnat-type* x))
  (if (integerp x)
      (<= x 0)
    t))