other
(in-package "ACL2")
*common-lisp-symbols-from-main-lisp-package*constant
(defconst *common-lisp-symbols-from-main-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 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 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 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 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 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 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 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 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 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 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 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))
*common-lisp-specials-and-constants*constant
(defconst *common-lisp-specials-and-constants* '(* ** *** *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 replace fill character = break prin1))
constant
(defconst nil 'nil)
*stobj-inline-declare*constant
(defconst *stobj-inline-declare* '(declare (stobj-inline-fn t)))
make-package-entrymacro
(defmacro make-package-entry (&key name imports hidden-p book-path defpkg-event-form tterm) `(list* ,NAME ,IMPORTS ,HIDDEN-P ,BOOK-PATH ,DEFPKG-EVENT-FORM ,TTERM))
find-package-entrymacro
(defmacro find-package-entry (name known-package-alist) `(assoc-equal ,NAME ,KNOWN-PACKAGE-ALIST))
package-entry-namemacro
(defmacro package-entry-name (package-entry) `(car ,PACKAGE-ENTRY))
package-entry-importsmacro
(defmacro package-entry-imports (package-entry) `(cadr ,PACKAGE-ENTRY))
package-entry-book-pathmacro
(defmacro package-entry-book-path (package-entry) `(cadddr ,PACKAGE-ENTRY))
package-entry-defpkg-event-formmacro
(defmacro package-entry-defpkg-event-form (package-entry) `(car (cddddr ,PACKAGE-ENTRY)))
package-entry-ttermmacro
(defmacro package-entry-tterm (package-entry) `(cdr (cddddr ,PACKAGE-ENTRY)))
remove-package-entrymacro
(defmacro remove-package-entry (name known-package-alist) `(remove1-assoc-equal ,NAME ,KNOWN-PACKAGE-ALIST))
getpropmacro
(defmacro getprop (symb key default world-name world-alist) (if (equal world-name ''current-acl2-world) `(fgetprop ,SYMB ,KEY ,DEFAULT ,WORLD-ALIST) `(sgetprop ,SYMB ,KEY ,DEFAULT ,WORLD-NAME ,WORLD-ALIST)))
getpropcmacro
(defmacro getpropc (symb key &optional default (world-alist '(w state))) `(getprop ,SYMB ,KEY ,DEFAULT 'current-acl2-world ,WORLD-ALIST))
*standard-co*constant
(defconst *standard-co* 'standard-character-output-0)
*standard-oi*constant
(defconst *standard-oi* 'standard-object-input-0)
*standard-ci*constant
(defconst *standard-ci* 'standard-character-input-0)
insistfunction
(defun insist (x) (declare (xargs :guard x :mode :logic :verify-guards t) (ignore x)) nil)
eqfunction
(defun eq (x y) (declare (xargs :guard (if (symbolp x) t (symbolp y)) :mode :logic :verify-guards t)) (equal x y))
booleanpfunction
(defun booleanp (x) (declare (xargs :guard t :mode :logic)) (if (eq x t) t (eq x nil)))
iff-is-an-equivalencetheorem
(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))
iff-implies-equal-implies-1theorem
(defthm iff-implies-equal-implies-1 (implies (iff x x-equiv) (equal (implies x y) (implies x-equiv y))) :rule-classes (:congruence))
iff-implies-equal-implies-2theorem
(defthm iff-implies-equal-implies-2 (implies (iff y y-equiv) (equal (implies x y) (implies x y-equiv))) :rule-classes (:congruence))
iff-implies-equal-nottheorem
(defthm iff-implies-equal-not (implies (iff x x-equiv) (equal (not x) (not x-equiv))) :rule-classes (:congruence))
rewrite-equivfunction
(defun rewrite-equiv (x) (declare (xargs :mode :logic :guard t)) x)
real/rationalpmacro
(defmacro real/rationalp (x) `(rationalp ,X))
complex/complex-rationalpmacro
(defmacro complex/complex-rationalp (x) `(complex-rationalp ,X))
true-listpfunction
(defun true-listp (x) (declare (xargs :guard t :mode :logic)) (if (consp x) (true-listp (cdr x)) (eq x nil)))
list-macrofunction
(defun list-macro (lst) (declare (xargs :guard t)) (if (consp lst) (cons 'cons (cons (car lst) (cons (list-macro (cdr lst)) nil))) nil))
listmacro
(defmacro list (&rest args) (list-macro args))
list$macro
(defmacro list$ (&rest args) (list-macro args))
and-macrofunction
(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))
or-macrofunction
(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))
-macro
(defmacro - (x &optional (y 'nil binary-casep)) (if binary-casep (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))))))
booleanp-compound-recognizertheorem
(defthm booleanp-compound-recognizer (equal (booleanp x) (or (equal x t) (equal x nil))) :rule-classes :compound-recognizer)
integer-absfunction
(defun integer-abs (x) (declare (xargs :guard t :mode :logic)) (if (integerp x) (if (< x 0) (- x) x) 0))
xxxjoinfunction
(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)))
+macro
(defmacro + (&rest rst) (if rst (if (cdr rst) (xxxjoin 'binary-+ rst) (cons 'binary-+ (cons 0 (cons (car rst) nil)))) 0))
lenfunction
(defun len (x) (declare (xargs :guard t :mode :program)) (if (consp x) (+ 1 (len (cdr x))) 0))
lengthfunction
(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-countfunction
(defun acl2-count (x) (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)))))
other
(verify-termination-boot-strap :skip-proofs len (declare (xargs :mode :logic)))
other
(verify-termination-boot-strap :skip-proofs length (declare (xargs :mode :logic)))
other
(verify-termination-boot-strap :skip-proofs acl2-count (declare (xargs :mode :logic)))
cond-clausespfunction
(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)))
cond-macrofunction
(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))) (list 'or (car (car clauses)) (cond-macro (cdr clauses))))) nil))
condmacro
(defmacro cond (&rest clauses) (declare (xargs :guard (cond-clausesp clauses))) (cond-macro clauses))
eqlablepfunction
(defun eqlablep (x) (declare (xargs :mode :logic :guard t)) (or (acl2-numberp x) (symbolp x) (characterp x)))
eqlablep-recogtheorem
(defthm eqlablep-recog (equal (eqlablep x) (or (acl2-numberp x) (symbolp x) (characterp x))) :rule-classes :compound-recognizer)
eqlable-listpfunction
(defun eqlable-listp (l) (declare (xargs :mode :logic :guard t)) (if (consp l) (and (eqlablep (car l)) (eqlable-listp (cdr l))) (equal l nil)))
eqlfunction
(defun eql (x y) (declare (xargs :mode :logic :guard (or (eqlablep x) (eqlablep y)))) (equal x y))
*null-char*constant
(defconst *null-char* (code-char 0))
make-character-listfunction
(defun make-character-list (x) (declare (xargs :guard t)) (cond ((atom x) nil) ((characterp (car x)) (cons (car x) (make-character-list (cdr x)))) (t (cons *null-char* (make-character-list (cdr x))))))
eqlable-alistpfunction
(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))))))
alistpfunction
(defun alistp (l) (declare (xargs :guard t)) (cond ((atom l) (eq l nil)) (t (and (consp (car l)) (alistp (cdr l))))))
alistp-forward-to-true-listptheorem
(defthm alistp-forward-to-true-listp (implies (alistp x) (true-listp x)) :rule-classes :forward-chaining)
eqlable-alistp-forward-to-alistptheorem
(defthm eqlable-alistp-forward-to-alistp (implies (eqlable-alistp x) (alistp x)) :rule-classes :forward-chaining)
aconsfunction
(defun acons (key datum alist) (declare (xargs :guard (alistp alist))) (cons (cons key datum) alist))
endpfunction
(defun endp (x) (declare (xargs :mode :logic :guard (or (consp x) (eq x nil)))) (atom x))
symbol-listpfunction
(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))))))
symbol-listp-forward-to-eqlable-listptheorem
(defthm symbol-listp-forward-to-eqlable-listp (implies (symbol-listp x) (eqlable-listp x)) :rule-classes :forward-chaining)
symbol-doublet-listpfunction
(defun symbol-doublet-listp (lst) (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))))))
reverse-strip-carsfunction
(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)))))
strip-carsfunction
(defun strip-cars (x) (declare (xargs :guard (alistp x))) (cond ((endp x) nil) (t (cons (car (car x)) (strip-cars (cdr x))))))
reverse-strip-cdrsfunction
(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)))))
strip-cdrsfunction
(defun strip-cdrs (x) (declare (xargs :guard (alistp x))) (cond ((endp x) nil) (t (cons (cdr (car x)) (strip-cdrs (cdr x))))))
hard-errorfunction
(defun hard-error (ctx str alist) (declare (xargs :guard t :mode :logic)) (declare (ignore ctx str alist)) nil)
illegalfunction
(defun illegal (ctx str alist) (declare (xargs :guard (hard-error ctx str alist))) (hard-error ctx str alist))
return-lastfunction
(defun return-last (fn eager-arg last-arg) (declare (ignore fn eager-arg) (xargs :guard (if (equal fn 'mbe1-raw) (equal last-arg eager-arg) t) :mode :logic)) last-arg)
return-last-fnfunction
(defun return-last-fn (qfn) (declare (xargs :guard t)) (and (consp qfn) (eq (car qfn) 'quote) (consp (cdr qfn)) (symbolp (cadr qfn)) (null (cddr qfn)) (cadr qfn)))
mbe1macro
(defmacro mbe1 (exec logic) `(return-last 'mbe1-raw ,EXEC ,LOGIC))
must-be-equalmacro
(defmacro must-be-equal (logic exec) `(mbe1 ,EXEC ,LOGIC))
mbemacro
(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))
binary-appendfunction
(defun binary-append (x y) (declare (xargs :guard (true-listp x))) (cond ((endp x) y) (t (cons (car x) (binary-append (cdr x) y)))))
appendmacro
(defmacro append (&rest rst) (cond ((null rst) nil) ((null (cdr rst)) (car rst)) (t (xxxjoin 'binary-append rst))))
true-listp-appendtheorem
(defthm true-listp-append (implies (true-listp b) (true-listp (append a b))) :rule-classes :type-prescription)
car-cdr-elimaxiom
(defaxiom car-cdr-elim (implies (consp x) (equal (cons (car x) (cdr x)) x)) :rule-classes :elim)
cons-equalaxiom
(defaxiom cons-equal (equal (equal (cons x1 y1) (cons x2 y2)) (and (equal x1 x2) (equal y1 y2))))
append-to-niltheorem
(defthm append-to-nil (implies (true-listp x) (equal (append x nil) x)))
concatenatemacro
(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))) (list 'string-append (car sequences) (cadr sequences))) (t (list 'string-append-lst (cons 'list sequences))))) ((endp sequences) nil) (t (cons 'append (append sequences (list nil))))))
string-appendfunction
(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 (concatenate 'string str1 str2)))
string-listpfunction
(defun string-listp (x) (declare (xargs :guard t)) (cond ((atom x) (eq x nil)) (t (and (stringp (car x)) (string-listp (cdr x))))))
string-append-lstfunction
(defun string-append-lst (x) (declare (xargs :guard (string-listp x))) (cond ((endp x) "") (t (string-append (car x) (string-append-lst (cdr x))))))
guard-check-fnfunction
(defun guard-check-fn (sym) (declare (xargs :guard (symbolp sym))) (intern-in-package-of-symbol (concatenate 'string (symbol-name sym) "$GUARD-CHECK") 'rewrite))
let-mbe-guard-formfunction
(defun let-mbe-guard-form (logic exec) (declare (ignore logic) (xargs :mode :program :guard (and (consp logic) (consp exec) (symbolp (car exec)) (equal (cdr logic) (cdr exec))))) (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))))))
let-mbemacro
(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)))))
defun-with-guard-checkmacro
(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))))
prog2$macro
(defmacro prog2$ (x y) `(return-last 'progn ,X ,Y))
other
(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)))))
other
(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)))))
member-equalfunction
(defun member-equal (x lst) (declare (xargs :guard (true-listp lst))) (cond ((endp lst) nil) ((equal x (car lst)) lst) (t (member-equal x (cdr lst)))))
member-eq-exec-is-member-equaltheorem
(defthm member-eq-exec-is-member-equal (equal (member-eq-exec x l) (member-equal x l)))
member-eql-exec-is-member-equaltheorem
(defthm member-eql-exec-is-member-equal (equal (member-eql-exec x l) (member-equal x l)))
membermacro
(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 `(member-equal ,X ,L))))
other
(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)))
other
(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)))
subsetp-equalfunction
(defun subsetp-equal (x y) (declare (xargs :guard (and (true-listp y) (true-listp x)))) (cond ((endp x) t) ((member-equal (car x) y) (subsetp-equal (cdr x) y)) (t nil)))
subsetp-eqmacro
(defmacro subsetp-eq (x y) `(subsetp ,X ,Y :test 'eq))
subsetp-eq-exec-is-subsetp-equaltheorem
(defthm subsetp-eq-exec-is-subsetp-equal (equal (subsetp-eq-exec x y) (subsetp-equal x y)))
subsetp-eql-exec-is-subsetp-equaltheorem
(defthm subsetp-eql-exec-is-subsetp-equal (equal (subsetp-eql-exec x y) (subsetp-equal x y)))
subsetpmacro
(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 `(subsetp-equal ,X ,Y))))
symbol-alistpfunction
(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))))))
symbol-alistp-forward-to-eqlable-alistptheorem
(defthm symbol-alistp-forward-to-eqlable-alistp (implies (symbol-alistp x) (eqlable-alistp x)) :rule-classes :forward-chaining)
character-alistpfunction
(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))))))
character-alistp-forward-to-eqlable-alistptheorem
(defthm character-alistp-forward-to-eqlable-alistp (implies (character-alistp x) (eqlable-alistp x)) :rule-classes :forward-chaining)
other
(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)))))
other
(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)))))
assoc-equalfunction
(defun assoc-equal (x alist) (declare (xargs :guard (alistp alist))) (cond ((endp alist) nil) ((equal x (car (car alist))) (car alist)) (t (assoc-equal x (cdr alist)))))
assoc-eq-exec-is-assoc-equaltheorem
(defthm assoc-eq-exec-is-assoc-equal (equal (assoc-eq-exec x l) (assoc-equal x l)))
assoc-eql-exec-is-assoc-equaltheorem
(defthm assoc-eql-exec-is-assoc-equal (equal (assoc-eql-exec x l) (assoc-equal x l)))
assocmacro
(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 `(assoc-equal ,X ,ALIST))))
assoc-eq-equal-alistpfunction
(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))))))
assoc-eq-safefunction
(defun assoc-eq-safe (key alist) (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)))))
assoc-eq-equalfunction
(defun assoc-eq-equal (x y alist) (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)))))
assoc-eq-cadrfunction
(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)))))
assoc-equal-cadrfunction
(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)))))
=function
(defun = (x y) (declare (xargs :mode :logic :guard (and (acl2-numberp x) (acl2-numberp y)))) (equal x y))
/=function
(defun /= (x y) (declare (xargs :mode :logic :guard (and (acl2-numberp x) (acl2-numberp y)))) (not (equal x y)))
int=macro
(defmacro int= (i j) (list 'eql (if (integerp i) i (list 'the 'integer i)) (if (integerp j) j (list 'the 'integer j))))
zpfunction
(defun zp (x) (declare (xargs :mode :logic :guard (and (integerp x) (<= 0 x)))) (if (integerp x) (<= x 0) t))
zp-compound-recognizertheorem
(defthm zp-compound-recognizer (equal (zp x) (or (not (integerp x)) (<= x 0))) :rule-classes :compound-recognizer)
zp-opentheorem
(defthm zp-open (implies (syntaxp (not (variablep x))) (equal (zp x) (if (integerp x) (<= x 0) t))))
zipfunction
(defun zip (x) (declare (xargs :mode :logic :guard (integerp x))) (if (integerp x) (= x 0) t))
zip-compound-recognizertheorem
(defthm zip-compound-recognizer (equal (zip x) (or (not (integerp x)) (equal x 0))) :rule-classes :compound-recognizer)
zip-opentheorem
(defthm zip-open (implies (syntaxp (not (variablep x))) (equal (zip x) (or (not (integerp x)) (equal x 0)))))
nthfunction
(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)))))
charfunction
(defun char (s n) (declare (xargs :guard (and (stringp s) (integerp n) (>= n 0) (< n (length s))))) (nth n (coerce s 'list)))
sleepfunction
(defun sleep (n) (declare (xargs :guard (and (rationalp n) (<= 0 n)))) (declare (ignore n)) nil)
proper-conspfunction
(defun proper-consp (x) (declare (xargs :guard t)) (and (consp x) (true-listp x)))
improper-conspfunction
(defun improper-consp (x) (declare (xargs :guard t)) (and (consp x) (not (true-listp x))))
*macro
(defmacro * (&rest rst) (cond ((null rst) 1) ((null (cdr rst)) (list 'binary-* 1 (car rst))) (t (xxxjoin 'binary-* rst))))
nonnegative-productaxiom
(defaxiom nonnegative-product (implies (real/rationalp x) (and (real/rationalp (* x x)) (<= 0 (* x x)))) :rule-classes ((:type-prescription :typed-term (* x x))))
conjugatefunction
(defun conjugate (x) (declare (xargs :guard (acl2-numberp x))) (complex (realpart x) (- (imagpart x))))
add-suffixfunction
(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))
*inline-suffix*constant
(defconst *inline-suffix* "$INLINE")
boolean-listpfunction
(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))))))
boolean-listp-constheorem
(defthm boolean-listp-cons (equal (boolean-listp (cons x y)) (and (booleanp x) (boolean-listp y))))
boolean-listp-forwardtheorem
(defthm boolean-listp-forward (implies (boolean-listp (cons a lst)) (and (booleanp a) (boolean-listp lst))) :rule-classes :forward-chaining)
boolean-listp-forward-to-symbol-listptheorem
(defthm boolean-listp-forward-to-symbol-listp (implies (boolean-listp x) (symbol-listp x)) :rule-classes :forward-chaining)
qdfs-checkfunction
(defun qdfs-check (qdfs) (declare (xargs :guard t)) (or (null qdfs) (and (true-listp qdfs) (= (length qdfs) 2) (eq (car qdfs) 'quote) (boolean-listp (cadr qdfs)))))
ec-call1macro
(defmacro ec-call1 (qdfs-in0 qdfs-out0 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)))
ec-callmacro
(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)))))))))
non-execmacro
(defmacro non-exec (x) (declare (xargs :guard t)) `(prog2$ (throw-nonexec-error :non-exec ',X) ,X))
/macro
(defmacro / (x &optional (y 'nil binary-casep)) (cond (binary-casep (list 'binary-* x (list 'unary-/ y))) (t (list 'unary-/ x))))
closureaxiom
(defaxiom closure (and (acl2-numberp (+ x y)) (acl2-numberp (* x y)) (acl2-numberp (- x)) (acl2-numberp (/ x))) :rule-classes nil)
commutativity-of-+axiom
(defaxiom commutativity-of-+ (equal (+ x y) (+ y x)))
unicity-of-0axiom
(defaxiom unicity-of-0 (equal (+ 0 x) (fix x)))
inverse-of-+axiom
(defaxiom inverse-of-+ (equal (+ x (- x)) 0))
commutativity-of-*axiom
(defaxiom commutativity-of-* (equal (* x y) (* y x)))
unicity-of-1axiom
(defaxiom unicity-of-1 (equal (* 1 x) (fix x)))
inverse-of-*axiom
(defaxiom inverse-of-* (implies (and (acl2-numberp x) (not (equal x 0))) (equal (* x (/ x)) 1)))
<-on-othersaxiom
(defaxiom <-on-others (equal (< x y) (< (+ x (- y)) 0)) :rule-classes nil)
trichotomyaxiom
(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)
positiveaxiom
(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)
rational-implies1axiom
(defaxiom rational-implies1 (implies (rationalp x) (and (integerp (denominator x)) (integerp (numerator x)) (< 0 (denominator x)))) :rule-classes nil)
rational-implies2axiom
(defaxiom rational-implies2 (implies (rationalp x) (equal (* (/ (denominator x)) (numerator x)) x)))
integer-implies-rationalaxiom
(defaxiom integer-implies-rational (implies (integerp x) (rationalp x)) :rule-classes nil)
complex-implies1axiom
(defaxiom complex-implies1 (and (real/rationalp (realpart x)) (real/rationalp (imagpart x))) :rule-classes nil)
complex-definitionaxiom
(defaxiom complex-definition (implies (and (real/rationalp x) (real/rationalp y)) (equal (complex x y) (+ x (* #C(0 1) y)))))
in-theory
(in-theory (disable complex-definition))
nonzero-imagpartaxiom
(defaxiom nonzero-imagpart (implies (complex/complex-rationalp x) (not (equal 0 (imagpart x)))) :rule-classes nil)
realpart-imagpart-elimaxiom
(defaxiom realpart-imagpart-elim (implies (acl2-numberp x) (equal (complex (realpart x) (imagpart x)) x)) :rule-classes (:rewrite :elim))
realpart-complexaxiom
(defaxiom realpart-complex (implies (and (real/rationalp x) (real/rationalp y)) (equal (realpart (complex x y)) x)))
imagpart-complexaxiom
(defaxiom imagpart-complex (implies (and (real/rationalp x) (real/rationalp y)) (equal (imagpart (complex x y)) y)))
complex-equaltheorem
(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))))
*force-xnume*constant
(defconst *force-xnume* (let ((x 165)) x))
immediate-force-modepfunction
(defun immediate-force-modep nil (declare (xargs :mode :logic :guard t)) "See :DOC immediate-force-modep.")
*immediate-force-modep-xnume*constant
(defconst *immediate-force-modep-xnume* (+ *force-xnume* 3))
case-splitfunction
(defun case-split (x) (declare (xargs :mode :logic :guard t)) x)
in-theory
(in-theory (disable (:executable-counterpart immediate-force-modep)))
disable-forcingmacro
(defmacro disable-forcing nil '(in-theory (disable (:executable-counterpart force))))
enable-forcingmacro
(defmacro enable-forcing nil '(in-theory (enable (:executable-counterpart force))))
disable-immediate-force-modepmacro
(defmacro disable-immediate-force-modep nil '(in-theory (disable (:executable-counterpart immediate-force-modep))))
enable-immediate-force-modepmacro
(defmacro enable-immediate-force-modep nil '(in-theory (enable (:executable-counterpart immediate-force-modep))))
synpfunction
(defun synp (vars form term) (declare (xargs :mode :logic :guard t) (ignore vars form term)) t)
syntaxpmacro
(defmacro syntaxp (form) (declare (xargs :guard t)) `(synp 'nil '(syntaxp ,FORM) '(and ,FORM t)))
bind-freemacro
(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 ',VARS '(bind-free ,FORM ,VARS) ',FORM) `(synp 't '(bind-free ,FORM) ',FORM)))
extra-infofunction
(defun extra-info (x y) (declare (ignore x y) (xargs :guard t)) t)
in-theory
(in-theory (disable extra-info (extra-info) (:type-prescription extra-info)))
*extra-info-fn*constant
(defconst *extra-info-fn* 'extra-info)
tau-systemfunction
(defun tau-system (x) (declare (xargs :mode :logic :guard t)) x)
*tau-status-boot-strap-settings*constant
(defconst *tau-status-boot-strap-settings* '((t . t) t . t))
in-theory
(in-theory (if (caar *tau-status-boot-strap-settings*) (enable (:executable-counterpart tau-system)) (disable (:executable-counterpart tau-system))))
*tau-system-xnume*constant
(defconst *tau-system-xnume* (+ *force-xnume* 12))
*tau-acl2-numberp-pair*constant
(defconst *tau-acl2-numberp-pair* '(0 . acl2-numberp))
*tau-integerp-pair*constant
(defconst *tau-integerp-pair* '(4 . integerp))
*tau-rationalp-pair*constant
(defconst *tau-rationalp-pair* '(5 . rationalp))
*tau-booleanp-pair*constant
(defconst *tau-booleanp-pair* '(8 . booleanp))
*tau-natp-pair*constant
(defconst *tau-natp-pair* '(18 . natp))
*tau-bitp-pair*constant
(defconst *tau-bitp-pair* (cons (+ 1 (car *tau-natp-pair*)) 'bitp))
*tau-posp-pair*constant
(defconst *tau-posp-pair* (cons (+ 2 (car *tau-natp-pair*)) 'posp))
*tau-minusp-pair*constant
(defconst *tau-minusp-pair* (cons (+ 13 (car *tau-natp-pair*)) 'minusp))
rewrite-lambda-modepfunction
(defun rewrite-lambda-modep (x) (declare (xargs :mode :logic :guard t)) x)
*rewrite-lambda-modep-def-nume*constant
(defconst *rewrite-lambda-modep-def-nume* (+ *tau-system-xnume* 2))
*rewrite-lambda-modep-xnume*constant
(defconst *rewrite-lambda-modep-xnume* (+ *tau-system-xnume* 3))
integer-stepaxiom
(defaxiom integer-step (implies (integerp x) (and (integerp (+ x 1)) (integerp (+ x -1)))) :rule-classes nil)
lowest-termsaxiom
(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)
basic-tau-rulestheorem
(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))) (implies (booleanp v) (symbolp v)) (booleanp (equal x y)) (booleanp (< x y))) :rule-classes :tau-system)
booleanp-characterpaxiom
(defaxiom booleanp-characterp (booleanp (characterp x)) :rule-classes nil)
characterp-pageaxiom
(defaxiom characterp-page (characterp #\ ) :rule-classes nil)
characterp-tabaxiom
(defaxiom characterp-tab (characterp #\ ) :rule-classes nil)
characterp-ruboutaxiom
(defaxiom characterp-rubout (characterp #\) :rule-classes nil)
characterp-returnaxiom
(defaxiom characterp-return (characterp #\ ) :rule-classes nil)
other
(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)))))
other
(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)))))
no-duplicatesp-equalfunction
(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)))))
no-duplicatesp-eqmacro
(defmacro no-duplicatesp-eq (x) `(no-duplicatesp ,X :test 'eq))
no-duplicatesp-eq-exec-is-no-duplicatesp-equaltheorem
(defthm no-duplicatesp-eq-exec-is-no-duplicatesp-equal (equal (no-duplicatesp-eq-exec x) (no-duplicatesp-equal x)))
no-duplicatesp-eql-exec-is-no-duplicatesp-equaltheorem
(defthm no-duplicatesp-eql-exec-is-no-duplicatesp-equal (equal (no-duplicatesp-eql-exec x) (no-duplicatesp-equal x)))
no-duplicatespmacro
(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 `(no-duplicatesp-equal ,X))))
r-eqlable-alistpfunction
(defun r-eqlable-alistp (x) (declare (xargs :guard t)) (cond ((atom x) (equal x nil)) (t (and (consp (car x)) (eqlablep (cdr (car x))) (r-eqlable-alistp (cdr x))))))
r-symbol-alistpfunction
(defun r-symbol-alistp (x) (declare (xargs :guard t)) (cond ((atom x) (equal x nil)) (t (and (consp (car x)) (symbolp (cdr (car x))) (r-symbol-alistp (cdr x))))))
other
(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)))))
other
(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)))))
rassoc-equalfunction
(defun rassoc-equal (x alist) (declare (xargs :guard (alistp alist))) (cond ((endp alist) nil) ((equal x (cdr (car alist))) (car alist)) (t (rassoc-equal x (cdr alist)))))
rassoc-eq-exec-is-rassoc-equaltheorem
(defthm rassoc-eq-exec-is-rassoc-equal (equal (rassoc-eq-exec x alist) (rassoc-equal x alist)))
rassoc-eql-exec-is-rassoc-equaltheorem
(defthm rassoc-eql-exec-is-rassoc-equal (equal (rassoc-eql-exec x alist) (rassoc-equal x alist)))
rassocmacro
(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 `(rassoc-equal ,X ,ALIST))))
realfixfunction
(defun realfix (x) (declare (xargs :guard t :mode :logic)) (if (real/rationalp x) x 0))
natp-compound-recognizertheorem
(defthm natp-compound-recognizer (equal (natp x) (and (integerp x) (<= 0 x))) :rule-classes :compound-recognizer)
nat-alistpfunction
(defun nat-alistp (x) (declare (xargs :guard t)) (cond ((atom x) (eq x nil)) (t (and (consp (car x)) (natp (car (car x))) (nat-alistp (cdr x))))))
nat-alistp-forward-to-eqlable-alistptheorem
(defthm nat-alistp-forward-to-eqlable-alistp (implies (nat-alistp x) (eqlable-alistp x)) :rule-classes :forward-chaining)
bitp-compound-recognizertheorem
(defthm bitp-compound-recognizer (equal (bitp x) (or (equal x 0) (equal x 1))) :rule-classes :compound-recognizer)
bitp-as-inequalitytheorem
(defthm bitp-as-inequality (implies (bitp x) (and (natp x) (< x 2))) :rule-classes :tau-system)
posp-compound-recognizertheorem
(defthm posp-compound-recognizer (equal (posp x) (and (integerp x) (< 0 x))) :rule-classes :compound-recognizer)
o-first-exptfunction
(defun o-first-expt (x) (declare (xargs :guard (or (o-finp x) (consp (car x))) :mode :logic)) (if (o-finp x) 0 (caar x)))
o-first-coefffunction
(defun o-first-coeff (x) (declare (xargs :guard (or (o-finp x) (consp (car x))) :mode :logic)) (if (o-finp x) x (cdar x)))
o<gfunction
(defun o<g (x) (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)))))
o<function
(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)))))
other
(verify-termination-boot-strap :skip-proofs o<g (declare (xargs :mode :logic)))
other
(verify-termination-boot-strap :skip-proofs o< (declare (xargs :mode :logic)))
o-pfunction
(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)))))
o-p-implies-o<gtheorem
(defthm o-p-implies-o<g (implies (o-p a) (o<g a)))
other
(verify-guards o-p)
make-ordfunction
(defun make-ord (fe fco rst) (declare (xargs :guard (and (posp fco) (o-p fe) (o-p rst)))) (cons (cons fe fco) rst))
*standard-chars*constant
(defconst *standard-chars* '(#\ #\ #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\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 #\{ #\| #\} #\~))
standard-char-pfunction
(defun standard-char-p (x) (declare (xargs :guard (characterp x))) (if (member x *standard-chars*) t nil))
standard-char-p+function
(defun standard-char-p+ (x) (declare (xargs :guard t)) (and (characterp x) (standard-char-p x)))
standard-char-listpfunction
(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))))
character-listpfunction
(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))))))
character-listp-forward-to-eqlable-listptheorem
(defthm character-listp-forward-to-eqlable-listp (implies (character-listp x) (eqlable-listp x)) :rule-classes :forward-chaining)
standard-char-listp-forward-to-character-listptheorem
(defthm standard-char-listp-forward-to-character-listp (implies (standard-char-listp x) (character-listp x)) :rule-classes :forward-chaining)
coerce-inverse-1axiom
(defaxiom coerce-inverse-1 (implies (character-listp x) (equal (coerce (coerce x 'string) 'list) x)))
coerce-inverse-2axiom
(defaxiom coerce-inverse-2 (implies (stringp x) (equal (coerce (coerce x 'list) 'string) x)))
character-listp-coerceaxiom
(defaxiom character-listp-coerce (character-listp (coerce str 'list)) :rule-classes (:rewrite (:forward-chaining :trigger-terms ((coerce str 'list)))))
in-theory
(in-theory (disable standard-char-listp standard-char-p))
stringfunction
(defun string (x) (declare (xargs :guard (or (stringp x) (symbolp x) (characterp x)) :mode :logic)) (cond ((stringp x) x) ((symbolp x) (symbol-name x)) (t (coerce (list x) 'string))))
our-digit-char-pfunction
(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))))
digit-char-pmacro
(defmacro digit-char-p (ch &optional (radix '10)) `(our-digit-char-p ,CH ,RADIX))
atom-listpfunction
(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))))))
atom-listp-forward-to-true-listptheorem
(defthm atom-listp-forward-to-true-listp (implies (atom-listp x) (true-listp x)) :rule-classes :forward-chaining)
eqlable-listp-forward-to-atom-listptheorem
(defthm eqlable-listp-forward-to-atom-listp (implies (eqlable-listp x) (atom-listp x)) :rule-classes :forward-chaining)
characterp-nththeorem
(defthm characterp-nth (implies (and (character-listp x) (<= 0 i) (< i (len x))) (characterp (nth i x))))
standard-string-p1function
(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))))))
standard-string-pfunction
(defun standard-string-p (x) (declare (xargs :guard (stringp x))) (standard-string-p1 x (length x)))
standard-string-listpfunction
(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))))))
list*-macrofunction
(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)))))
throw-or-attach-callfunction
(defun throw-or-attach-call (fn formals) (declare (xargs :guard t)) (list 'throw-or-attach fn formals))
null-body-erfunction
(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)))
*main-lisp-package-name*constant
(defconst *main-lisp-package-name* "COMMON-LISP")
*initial-known-package-alist*constant
(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* :imports nil) (make-package-entry :name "KEYWORD" :imports nil)))
stringp-symbol-package-nameaxiom
(defaxiom stringp-symbol-package-name (stringp (symbol-package-name x)) :rule-classes :type-prescription)
symbolp-intern-in-package-of-symbolaxiom
(defaxiom symbolp-intern-in-package-of-symbol (symbolp (intern-in-package-of-symbol x y)) :rule-classes :type-prescription)
symbolp-pkg-witnessaxiom
(defaxiom symbolp-pkg-witness (symbolp (pkg-witness x)) :rule-classes :type-prescription)
internmacro
(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") ''a-random-symbol-for-intern) ((equal y "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)))))))
keywordpfunction
(defun keywordp (x) (declare (xargs :guard t)) (and (symbolp x) (equal (symbol-package-name x) "KEYWORD")))
keywordp-forward-to-symbolptheorem
(defthm keywordp-forward-to-symbolp (implies (keywordp x) (symbolp x)) :rule-classes :forward-chaining)
intern-in-package-of-symbol-symbol-nameaxiom
(defaxiom intern-in-package-of-symbol-symbol-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)))
symbol-package-name-of-symbol-is-not-empty-stringtheorem
(defthm symbol-package-name-of-symbol-is-not-empty-string (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)))))
*pkg-witness-name*constant
(defconst *pkg-witness-name* "ACL2-PKG-WITNESS")
symbol-name-pkg-witnessaxiom
(defaxiom symbol-name-pkg-witness (equal (symbol-name (pkg-witness pkg-name)) *pkg-witness-name*))
symbol-package-name-pkg-witness-nameaxiom
(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 "ACL2")))
member-symbol-namefunction
(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)))))
in-theory
(in-theory (disable member-symbol-name))
symbol-name-intern-in-package-of-symbolaxiom
(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)))
symbol-package-name-intern-in-package-of-symbolaxiom
(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))))
intern-in-package-of-symbol-is-identityaxiom
(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)))))))
symbol-listp-pkg-importsaxiom
(defaxiom symbol-listp-pkg-imports (symbol-listp (pkg-imports pkg)) :rule-classes ((:forward-chaining :trigger-terms ((pkg-imports pkg)))))
encapsulate
(encapsulate nil (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))
no-duplicatesp-eq-pkg-importsaxiom
(defaxiom no-duplicatesp-eq-pkg-imports (no-duplicatesp-eq (pkg-imports pkg)) :rule-classes :rewrite)
completion-of-pkg-importsaxiom
(defaxiom completion-of-pkg-imports (equal (pkg-imports x) (if (stringp x) (pkg-imports x) nil)) :rule-classes nil)
default-pkg-importstheorem
(defthm default-pkg-imports (implies (not (stringp x)) (equal (pkg-imports x) nil)) :hints (("Goal" :use completion-of-pkg-imports)))
acl2-input-channel-packageaxiom
(defaxiom acl2-input-channel-package (equal (pkg-imports "ACL2-INPUT-CHANNEL") nil))
acl2-output-channel-packageaxiom
(defaxiom acl2-output-channel-package (equal (pkg-imports "ACL2-OUTPUT-CHANNEL") nil))
acl2-packageaxiom
(defaxiom acl2-package (equal (pkg-imports "ACL2") *common-lisp-symbols-from-main-lisp-package*))
keyword-packageaxiom
(defaxiom keyword-package (equal (pkg-imports "KEYWORD") nil))
string-is-not-circularaxiom
(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)
nil-is-not-circularaxiom
(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)
standard-char-listp-appendtheorem
(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))))
character-listp-appendtheorem
(defthm character-listp-append (implies (true-listp x) (equal (character-listp (append x y)) (and (character-listp x) (character-listp y)))))
cons-with-hintfunction
(defun cons-with-hint (x y hint) (declare (xargs :guard t) (ignorable hint)) (cons x y))
other
(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))))))
other
(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))))))
remove-equalfunction
(defun remove-equal (x l) (declare (xargs :guard (true-listp l))) (cond ((endp l) nil) ((equal x (car l)) (remove-equal x (cdr l))) (t (cons (car l) (remove-equal x (cdr l))))))
remove-eq-exec-is-remove-equaltheorem
(defthm remove-eq-exec-is-remove-equal (equal (remove-eq-exec x l) (remove-equal x l)))
remove-eql-exec-is-remove-equaltheorem
(defthm remove-eql-exec-is-remove-equal (equal (remove-eql-exec x l) (remove-equal x l)))
removemacro
(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 `(remove-equal ,X ,L))))
other
(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))))
other
(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))))
remove1-equalfunction
(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))))
remove1-eqmacro
(defmacro remove1-eq (x lst) `(remove1 ,X ,LST :test 'eq))
remove1-eq-exec-is-remove1-equaltheorem
(defthm remove1-eq-exec-is-remove1-equal (equal (remove1-eq-exec x l) (remove1-equal x l)))
remove1-eql-exec-is-remove1-equaltheorem
(defthm remove1-eql-exec-is-remove1-equal (equal (remove1-eql-exec x l) (remove1-equal x l)))
remove1macro
(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 `(remove1-equal ,X ,L))))
other
(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))))
other
(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))))
remove-duplicates-equalfunction
(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))))
remove-duplicates-eqmacro
(defmacro remove-duplicates-eq (x) `(remove-duplicates ,X :test 'eq))
remove-duplicates-eq-exec-is-remove-duplicates-equaltheorem
(defthm remove-duplicates-eq-exec-is-remove-duplicates-equal (equal (remove-duplicates-eq-exec x) (remove-duplicates-equal x)))
remove-duplicates-eql-exec-is-remove-duplicates-equaltheorem
(defthm remove-duplicates-eql-exec-is-remove-duplicates-equal (equal (remove-duplicates-eql-exec x) (remove-duplicates-equal x)))
remove-duplicates-logicmacro
(defmacro remove-duplicates-logic (x) `(let ((x ,X)) (if (stringp x) (coerce (remove-duplicates-equal (coerce x 'list)) 'string) (remove-duplicates-equal x))))
remove-duplicatesmacro
(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 :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 `(remove-duplicates-logic ,X))))
character-listp-remove-duplicatestheorem
(defthm character-listp-remove-duplicates (implies (character-listp x) (character-listp (remove-duplicates x))))
revappendfunction
(defun revappend (x y) (declare (xargs :guard (true-listp x))) (if (endp x) y (revappend (cdr x) (cons (car x) y))))
true-listp-revappend-type-prescriptiontheorem
(defthm true-listp-revappend-type-prescription (implies (true-listp y) (true-listp (revappend x y))) :rule-classes :type-prescription)
character-listp-revappendtheorem
(defthm character-listp-revappend (implies (true-listp x) (equal (character-listp (revappend x y)) (and (character-listp x) (character-listp y)))) :hints (("Goal" :induct (revappend x y))))
reversefunction
(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))))
pairlis$-tailrecfunction
(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)))))
pairlis$function
(defun pairlis$ (x y) (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)))
pairlis$-tailrec-is-pairlis$theorem
(defthm pairlis$-tailrec-is-pairlis$ (implies (true-listp acc) (equal (pairlis$-tailrec x y acc) (revappend acc (pairlis$ x y)))))
other
(verify-guards pairlis$)
other
(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)))))
other
(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)))))
set-difference-equalfunction
(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)))))
set-difference-eqmacro
(defmacro set-difference-eq (l1 l2) `(set-difference$ ,L1 ,L2 :test 'eq))
set-difference-eq-exec-is-set-difference-equaltheorem
(defthm set-difference-eq-exec-is-set-difference-equal (equal (set-difference-eq-exec l1 l2) (set-difference-equal l1 l2)))
set-difference-eql-exec-is-set-difference-equaltheorem
(defthm set-difference-eql-exec-is-set-difference-equal (equal (set-difference-eql-exec l1 l2) (set-difference-equal l1 l2)))
set-difference$macro
(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 `(set-difference-equal ,L1 ,L2))))
*window-descriptions*constant
(defconst *window-descriptions* '((proof-tree "0" t t nil) (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) (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)))
*valid-output-names*constant
(defconst *valid-output-names* (set-difference-eq (strip-cars *window-descriptions*) '(temporary query)))
listpfunction
(defun listp (x) (declare (xargs :mode :logic :guard t)) (or (consp x) (equal x nil)))
*summary-types*constant
(defconst *summary-types* '(errors form header hint-events redundant rules splitter-rules steps system-attachments time value warnings))
with-evisc-tuplemacro
(defmacro with-evisc-tuple (form &key (term 'nil termp) (ld 'nil ldp) (abbrev 'nil abbrevp) (gag-mode 'nil gag-modep)) `(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)))
lastfunction
(defun last (l) (declare (xargs :guard (listp l))) (if (atom (cdr l)) l (last (cdr l))))
last-cdr-is-niltheorem
(defthm last-cdr-is-nil (implies (true-listp x) (equal (last-cdr x) nil)))
first-n-acfunction
(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)))))
true-listp-first-n-ac-type-prescriptiontheorem
(defthm true-listp-first-n-ac-type-prescription (true-listp (first-n-ac i l ac)) :rule-classes :type-prescription)
takefunction
(defun take (n l) (declare (xargs :guard (and (integerp n) (not (< n 0)) (true-listp l)) :verify-guards nil)) (mbe :logic (if (zp n) nil (cons (car l) (take (1- n) (cdr l)))) :exec (first-n-ac n l nil)))
butlastfunction
(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-guardpfunction
(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))) (member-eq (car (car rst)) '(defun defund defun-nx defund-nx)) (mutual-recursion-guardp (cdr rst))))))
collect-cadrs-when-car-member-eqfunction
(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)))))
legal-constantp1function
(defun legal-constantp1 (name) (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))) #\*)))))
value-triple-macro-fnfunction
(defun value-triple-macro-fn (form on-skip-proofs check safe-mode stobjs-out ctx) (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) (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)))))
value-triplemacro
(defmacro value-triple (form &key on-skip-proofs check (safe-mode ':same) (stobjs-out 'nil) (ctx ''value-triple)) (value-triple-macro-fn form on-skip-proofs check safe-mode stobjs-out ctx))
assert-eventmacro
(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))))
event-keyword-namefunction
(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))
event-keyword-name-lstfunction
(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)))))
other
(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))))
other
(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))))
add-to-set-equalfunction
(defun add-to-set-equal (x l) (declare (xargs :guard (true-listp l))) (cond ((member-equal x l) l) (t (cons x l))))
add-to-set-eqmacro
(defmacro add-to-set-eq (x lst) `(add-to-set ,X ,LST :test 'eq))
add-to-set-eqlmacro
(defmacro add-to-set-eql (x lst) `(add-to-set ,X ,LST :test 'eql))
add-to-set-eq-exec-is-add-to-set-equaltheorem
(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)))
add-to-set-eql-exec-is-add-to-set-equaltheorem
(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)))
in-theory
(in-theory (disable add-to-set-eq-exec add-to-set-eql-exec))
add-to-setmacro
(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 `(add-to-set-equal ,X ,LST))))
keyword-value-listpfunction
(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))))))
keyword-value-listp-forward-to-true-listptheorem
(defthm keyword-value-listp-forward-to-true-listp (implies (keyword-value-listp x) (true-listp x)) :rule-classes :forward-chaining)
throw-nonexec-errorfunction
(defun throw-nonexec-error (fn actuals) (declare (xargs :mode :logic :guard t) (ignore fn actuals)) nil)
evensfunction
(defun evens (l) (declare (xargs :guard (true-listp l))) (cond ((endp l) nil) (t (cons (car l) (evens (cddr l))))))
oddsfunction
(defun odds (l) (declare (xargs :guard (true-listp l))) (evens (cdr l)))
mv-nthfunction
(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)))))
make-mv-nthsfunction
(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))))))
mv?macro
(defmacro mv? (&rest l) (declare (xargs :guard l)) (cond ((null (cdr l)) (car l)) (t `(mv ,@L))))
mv-letmacro
(defmacro mv-let (&rest rst) (declare (xargs :guard (and (>= (length rst) 3) (true-listp (car rst)) (>= (length (car rst)) 2)))) (list* 'let (make-mv-nths (car rst) (list 'mv-list (length (car rst)) (cadr rst)) 0) (cddr rst)))
mv?-letmacro
(defmacro mv?-let (vars form &rest rst) (declare (xargs :guard (and (true-listp vars) vars))) (cond ((null (cdr vars)) `(let ((,(CAR VARS) ,FORM)) ,@RST)) (t `(mv-let ,VARS ,FORM ,@RST))))
legal-case-clausespfunction
(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)))
case-testfunction
(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)))))
case-listfunction
(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))))))
case-list-checkfunction
(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))))))
casemacro
(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)))))))
nonnegative-integer-quotientfunction
(defun nonnegative-integer-quotient (i j) (declare (xargs :guard (and (integerp i) (not (< i 0)) (integerp j) (< 0 j)))) (if (or (= (nfix j) 0) (< (ifix i) j)) 0 (+ 1 (nonnegative-integer-quotient (- i j) j))))
true-list-listpfunction
(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))))))
true-list-listp-forward-to-true-listptheorem
(defthm true-list-listp-forward-to-true-listp (implies (true-list-listp x) (true-listp x)) :rule-classes :forward-chaining)
legal-let*-pfunction
(defun legal-let*-p (bindings ignore-vars ignored-seen top-form) (declare (xargs :guard (and top-form (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))))
well-formed-type-decls-pfunction
(defun well-formed-type-decls-p (decls 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)))
symbol-list-listpfunction
(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))))))
get-type-declsfunction
(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)))))
let*-macrofunction
(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 (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))))))))
collect-cdrs-when-car-eqfunction
(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)))))
append-lstfunction
(defun append-lst (lst) (declare (xargs :guard (true-list-listp lst))) (cond ((endp lst) nil) (t (append (car lst) (append-lst (cdr lst))))))
restrict-alistfunction
(defun restrict-alist (keys alist) (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)))))
let*macro
(defmacro let* (&whole form bindings &rest decl-body) (declare (xargs :guard (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))))
other
(progn (defun floor (i j) (declare (xargs :guard (and (real/rationalp i) (real/rationalp j) (not (eql j 0))))) (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))))) (defun ceiling (i j) (declare (xargs :guard (and (real/rationalp i) (real/rationalp j) (not (eql j 0))))) (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)))))) (defun truncate (i j) (declare (xargs :guard (and (real/rationalp i) (real/rationalp j) (not (eql j 0))))) (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)))))) (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)))))))))) (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)) (defun plusp (x) (declare (xargs :mode :logic :guard (real/rationalp x))) (> x 0)) (defun minusp (x) (declare (xargs :mode :logic :guard (real/rationalp x))) (< x 0)) (defun min (x y) (declare (xargs :guard (and (real/rationalp x) (real/rationalp y)))) (if (< x y) x y)) (defun max (x y) (declare (xargs :guard (and (real/rationalp x) (real/rationalp y)))) (if (> x y) x y)) (defun abs (x) (declare (xargs :guard (real/rationalp x) :mode :logic)) (if (minusp x) (- x) x)) (defun signum (x) (declare (xargs :guard (real/rationalp x))) (if (zerop x) 0 (if (minusp x) -1 1))) (defun lognot (i) (declare (xargs :guard (integerp i))) (+ (- (ifix i)) -1)))
digit-to-charfunction
(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)))
print-base-pfunction
(defun print-base-p (print-base) (declare (xargs :guard t :mode :logic)) (and (member print-base '(2 8 10 16)) t))
explode-nonnegative-integerfunction
(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) '(#\0)) (t ans))) (t (explode-nonnegative-integer (floor n print-base) print-base (cons (digit-to-char (mod n print-base)) ans)))))
make-var-lst1function
(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)))))
make-var-lstfunction
(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))
nthcdrfunction
(defun nthcdr (n l) (declare (xargs :guard (and (integerp n) (<= 0 n) (true-listp l)))) (if (zp n) l (nthcdr (+ n -1) (cdr l))))
true-listp-nthcdr-type-prescriptiontheorem
(defthm true-listp-nthcdr-type-prescription (implies (true-listp x) (true-listp (nthcdr n x))) :rule-classes :type-prescription)
other
(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)))))
other
(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)))))
union-equalfunction
(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)))))
union-eq-exec-is-union-equaltheorem
(defthm union-eq-exec-is-union-equal (equal (union-eq-exec l1 l2) (union-equal l1 l2)))
union-eql-exec-is-union-equaltheorem
(defthm union-eql-exec-is-union-equal (equal (union-eql-exec l1 l2) (union-equal l1 l2)))
parse-args-and-testfunction
(defun parse-args-and-test (x tests default ctx form name) (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)))))
union-equal-with-union-eq-exec-guardmacro
(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))))
union-equal-with-union-eql-exec-guardmacro
(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))))
union$macro
(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 :logic ,(XXXJOIN 'UNION-EQUAL-WITH-UNION-EQ-EXEC-GUARD VARS) :exec ,(XXXJOIN 'UNION-EQ-EXEC VARS))) ((equal test ''eql) `(let-mbe ,BINDINGS :guardp nil :logic ,(XXXJOIN 'UNION-EQUAL-WITH-UNION-EQL-EXEC-GUARD VARS) :exec ,(XXXJOIN 'UNION-EQL-EXEC VARS))) (t (xxxjoin 'union-equal args))))))))
*xargs-keywords*constant
(defconst *xargs-keywords* '(:guard :guard-hints :guard-debug :guard-simplify :hints :measure :measure-debug :ruler-extenders :mode :non-executable :normalize :otf-flg :stobjs :dfs :verify-guards :well-founded-relation :split-types :loop$-recursion :type-prescription))
plausible-dclsp1function
(defun plausible-dclsp1 (lst) (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)))
plausible-dclspfunction
(defun plausible-dclsp (lst) (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)))
strip-keyword-listfunction
(defun strip-keyword-list (fields lst) (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)))))))
strip-dcls1function
(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)))))))))
strip-dclsfunction
(defun strip-dcls (fields lst) (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)))))))))
fetch-dcl-fields2function
(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)))))
fetch-dcl-fields1function
(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))))))
fetch-dcl-fieldsfunction
(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))))))
fetch-dcl-fieldfunction
(defun fetch-dcl-field (field-name lst) (declare (xargs :guard (and (symbolp field-name) (plausible-dclsp lst)))) (fetch-dcl-fields (list field-name) lst))
with-output-on-off-binding-valfunction
(defun with-output-on-off-binding-val (on off summary-p) (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 `',OFF))) ((eq off :all) `(set-difference-eq ,QCONST ',ON)) (t `(union-eq ',OFF (set-difference-eq (f-get-global ',GLOBAL state) ',ON))))))
with-output-on-off-argfunction
(defun with-output-on-off-arg (arg universe) (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)))
msgpfunction
(defun msgp (x) (declare (xargs :guard t)) (or (stringp x) (and (consp x) (stringp (car x)) (character-alistp (cdr x)))))
ctxpfunction
(defun ctxp (x) (declare (xargs :guard t)) (or (symbolp x) (and (consp x) (symbolp (car x))) (msgp x)))
with-output-fnfunction
(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) (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) (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)) (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 (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 (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))))))
with-output!-fnfunction
(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 (ILLEGAL 'WITH-OUTPUT "Macroexpansion of ~q0 failed." (LIST (CONS #\0 (CONS 'WITH-OUTPUT ARGS))))))))
with-output!macro
(defmacro with-output! (&rest args) (with-output!-fn args))
with-outputmacro
(defmacro with-output (&rest args) (with-output!-fn args))
defun-nx-dclsfunction
(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-nx-formfunction
(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-nx-fnfunction
(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 nil (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)))))))
defun-nxmacro
(defmacro defun-nx (&whole form &rest rest) (declare (xargs :guard (and (true-listp form) (true-listp (caddr form)))) (ignore rest)) (defun-nx-fn form))
defund-nxmacro
(defmacro defund-nx (&whole form &rest rest) (declare (xargs :guard (and (true-listp form) (true-listp (caddr form)))) (ignore rest)) (defun-nx-fn form))
update-mutual-recursion-for-defun-nx-1function
(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))))))
update-mutual-recursion-for-defun-nxfunction
(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)))
assoc-keywordfunction
(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)))))
program-declared-p2function
(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)))))
program-declared-p1function
(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)))))
program-declared-pfunction
(defun program-declared-p (def) (declare (xargs :guard (true-listp def) :mode :program)) (program-declared-p1 (butlast (cddr def) 1)))
some-program-declared-pfunction
(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))))))
pairlis-x1function
(defun pairlis-x1 (x1 lst) (declare (xargs :guard (true-listp lst))) (cond ((endp lst) nil) (t (cons (cons x1 (car lst)) (pairlis-x1 x1 (cdr lst))))))
pairlis-x2function
(defun pairlis-x2 (lst x2) (declare (xargs :guard (true-listp lst))) (cond ((endp lst) nil) (t (cons (cons (car lst) x2) (pairlis-x2 (cdr lst) x2)))))
mutual-recursionmacro
(defmacro mutual-recursion (&whole event-form &rest rst0) (declare (xargs :guard (mutual-recursion-guardp rst0))) (let ((rst (update-mutual-recursion-for-defun-nx rst0))) (let ((form (list 'defuns-fn (list 'quote (strip-cdrs rst)) 'state (list 'quote event-form)))) (cond ((or (and (assoc-eq 'defund rst0) (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)))))
nvariablepmacro
(defmacro nvariablep (x) (list 'consp x))
kwotefunction
(defun kwote (x) (declare (xargs :guard t)) (mbe :logic (list 'quote x) :exec (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)))))
maybe-kwotefunction
(defun maybe-kwote (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))))
kwote-lstfunction
(defun kwote-lst (lst) (declare (xargs :guard (true-listp lst))) (cond ((endp lst) nil) (t (cons (kwote (car lst)) (kwote-lst (cdr lst))))))
commutativity-2-of-+encapsulate
(encapsulate nil (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)))))
pseudo-termpmutual-recursion
(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)) (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)))))))
pseudo-term-listp-forward-to-true-listptheorem
(defthm pseudo-term-listp-forward-to-true-listp (implies (pseudo-term-listp x) (true-listp x)) :rule-classes :forward-chaining)
pseudo-termp-consp-forwardtheorem
(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)
encapsulate
(encapsulate nil (table acl2-defaults-table :defun-mode :logic) (verify-guards pseudo-termp))
pseudo-term-list-listpfunction
(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)))))
other
(verify-guards pseudo-term-list-listp)
lambda-object-formalsfunction
(defun lambda-object-formals (x) (declare (xargs :guard t)) (if (and (consp x) (consp (cdr x))) (cadr x) nil))
lambda-object-dclfunction
(defun lambda-object-dcl (x) (declare (xargs :guard t)) (cond ((and (consp x) (consp (cdr x)) (consp (cddr x)) (consp (cdddr x)) (null (cddddr x))) (caddr x)) (t nil)))
lambda-object-bodyfunction
(defun lambda-object-body (x) (declare (xargs :guard t)) (cond ((and (consp x) (consp (cdr x)) (consp (cddr x))) (cond ((atom (cdddr x)) (if (null (cdddr x)) (caddr x) nil)) ((null (cddddr x)) (cadddr x)) (t nil))) (t nil)))
lambda-object-shapepfunction
(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))))))
make-lambda-objectfunction
(defun make-lambda-object (formals dcl body) (declare (xargs :guard t)) `(lambda ,FORMALS ,@(IF DCL (LIST DCL) NIL) ,BODY))
fn-symbfunction
(defun fn-symb (x) (declare (xargs :guard t)) (if (and (nvariablep x) (not (fquotep x))) (car x) nil))
fargn1function
(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))))))
fargnmacro
(defmacro fargn (x n) (declare (xargs :guard (and (integerp n) (> n 0)))) (list 'car (fargn1 x n)))
all-vars1mutual-recursion
(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))))))
other
(verify-termination-boot-strap (all-vars1 (declare (xargs :mode :logic :verify-guards nil))) (all-vars1-lst (declare (xargs :mode :logic))))
all-varsfunction
(defun all-vars (term) (declare (xargs :guard (pseudo-termp term) :verify-guards nil)) (all-vars1 term nil))
translate-and-testmacro
(defmacro translate-and-test (test-fn form) (declare (ignore test-fn)) form)
other
(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))))
other
(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))))
intersectp-equalfunction
(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))))
intersectp-eqmacro
(defmacro intersectp-eq (x y) `(intersectp ,X ,Y :test 'eq))
intersectp-eq-exec-is-intersectp-equaltheorem
(defthm intersectp-eq-exec-is-intersectp-equal (equal (intersectp-eq-exec x y) (intersectp-equal x y)))
intersectp-eql-exec-is-intersectp-equaltheorem
(defthm intersectp-eql-exec-is-intersectp-equal (equal (intersectp-eql-exec x y) (intersectp-equal x y)))
intersectpmacro
(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 `(intersectp-equal ,X ,Y))))
chk-no-stobj-index-aliasingfunction
(defun chk-no-stobj-index-aliasing (producers others) (declare (xargs :guard (and (true-listp producers) (no-duplicatesp-equal producers) (true-listp others) (not (intersectp-equal producers others)))) (ignore producers others)) nil)
make-fmt-bindingsfunction
(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))))))
*base-10-chars*constant
(defconst *base-10-chars* '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
warning$macro
(defmacro warning$ (ctx summary str+ &rest fmt-args) (list 'warning1 ctx (if (consp summary) (kwote summary) summary) str+ (make-fmt-bindings *base-10-chars* fmt-args) 'state))
msgmacro
(defmacro msg (str &rest args) (declare (xargs :guard (<= (length args) 10))) `(cons ,STR ,(MAKE-FMT-BINDINGS *BASE-10-CHARS* ARGS)))
check-vars-not-free-testfunction
(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)))
check-vars-not-freemacro
(defmacro check-vars-not-free (vars form) (declare (xargs :guard (symbol-listp vars))) (cond ((null vars) form) (t `(translate-and-test (lambda (term) (check-vars-not-free-test ',VARS term)) ,FORM))))
er-progn-fnfunction
(defun er-progn-fn (lst) (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) '(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))))))))
er-prognmacro
(defmacro er-progn (&rest lst) (declare (xargs :guard (and (true-listp lst) lst))) (er-progn-fn lst))
other
(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)))))
natp-position-ac-eq-exectheorem
(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)
other
(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)))))
natp-position-ac-eql-exectheorem
(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)
position-equal-acfunction
(defun position-equal-ac (item lst acc) (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)))))
natp-position-equal-actheorem
(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)
position-ac-equalmacro
(defmacro position-ac-equal (item lst acc) `(position-equal-ac ,ITEM ,LST ,ACC))
position-eq-acmacro
(defmacro position-eq-ac (item lst acc) `(position-ac ,ITEM ,LST ,ACC :test 'eq))
position-ac-eqmacro
(defmacro position-ac-eq (item lst acc) `(position-ac ,ITEM ,LST ,ACC :test 'eq))
position-ac-eq-exec-is-position-equal-actheorem
(defthm position-ac-eq-exec-is-position-equal-ac (equal (position-ac-eq-exec item lst acc) (position-equal-ac item lst acc)))
position-ac-eql-exec-is-position-equal-actheorem
(defthm position-ac-eql-exec-is-position-equal-ac (equal (position-ac-eql-exec item lst acc) (position-equal-ac item lst acc)))
position-acmacro
(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 `(position-equal-ac ,ITEM ,LST ,ACC))))
other
(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))
other
(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)))
position-equalfunction
(defun position-equal (x seq) (declare (xargs :guard (or (stringp seq) (true-listp seq)))) (if (stringp seq) (position-ac x (coerce seq 'list) 0) (position-equal-ac x seq 0)))
position-eqmacro
(defmacro position-eq (item lst) `(position ,ITEM ,LST :test 'eq))
position-eq-exec-is-position-equaltheorem
(defthm position-eq-exec-is-position-equal (implies (not (stringp lst)) (equal (position-eq-exec item lst) (position-equal item lst))))
position-eql-exec-is-position-equaltheorem
(defthm position-eql-exec-is-position-equal (equal (position-eql-exec item lst) (position-equal item lst)))
positionmacro
(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 `(position-equal ,X ,SEQ))))
other
(progn (defun expt (r i) (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)))
expt-type-prescription-non-zero-basetheorem
(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)
rationalp-expt-type-prescriptiontheorem
(defthm rationalp-expt-type-prescription (implies (rationalp r) (rationalp (expt r i))) :rule-classes :type-prescription)
other
(verify-termination-boot-strap logbitp)
other
(verify-termination-boot-strap ash)
char-code-linearaxiom
(defaxiom char-code-linear (< (char-code x) 256) :rule-classes :linear)
code-char-typeaxiom
(defaxiom code-char-type (characterp (code-char n)) :rule-classes :type-prescription)
code-char-char-code-is-identityaxiom
(defaxiom code-char-char-code-is-identity (implies (characterp c) (equal (code-char (char-code c)) c)))
char-code-code-char-is-identityaxiom
(defaxiom char-code-code-char-is-identity (implies (and (integerp n) (<= 0 n) (< n 256)) (equal (char-code (code-char n)) n)))
char<function
(defun char< (x y) (declare (xargs :guard (and (characterp x) (characterp y)))) (< (char-code x) (char-code y)))
char>function
(defun char> (x y) (declare (xargs :guard (and (characterp x) (characterp y)))) (> (char-code x) (char-code y)))
char<=function
(defun char<= (x y) (declare (xargs :guard (and (characterp x) (characterp y)))) (<= (char-code x) (char-code y)))
char>=function
(defun char>= (x y) (declare (xargs :guard (and (characterp x) (characterp y)))) (>= (char-code x) (char-code y)))
string<-lfunction
(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)))
string<function
(defun string< (str1 str2) (declare (xargs :guard (and (stringp str1) (stringp str2)))) (string<-l (coerce str1 'list) (coerce str2 'list) 0))
string>function
(defun string> (str1 str2) (declare (xargs :guard (and (stringp str1) (stringp str2)))) (string< str2 str1))
string<=function
(defun string<= (str1 str2) (declare (xargs :guard (and (stringp str1) (stringp str2)))) (if (equal str1 str2) (length str1) (string< str1 str2)))
string>=function
(defun string>= (str1 str2) (declare (xargs :guard (and (stringp str1) (stringp str2)))) (if (equal str1 str2) (length str1) (string> str1 str2)))
symbol<function
(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))))))
string<-l-irreflexivetheorem
(defthm string<-l-irreflexive (not (string<-l x x i)))
string<-irreflexivetheorem
(defthm string<-irreflexive (not (string< s s)))
substitute-acfunction
(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)))))
substitutefunction
(defun substitute (new old seq) (declare (xargs :guard (or (and (stringp seq) (characterp new)) (and (true-listp seq) (or (eqlablep old) (eqlable-listp seq)))) :verify-guards nil)) (if (stringp seq) (coerce (substitute-ac new old (coerce seq 'list) nil) 'string) (substitute-ac new old seq nil)))
stringp-substitute-type-prescriptiontheorem
(defthm stringp-substitute-type-prescription (implies (stringp seq) (stringp (substitute new old seq))) :rule-classes :type-prescription)
true-listp-substitute-type-prescriptiontheorem
(defthm true-listp-substitute-type-prescription (implies (not (stringp seq)) (true-listp (substitute new old seq))) :rule-classes :type-prescription)
sublisfunction
(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))))))
substfunction
(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))))))
pprognmacro
(defmacro pprogn (&rest lst) (declare (xargs :guard (and lst (true-listp lst)))) (cond ((endp (cdr lst)) (car lst)) (t (list 'let (list (list 'state (car lst))) (cons 'pprogn (cdr lst))))))
progn$macro
(defmacro progn$ (&rest rst) (cond ((null rst) nil) ((null (cdr rst)) (car rst)) (t (xxxjoin 'prog2$ rst))))
acl2-unwind-protectmacro
(defmacro acl2-unwind-protect (expl body cleanup1 cleanup2) (declare (ignore expl)) (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)))))))))
when-logicmacro
(defmacro when-logic (str x) (list 'if '(eq (default-defun-mode-from-state state) :program) (list 'skip-when-logic (list 'quote str) 'state) x))
in-packagemacro
(defmacro in-package (str) (list 'in-package-fn (list 'quote str) 'state))
defpkgmacro
(defmacro defpkg (&whole event-form name form &optional doc book-path hidden-p) (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)))
defunmacro
(defmacro defun (&whole event-form &rest def) (list 'defun-fn (list 'quote def) 'state (list 'quote event-form)))
defunsmacro
(defmacro defuns (&whole event-form &rest def-lst) (list 'defuns-fn (list 'quote def-lst) 'state (list 'quote event-form)))
verify-terminationmacro
(defmacro verify-termination (&rest lst) `(make-event (verify-termination-fn ',LST state)))
verify-termination-boot-strapmacro
(defmacro verify-termination-boot-strap (&whole event-form &rest lst) (list 'verify-termination-boot-strap-fn (list 'quote lst) 'state (list 'quote event-form)))
verify-guardsmacro
(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) (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)))
verify-guards+macro
(defmacro verify-guards+ (name &rest rest) `(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)))
defmacromacro
(defmacro defmacro (&whole event-form &rest mdef) (list 'defmacro-fn (list 'quote mdef) 'state (list 'quote event-form)))
defconstmacro
(defmacro defconst (&whole event-form name form) (list 'defconst-fn (list 'quote name) (list 'quote form) 'state (list 'quote event-form)))
defthmmacro
(defmacro defthm (&whole event-form name term &key (rule-classes '(:rewrite)) instructions hints otf-flg) (list 'defthm-fn (list 'quote name) (list 'quote term) 'state (list 'quote rule-classes) (list 'quote instructions) (list 'quote hints) (list 'quote otf-flg) (list 'quote event-form)))
ermacro
(defmacro er (severity context str &rest str-args) (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 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!") (list 'illegal context str alist)) ((equal severity-name "HARD?!") (list 'hard-error context str alist)) (t (illegal 'top-level "Illegal severity, ~x0; macroexpansion of ER failed!" (list (cons #\0 severity)))))))
defthmd-fnfunction
(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 :on 'error (list 'progn (list 'with-output :stack :pop (cons 'defthm (cdr event-form))) (list 'with-output :stack :pop :off 'summary (list 'in-theory (list 'disable name))) (list 'value-triple (list 'quote (event-keyword-name 'defthmd name)) :on-skip-proofs t)))))))
defthmdmacro
(defmacro defthmd (&whole event-form name term &rest rst) (declare (xargs :guard t) (ignore term)) (defthmd-fn event-form name rst))
defaxiommacro
(defmacro defaxiom (&whole event-form name term &key (rule-classes '(:rewrite))) (list 'defaxiom-fn (list 'quote name) (list 'quote term) 'state (list 'quote rule-classes) (list 'quote event-form)))
deflabelmacro
(defmacro deflabel (&whole event-form name) (list 'deflabel-fn (list 'quote name) 'state (list 'quote event-form)))
deftheorymacro
(defmacro deftheory (&whole event-form name expr &key redundant-okp ctx) (list 'deftheory-fn (list 'quote name) (list 'quote expr) 'state (list 'quote redundant-okp) (list 'quote ctx) (list 'quote event-form)))
defthymacro
(defmacro defthy (name &rest args) `(deftheory ,NAME ,@ARGS :redundant-okp t :ctx (defthy . ,NAME)))
deftheory-staticmacro
(defmacro deftheory-static (name theory) `(make-event (let ((world (w state))) (declare (ignorable world)) (list 'deftheory ',NAME (list 'quote ,THEORY)))))
defstobjmacro
(defmacro defstobj (&whole event-form name &rest args) (list 'defstobj-fn (list 'quote name) (list 'quote args) 'state (list 'quote event-form)))
in-theorymacro
(defmacro in-theory (&whole event-form expr) (list 'in-theory-fn (list 'quote expr) 'state (list 'quote event-form)))
in-arithmetic-theorymacro
(defmacro in-arithmetic-theory (&whole event-form expr) (list 'in-arithmetic-theory-fn (list 'quote expr) 'state (list 'quote event-form)))
regenerate-tau-databasemacro
(defmacro regenerate-tau-database (&whole event-form) (list 'regenerate-tau-database-fn 'state (list 'quote event-form)))
push-untouchablemacro
(defmacro push-untouchable (&whole event-form name fn-p) (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)))
remove-untouchablemacro
(defmacro remove-untouchable (&whole event-form name fn-p) (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)))))
set-bodymacro
(defmacro set-body (&whole event-form fn name-or-rune) `(set-body-fn ',FN ',NAME-OR-RUNE state ',EVENT-FORM))
tablemacro
(defmacro table (&whole event-form name &rest args) (list 'table-fn (list 'quote name) (list 'quote args) 'state (list 'quote event-form)))
encapsulatemacro
(defmacro encapsulate (&whole event-form signatures &rest cmd-lst) (list 'encapsulate-fn (list 'quote signatures) (list 'quote cmd-lst) 'state (list 'quote event-form)))
partial-encapsulatemacro
(defmacro partial-encapsulate (sigs supporters &rest cmd-lst) (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)))))
*load-compiled-file-values*constant
(defconst *load-compiled-file-values* '(t nil :warn :default :comp))
include-bookmacro
(defmacro include-book (&whole event-form user-book-name &key (load-compiled-file ':default) (uncertified-okp 't) (defaxioms-okp 't) (skip-proofs-okp 't) (ttags ':default) dir) (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)))
make-eventmacro
(defmacro make-event (&whole event-form form &key expansion? check-expansion on-behalf-of save-event-data) (declare (xargs :guard t)) `(make-event-fn ',FORM ',EXPANSION? ',CHECK-EXPANSION ',ON-BEHALF-OF ',SAVE-EVENT-DATA ',EVENT-FORM state))
record-expansionmacro
(defmacro record-expansion (x y) (declare (ignore x)) y)
skip-proofsmacro
(defmacro skip-proofs (x) `(state-global-let* ((ld-skip-proofsp (or (f-get-global 'ld-skip-proofsp state) t)) (inside-skip-proofs t)) ,X))
localmacro
(defmacro local (x) (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))))
defchoosemacro
(defmacro defchoose (&whole event-form &rest def) (list 'defchoose-fn (list 'quote def) 'state (list 'quote event-form)))
defattachmacro
(defmacro defattach (&whole event-form &rest args) (list 'defattach-fn (list 'quote args) 'state (list 'quote event-form)))
other
(deflabel worldp)
plist-worldpfunction
(defun plist-worldp (alist) (declare (xargs :guard 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))))))
plist-worldp-forward-to-assoc-eq-equal-alistptheorem
(defthm plist-worldp-forward-to-assoc-eq-equal-alistp (implies (plist-worldp x) (assoc-eq-equal-alistp x)) :rule-classes :forward-chaining)
putpropfunction
(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))
*acl2-property-unbound*constant
(defconst *acl2-property-unbound* :acl2-property-unbound)
getprop-defaultfunction
(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))
fgetpropfunction
(defun fgetprop (symb key default world-alist) (declare (xargs :guard (and (symbolp symb) (symbolp key) (plist-worldp world-alist)))) (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)))))
sgetpropfunction
(defun sgetprop (symb key default world-name world-alist) (declare (xargs :guard (and (symbolp symb) (symbolp key) (symbolp world-name) (plist-worldp world-alist)))) (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)))))
ordered-symbol-alistpfunction
(defun ordered-symbol-alistp (x) (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))))))
ordered-symbol-alistp-forward-to-symbol-alistptheorem
(defthm ordered-symbol-alistp-forward-to-symbol-alistp (implies (ordered-symbol-alistp x) (symbol-alistp x)) :rule-classes :forward-chaining)
add-pairfunction
(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))))))
other
(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))))))
other
(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))))))
remove1-assoc-equalfunction
(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))))))
remove1-assoc-eqmacro
(defmacro remove1-assoc-eq (key lst) `(remove1-assoc ,KEY ,LST :test 'eq))
remove1-assoc-eq-exec-is-remove1-assoc-equaltheorem
(defthm remove1-assoc-eq-exec-is-remove1-assoc-equal (equal (remove1-assoc-eq-exec key lst) (remove1-assoc-equal key lst)))
remove1-assoc-eql-exec-is-remove1-assoc-equaltheorem
(defthm remove1-assoc-eql-exec-is-remove1-assoc-equal (equal (remove1-assoc-eql-exec key lst) (remove1-assoc-equal key lst)))
remove1-assocmacro
(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 `(remove1-assoc-equal ,KEY ,ALIST))))
other
(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))))))
other
(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))))))
remove-assoc-equalfunction
(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))))))
remove-assoc-eqmacro
(defmacro remove-assoc-eq (x lst) `(remove-assoc ,X ,LST :test 'eq))
remove-assoc-eq-exec-is-remove-assoc-equaltheorem
(defthm remove-assoc-eq-exec-is-remove-assoc-equal (equal (remove-assoc-eq-exec x l) (remove-assoc-equal x l)))
remove-assoc-eql-exec-is-remove-assoc-equaltheorem
(defthm remove-assoc-eql-exec-is-remove-assoc-equal (equal (remove-assoc-eql-exec x l) (remove-assoc-equal x l)))
remove-assocmacro
(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 `(remove-assoc-equal ,X ,ALIST))))
getprops1function
(defun getprops1 (alist) (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))))))
getpropsfunction
(defun getprops (symb world-name world-alist) (declare (xargs :guard (and (symbolp symb) (symbolp world-name) (plist-worldp world-alist)) :mode :program)) (cond ((endp world-alist) 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)))))
other
(verify-termination-boot-strap getprops (declare (xargs :mode :logic :verify-guards nil)))
equal-char-codetheorem
(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))))))
has-propsp1function
(defun has-propsp1 (alist exceptions 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)))
has-propspfunction
(defun has-propsp (symb exceptions world-name world-alist known-unbound) (declare (xargs :guard (and (symbolp symb) (symbolp world-name) (plist-worldp world-alist) (true-listp exceptions) (true-listp known-unbound)))) (cond ((endp world-alist) 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)))
extend-worldfunction
(defun extend-world (name wrld) (declare (xargs :guard t) (ignore name)) wrld)
retract-worldfunction
(defun retract-world (name wrld) (declare (xargs :guard t) (ignore name)) wrld)
global-valfunction
(defun global-val (var wrld) (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))
function-symbolpfunction
(defun function-symbolp (sym wrld) (declare (xargs :guard (and (symbolp sym) (plist-worldp wrld)))) (not (eq (getpropc sym 'formals t wrld) t)))
fcons-term*macro
(defmacro fcons-term* (&rest x) (cons 'list x))
conjoin2function
(defun conjoin2 (t1 t2) (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*))))
conjoinfunction
(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))))))
conjoin-untranslated-termsfunction
(defun conjoin-untranslated-terms (l) (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)))))))
disjoin2function
(defun disjoin2 (t1 t2) (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))))
disjoinfunction
(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))))))
disjoin-lstfunction
(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))))))
conjoin?function
(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))))
<=?function
(defun <=? (tflg x y) (declare (xargs :guard t)) (if tflg `(not (< ,Y ,X)) `(<= ,X ,Y)))
disjoin?function
(defun disjoin? (tflg lst) (declare (xargs :guard (true-listp lst))) (cond (tflg (or-macro lst)) ((null lst) nil) ((null (cdr lst)) (car lst)) (t (cons 'or lst))))
translate-declaration-to-guard/integer-genfunction
(defun translate-declaration-to-guard/integer-gen (lo var hi 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 (conjoin? tflg (list (list 'integerp var) (<=? tflg (kwote? tflg lower-bound) var) (<=? tflg var (kwote? tflg upper-bound))))))))) (t nil))))
translate-declaration-to-guard/integerfunction
(defun translate-declaration-to-guard/integer (lo var hi) (declare (xargs :guard t :mode :program)) (translate-declaration-to-guard/integer-gen lo var hi nil))
weak-satisfies-type-spec-pfunction
(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))))
translate-declaration-to-guard1-genfunction
(defun translate-declaration-to-guard1-gen (x var tflg wrld) (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) ''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) (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)))
translate-declaration-to-guard1function
(defun translate-declaration-to-guard1 (x var wrld) (declare (xargs :guard (or (symbolp wrld) (plist-worldp wrld)) :mode :program)) (translate-declaration-to-guard1-gen x var nil wrld))
translate-declaration-to-guard-genmutual-recursion
(mutual-recursion (defun translate-declaration-to-guard-gen (x var tflg wrld) (declare (xargs :guard (or (symbolp wrld) (plist-worldp wrld)) :mode :program)) (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) (declare (xargs :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))))))))))
translate-declaration-to-guardfunction
(defun translate-declaration-to-guard (x var wrld) (declare (xargs :guard (or (symbolp wrld) (plist-worldp wrld)) :mode :program)) (translate-declaration-to-guard-gen x var nil wrld))
translate-declaration-to-guard-lstfunction
(defun translate-declaration-to-guard-lst (l var wrld) (declare (xargs :guard (and (true-listp l) (consp l) (or (null wrld) (plist-worldp wrld))) :mode :program)) (translate-declaration-to-guard-gen-lst l var nil wrld))
the-checkfunction
(defun the-check (guard x y) (declare (xargs :guard guard)) (declare (ignore x guard)) y)
the-fnfunction
(defun the-fn (x y) (declare (xargs :guard (translate-declaration-to-guard x 'var nil) :mode :program)) (let ((guard (translate-declaration-to-guard x 'var nil))) (cond ((null guard) (illegal nil "Illegal-type: ~x0." (list (cons #\0 x)))) (t `(let ((var ,Y)) (declare (type (or t ,X) var)) (the-check ,GUARD ',X var))))))
themacro
(defmacro the (x y) (declare (xargs :guard (translate-declaration-to-guard x 'var nil))) (if (eq x 'double-float) y (the-fn x y)))
the-check-for-*1*function
(defun the-check-for-*1* (guard x y var) (declare (xargs :guard guard)) (declare (ignore x guard var)) y)
the-fn-for-*1*function
(defun the-fn-for-*1* (x y) (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)))
the-for-*1*macro
(defmacro the-for-*1* (x y) (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)))
*fixnum-bits*constant
(defconst *fixnum-bits* 61)
*fixnat-bits*constant
(defconst *fixnat-bits* (1- *fixnum-bits*))
*fixnum-type*constant
(defconst *fixnum-type* `(signed-byte ,*FIXNUM-BITS*))
the-fixnummacro
(defmacro the-fixnum (n) (list 'the *fixnum-type* n))
fixnum-boundmacro
(defmacro fixnum-bound nil (1- (expt 2 *fixnat-bits*)))
fixnat-alistpfunction
(defun fixnat-alistp (x) (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))))))
fixnat-alistp-forward-to-nat-alistptheorem
(defthm fixnat-alistp-forward-to-nat-alistp (implies (fixnat-alistp x) (nat-alistp x)) :rule-classes :forward-chaining)
array-maximum-length-boundmacro
(defmacro array-maximum-length-bound nil (fixnum-bound))
*array-maximum-length-bound*constant
(defconst *array-maximum-length-bound* (array-maximum-length-bound))
bounded-integer-alistpfunction
(defun bounded-integer-alistp (l 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)))))))
bounded-integer-alistp-forward-to-eqlable-alistptheorem
(defthm bounded-integer-alistp-forward-to-eqlable-alistp (implies (bounded-integer-alistp x n) (eqlable-alistp x)) :rule-classes :forward-chaining)
keyword-value-listp-assoc-keywordtheorem
(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)))))
consp-assoc-equaltheorem
(defthm consp-assoc-equal (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)))))
f-get-globalmacro
(defmacro f-get-global (x st) (list 'get-global x st))
array1pfunction
(defun array1p (name l) (declare (xargs :guard t)) (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))))))))
array1p-forwardtheorem
(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)
array1p-lineartheorem
(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)))
bounded-integer-alistp2function
(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)))))
assoc2function
(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)))))
array2pfunction
(defun array2p (name l) (declare (xargs :guard t)) (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)))))))))
array2p-forwardtheorem
(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)
array2p-lineartheorem
(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)))
headerfunction
(defun header (name l) (declare (xargs :guard (or (array1p name l) (array2p name l)))) (prog2$ name (assoc-eq :header l)))
dimensionsfunction
(defun dimensions (name l) (declare (xargs :guard (or (array1p name l) (array2p name l)))) (cadr (assoc-keyword :dimensions (cdr (header name l)))))
maximum-lengthfunction
(defun maximum-length (name l) (declare (xargs :guard (or (array1p name l) (array2p name l)))) (cadr (assoc-keyword :maximum-length (cdr (header name l)))))
defaultfunction
(defun default (name l) (declare (xargs :guard (or (array1p name l) (array2p name l)))) (cadr (assoc-keyword :default (cdr (header name l)))))
aref1function
(defun aref1 (name l n) (declare (xargs :guard (and (array1p name l) (integerp n) (>= n 0) (< n (car (dimensions name l)))))) (let ((x (and (not (eq n :header)) (assoc n l)))) (cond ((null x) (default name l)) (t (cdr x)))))
compress11function
(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))))))))
array-orderfunction
(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 '<))))
compress1function
(defun compress1 (name l) (declare (xargs :guard (array1p name l))) (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))))
array1p-constheorem
(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))))
aset1function
(defun aset1 (name l n val) (declare (xargs :guard (and (array1p name l) (integerp n) (>= n 0) (< n (car (dimensions name l)))))) (let ((l (cons (cons n val) l))) (cond ((> (length l) (maximum-length name l)) (compress1 name l)) (t l))))
aset1-trustedfunction
(defun aset1-trusted (name l n val) (declare (xargs :guard (and (array1p name l) (integerp n) (>= n 0) (< n (car (dimensions name l)))))) (aset1 name l n val))
aref2function
(defun aref2 (name l i j) (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)))))) (let ((x (assoc2 i j l))) (cond ((null x) (default name l)) (t (cdr x)))))
compress211function
(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))))))))
compress21function
(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)))))
compress2function
(defun compress2 (name l) (declare (xargs :guard (array2p name l))) (cons (header name l) (compress21 name l 0 (car (dimensions name l)) (cadr (dimensions name l)) (default name l))))
array2p-constheorem
(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))))
aset2function
(defun aset2 (name l i j val) (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)))))) (let ((l (cons (cons (cons i j) val) l))) (cond ((> (length l) (maximum-length name l)) (compress2 name l)) (t l))))
flush-compressfunction
(defun flush-compress (name) (declare (xargs :guard t)) (declare (ignore name)) nil)
maybe-flush-and-compress1function
(defun maybe-flush-and-compress1 (name ar) (declare (xargs :guard (array1p name ar))) (compress1 name ar))
cdrnfunction
(defun cdrn (x i) (declare (xargs :guard (and (integerp i) (<= 0 i)))) (cond ((zp i) x) (t (cdrn (list 'cdr x) (- i 1)))))
mv-listfunction
(defun mv-list (input-arity x) (declare (xargs :guard t :mode :logic) (ignore input-arity)) x)
live-stobjpmacro
(defmacro live-stobjp (name) `(or (and (typep ,NAME 'vector) (not (stringp ,NAME))) (typep ,NAME 'hash-table)))
swap-stobjsmacro
(defmacro swap-stobjs (x y) `(progn$ (mv ,Y ,X)))
update-nthfunction
(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))))))
update-nth-arrayfunction
(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))
acl2-number-listpfunction
(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))))))
acl2-number-listp-forward-to-true-listptheorem
(defthm acl2-number-listp-forward-to-true-listp (implies (acl2-number-listp x) (true-listp x)) :rule-classes :forward-chaining)
rational-listpfunction
(defun rational-listp (l) (declare (xargs :guard t)) (cond ((atom l) (eq l nil)) (t (and (rationalp (car l)) (rational-listp (cdr l))))))
rational-listp-forward-to-acl2-number-listptheorem
(defthm rational-listp-forward-to-acl2-number-listp (implies (rational-listp x) (acl2-number-listp x)) :rule-classes :forward-chaining)
integer-listpfunction
(defun integer-listp (l) (declare (xargs :guard t)) (cond ((atom l) (eq l nil)) (t (and (integerp (car l)) (integer-listp (cdr l))))))
integer-listp-forward-to-rational-listptheorem
(defthm integer-listp-forward-to-rational-listp (implies (integer-listp x) (rational-listp x)) :rule-classes :forward-chaining)
nat-listpfunction
(defun nat-listp (l) (declare (xargs :guard t)) (cond ((atom l) (eq l nil)) (t (and (natp (car l)) (nat-listp (cdr l))))))
nat-listp-forward-to-integer-listptheorem
(defthm nat-listp-forward-to-integer-listp (implies (nat-listp x) (integer-listp x)) :rule-classes :forward-chaining)
open-input-channelsfunction
(defun open-input-channels (st) (declare (xargs :guard (true-listp st))) (nth 0 st))
update-open-input-channelsfunction
(defun update-open-input-channels (x st) (declare (xargs :guard (true-listp st))) (update-nth 0 x st))
open-output-channelsfunction
(defun open-output-channels (st) (declare (xargs :guard (true-listp st))) (nth 1 st))
update-open-output-channelsfunction
(defun update-open-output-channels (x st) (declare (xargs :guard (true-listp st))) (update-nth 1 x st))
global-tablefunction
(defun global-table (st) (declare (xargs :guard (true-listp st))) (nth 2 st))
update-global-tablefunction
(defun update-global-table (x st) (declare (xargs :guard (true-listp st))) (update-nth 2 x st))
idatesfunction
(defun idates (st) (declare (xargs :guard (true-listp st))) (nth 3 st))
update-idatesfunction
(defun update-idates (x st) (declare (xargs :guard (true-listp st))) (update-nth 3 x st))
acl2-oraclefunction
(defun acl2-oracle (st) (declare (xargs :guard (true-listp st))) (nth 4 st))
update-acl2-oraclefunction
(defun update-acl2-oracle (x st) (declare (xargs :guard (true-listp st))) (update-nth 4 x st))
file-clockfunction
(defun file-clock (st) (declare (xargs :guard (true-listp st))) (nth 5 st))
update-file-clockfunction
(defun update-file-clock (x st) (declare (xargs :guard (true-listp st))) (update-nth 5 x st))
readable-filesfunction
(defun readable-files (st) (declare (xargs :guard (true-listp st))) (nth 6 st))
written-filesfunction
(defun written-files (st) (declare (xargs :guard (true-listp st))) (nth 7 st))
update-written-filesfunction
(defun update-written-files (x st) (declare (xargs :guard (true-listp st))) (update-nth 7 x st))
read-filesfunction
(defun read-files (st) (declare (xargs :guard (true-listp st))) (nth 8 st))
update-read-filesfunction
(defun update-read-files (x st) (declare (xargs :guard (true-listp st))) (update-nth 8 x st))
writeable-filesfunction
(defun writeable-files (st) (declare (xargs :guard (true-listp st))) (nth 9 st))
user-stobj-alist1function
(defun user-stobj-alist1 (st) (declare (xargs :guard (true-listp st))) (nth 10 st))
update-user-stobj-alist1function
(defun update-user-stobj-alist1 (x st) (declare (xargs :guard (true-listp st))) (update-nth 10 x st))
*initial-checkpoint-processors*constant
(defconst *initial-checkpoint-processors* '(eliminate-destructors-clause fertilize-clause generalize-clause eliminate-irrelevance-clause push-clause :induct))
*initial-program-fns-with-raw-code*constant
(defconst *initial-program-fns-with-raw-code* '(relieve-hyp-synp ev-w-lst simplify-clause1 ev-rec-acl2-unwind-protect allocate-fixnum-range trace$-fn-general ev-fncall! open-trace-file-fn set-trace-evisc-tuple ev-fncall-w-body ev-rec setup-simplify-clause-pot-lst1 save-exec-fn cw-gstack-fn recompress-global-enabled-structure ev-w verbose-pstack comp-fn acl2-raw-eval pstack-fn dmr-start-fn ev-fncall-meta ld-loop print-summary ev ev-lst allegro-allocate-slowly-fn certify-book-step-3+ certify-book-fn translate11-local-def include-book-fn1 include-book-fn set-w prove-loop chk-virgin-msg w-of-any-state ld-fn-body untranslate longest-common-tail-length-rec compile-function untranslate-lst ev-synp add-polys dmr-stop-fn ld-print-results close-trace-file-fn ev-fncall-rec ev-fncall ld-fn0 ld-fn write-expansion-file latch-stobjs1 chk-package-reincarnation-import-restrictions untrace$-fn1 bdd-top defstobj-field-fns-raw-defs times-mod-m31 prove 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 waterfall1-wrapper@par-before waterfall1-wrapper@par-after increment-waterfall-parallelism-counter flush-waterfall-parallelism-hashtables clear-current-waterfall-parallelism-ht setup-waterfall-parallelism-ht-for-name set-waterfall-parallelism-fn 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 fchecksum-obj2 check-sum-obj verify-guards-fn1 ev-fncall+-w extend-current-theory defstobj-fn apply-user-stobj-alist-or-kwote accp-info read-file-iterate-safe set-cbd-fn1 read-hons-copy-lambda-object-culprit defstobj-field-fns-raw-defs chk-certificate-file get-cert-obj-and-cert-filename include-book-raw-error add-global-stobj remove-global-stobj translate-stobj-type-to-guard chk-acceptable-defuns-redundancy))
*initial-logic-fns-with-raw-code*constant
(defconst *initial-logic-fns-with-raw-code* '(mod-expt header search-fn state-p1 aref2 aref1 fgetprop getenv$ wormhole-eval wormhole1 get-persistent-whs sync-ephemeral-whs-with-persistent-whs aset2 sgetprop setenv$ getprops compress1 time-limit5-reached-p fmt-to-comment-window fmt-to-comment-window! fmt-to-comment-window+ fmt-to-comment-window!+ len cpu-core-count nonnegative-integer-quotient check-print-base retract-world aset1 array1p boole$ array2p strip-cdrs compress2 strip-cars plist-worldp plist-worldp-with-formals wormhole-p may-need-slashes-fn has-propsp hard-error abort! p! flush-compress maybe-flush-and-compress1 alphorder extend-world default-total-parallelism-work-limit 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 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 random$ throw-nonexec-error gc$-fn set-compiler-enabled good-bye-fn take file-write-date$ print-call-history set-debugger-enable-fn 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 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 sys-call sys-call+ sys-call* canonical-pathname doppelganger-badge-userfn doppelganger-apply$-userfn ev-fncall-w-guard1 print-cl-cache-fn mfc-ancestors mfc-clause mfc-rdepth mfc-type-alist mfc-unify-subst mfc-world mfc-ap-fn mfc-relieve-hyp-fn mfc-relieve-hyp-ttree mfc-rw+-fn mfc-rw+-ttree mfc-rw-fn mfc-rw-ttree mfc-ts-fn mfc-ts-ttree magic-ev-fncall never-memoize-fn big-n zp-big-n decrement-big-n 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 apply$-lambda apply$-prim ilks-plist-worldp brr-evisc-tuple-oracle-update iprint-oracle-updates iprint-ar-aref1 brr-near-missp 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))
*initial-macros-with-raw-code*constant
(defconst *initial-macros-with-raw-code* '(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-constraint-tracking set-default-backchain-limit set-state-ok set-subgoal-loop-limits 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 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 por pand plet pargs spec-mv-let trace! with-live-state with-output-object-channel-sharing with-hcomp-bindings with-hcomp-ht-bindings with-hcomp-bindings-encapsulate switch-hcomp-status-encapsulate with-hcomp-bindings-protected-eval 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 deflock f-put-global@par set-waterfall-parallelism with-prover-step-limit waterfall1-wrapper@par with-waterfall-parallelism-timings with-parallelism-hazard-warnings warn-about-parallelism-hazard with-ensured-parallelism-finishing state-global-let* 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 swap-stobjs))
untouchable-markerfunction
(defun untouchable-marker (mac) (declare (ignore mac) (xargs :guard t)) t)
defmacro-untouchablemacro
(defmacro defmacro-untouchable (mac args &rest rest) (declare (xargs :guard (and (symbolp mac) (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))))
other
(defmacro-untouchable with-live-state (form) form)
init-iprint-arfunction
(defun init-iprint-ar (hard-bound enabledp) (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))))))
*iprint-soft-bound-default*constant
(defconst *iprint-soft-bound-default* 1000)
*iprint-hard-bound-default*constant
(defconst *iprint-hard-bound-default* 10000)
default-total-parallelism-work-limitfunction
(defun default-total-parallelism-work-limit nil (declare (xargs :guard t)) (let ((val 8000)) val))
*fmt-soft-right-margin-default*constant
(defconst *fmt-soft-right-margin-default* 65)
*fmt-hard-right-margin-default*constant
(defconst *fmt-hard-right-margin-default* 77)
*initial-ld-special-bindings*constant
(defconst *initial-ld-special-bindings* `((standard-oi . ,*STANDARD-OI*) (standard-co . ,*STANDARD-CO*) (proofs-co . ,*STANDARD-CO*) (ld-skip-proofsp) (ld-redefinition-action) (ld-prompt . t) (ld-missing-input-ok) (ld-always-skip-top-level-locals) (ld-pre-eval-filter . :all) (ld-pre-eval-print) (ld-post-eval-print . :command-conventions) (ld-evisc-tuple) (ld-error-triples . t) (ld-error-action . :continue) (ld-query-control-alist) (ld-verbose . "Project-dir-alist:~|~xb.~|Type :help for help.~%Type ~ (quit) to quit completely out of ACL2.~|~%") (ld-user-stobjs-modified-warning)))
*initial-global-table-1*constant
(defconst *initial-global-table-1* (append `((abbrev-evisc-tuple . :default) (abort-soft . t) (accumulated-ttree) (acl2-raw-mode-p) (acl2-sources-dir) (acl2-version . ,(CONCATENATE 'STRING "ACL2 Version 8.6")) (acl2-world-alist) (acl2p-checkpoints-for-summary) (axiomsp) (bddnotes) (book-hash-alistp) (boot-strap-flg . t) (brr-evisc-tuple . :default) (cert-data) (certify-book-info) (check-invariant-risk . :warning) (check-sum-weirdness) (checkpoint-forced-goals) (checkpoint-processors . ,*INITIAL-CHECKPOINT-PROCESSORS*) (checkpoint-summary-limit nil . 3) (compiled-file-extension) (compiler-enabled) (connected-book-directory) (current-acl2-world) (current-package . "ACL2") (debug-pspv) (debugger-enable) (defaxioms-okp-cert . t) (deferred-ttag-notes . :not-deferred) (deferred-ttag-notes-saved) (dmrp) (event-data-fal) (evisc-hitp-without-iprint) (eviscerate-hide-terms) (fast-cert-status) (fmt-hard-right-margin . ,*FMT-HARD-RIGHT-MARGIN-DEFAULT*) (fmt-soft-right-margin . ,*FMT-SOFT-RIGHT-MARGIN-DEFAULT*) (gag-mode) (gag-mode-evisc-tuple) (gag-state) (gag-state-saved) (get-internal-time-as-realtime) (giant-lambda-object) (global-ctx) (global-enabled-structure) (gstackp) (guard-checking-on . t) (host-lisp) (ignore-cert-files) (illegal-to-certify-message)) `((in-local-flg) (in-prove-flg) (in-verify-flg) (including-uncertified-p) (inhibit-er-hard) (inhibit-output-lst summary) (inhibit-output-lst-stack) (inhibited-summary-types) (inside-progn-fn1) (inside-skip-proofs) (iprint-ar . ,(INIT-IPRINT-AR *IPRINT-HARD-BOUND-DEFAULT* NIL)) (iprint-fal) (iprint-hard-bound . ,*IPRINT-HARD-BOUND-DEFAULT*) (iprint-soft-bound . ,*IPRINT-SOFT-BOUND-DEFAULT*) (keep-tmp-files) (last-event-data) (last-make-event-expansion) (last-step-limit . -1) (ld-history) (ld-level . 0) (ld-okp . :default) (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) (make-event-debug-depth . 0) (match-free-error) (modifying-include-book-dir-alist) (parallel-execution-enabled) (parallelism-hazards-action) (pc-erp) (pc-info) (pc-output) (pc-ss-alist) (pc-val) (port-file-enabled . t) (ppr-flat-right-margin . 40) (print-base . 10) (print-case . :upcase) (print-circle) (print-circle-files . t) (print-clause-ids) (print-escape . t) (print-gv-defaults) (print-length) (print-level) (print-lines) (print-pretty) (print-radix) (print-readably)) `((print-right-margin) (program-fns-with-raw-code . ,*INITIAL-PROGRAM-FNS-WITH-RAW-CODE*) (prompt-function . default-print-prompt) (prompt-memo) (proof-tree) (proof-tree-buffer-width . ,*FMT-SOFT-RIGHT-MARGIN-DEFAULT*) (proof-tree-ctx) (proof-tree-indent . "| ") (proof-tree-start-printed) (protect-memoize-statistics) (raw-guard-warningp) (raw-include-book-dir!-alist . :ignore) (raw-include-book-dir-alist . :ignore) (raw-proof-format) (raw-warning-format) (redo-flat-fail) (redo-flat-succ) (redundant-with-raw-code-okp) (retrace-p) (safe-mode) (save-expansion-file) (saved-output-p) (saved-output-reversed) (saved-output-token-lst) (script-mode) (serialize-character) (serialize-character-system) (show-custom-keyword-hint-expansion) (skip-notify-on-defttag) (skip-proofs-by-system) (skip-proofs-okp-cert . t) (skip-reset-prehistory) (slow-array-action . :break) (splitter-output . t) (step-limit-record) (system-attachments-cache) (temp-touchable-fns) (temp-touchable-vars) (term-evisc-tuple . :default) (timer-alist) (tmp-dir) (total-parallelism-work-limit . ,(DEFAULT-TOTAL-PARALLELISM-WORK-LIMIT)) (total-parallelism-work-limit-error . t) (trace-co . standard-character-output-0) (trace-specs) (triple-print-prefix . " ") (ttags-allowed . :all) (undone-worlds-kill-ring nil nil nil) (useless-runes) (user-home-dir)) '((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) (warnings-as-errors) (waterfall-parallelism) (waterfall-parallelism-timing-threshold . 10000) (waterfall-printing . :full) (waterfall-printing-when-finished) (window-interface-postlude . "#>\>#<\<e(acl2-window-postlude ?~sw ~xt ~xp)#>\>") (window-interface-prelude . "~%#<\<e(acl2-window-prelude ?~sw ~xc)#>\>#<\<~sw") (window-interfacep) (wormhole-name) (wormhole-status) (write-acl2x) (write-bookdata) (write-for-read) (writes-okp . t))))
merge-symbol-alistpfunction
(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))))))
merge-sort-symbol-alistpfunction
(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)))))))
*initial-global-table*constant
(defconst *initial-global-table* (merge-sort-symbol-alistp (append *initial-ld-special-bindings* *initial-global-table-1*)))
other
(value (or (ordered-symbol-alistp *initial-global-table*) (illegal 'top-level "*initial-global-table* is not an ordered-symbol-alistp!" nil)))
all-boundpfunction
(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)))
known-package-alistpfunction
(defun known-package-alistp (x) (declare (xargs :guard t)) (cond ((atom x) (null x)) (t (and (true-listp (car x)) (stringp (car (car x))) (symbol-listp (cadr (car x))) (known-package-alistp (cdr x))))))
known-package-alistp-forward-to-true-list-listp-and-alistptheorem
(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)
timer-alistpfunction
(defun timer-alistp (x) (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)))
timer-alistp-forward-to-true-list-listp-and-symbol-alistptheorem
(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)
typed-io-listpfunction
(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)))))
typed-io-listp-forward-to-true-listptheorem
(defthm typed-io-listp-forward-to-true-listp (implies (typed-io-listp x typ) (true-listp x)) :rule-classes :forward-chaining)
*file-types*constant
(defconst *file-types* '(:character :byte :object))
channel-headerpfunction
(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))))
open-channel1function
(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))))))
open-channel1-forward-to-true-listp-and-consptheorem
(defthm open-channel1-forward-to-true-listp-and-consp (implies (open-channel1 x) (and (true-listp x) (consp x))) :rule-classes :forward-chaining)
open-channel-listpfunction
(defun open-channel-listp (l) (declare (xargs :guard (alistp l))) (if (endp l) t (and (open-channel1 (cdr (car l))) (open-channel-listp (cdr l)))))
open-channels-pfunction
(defun open-channels-p (x) (declare (xargs :guard t)) (and (ordered-symbol-alistp x) (open-channel-listp x)))
open-channels-p-forwardtheorem
(defthm open-channels-p-forward (implies (open-channels-p x) (and (ordered-symbol-alistp x) (true-list-listp x))) :rule-classes :forward-chaining)
file-clock-pfunction
(defun file-clock-p (x) (declare (xargs :guard t)) (natp x))
file-clock-p-forward-to-integerptheorem
(defthm file-clock-p-forward-to-integerp (implies (file-clock-p x) (natp x)) :rule-classes :forward-chaining)
readable-filefunction
(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))))))
readable-file-forward-to-true-listp-and-consptheorem
(defthm readable-file-forward-to-true-listp-and-consp (implies (readable-file x) (and (true-listp x) (consp x))) :rule-classes :forward-chaining)
readable-files-listpfunction
(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))))))
readable-files-listp-forward-to-true-list-listp-and-alistptheorem
(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)
readable-files-pfunction
(defun readable-files-p (x) (declare (xargs :guard t)) (readable-files-listp x))
readable-files-p-forward-to-readable-files-listptheorem
(defthm readable-files-p-forward-to-readable-files-listp (implies (readable-files-p x) (readable-files-listp x)) :rule-classes :forward-chaining)
written-filefunction
(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))))))
written-file-forward-to-true-listp-and-consptheorem
(defthm written-file-forward-to-true-listp-and-consp (implies (written-file x) (and (true-listp x) (consp x))) :rule-classes :forward-chaining)
written-file-listpfunction
(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))))))
written-file-listp-forward-to-true-list-listp-and-alistptheorem
(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)
written-files-pfunction
(defun written-files-p (x) (declare (xargs :guard t)) (written-file-listp x))
written-files-p-forward-to-written-file-listptheorem
(defthm written-files-p-forward-to-written-file-listp (implies (written-files-p x) (written-file-listp x)) :rule-classes :forward-chaining)
read-file-listp1function
(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))))
read-file-listp1-forward-to-true-listp-and-consptheorem
(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)
read-file-listpfunction
(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))))))
read-file-listp-forward-to-true-list-listptheorem
(defthm read-file-listp-forward-to-true-list-listp (implies (read-file-listp x) (true-list-listp x)) :rule-classes :forward-chaining)
read-files-pfunction
(defun read-files-p (x) (declare (xargs :guard t)) (read-file-listp x))
read-files-p-forward-to-read-file-listptheorem
(defthm read-files-p-forward-to-read-file-listp (implies (read-files-p x) (read-file-listp x)) :rule-classes :forward-chaining)
writable-file-listp1function
(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))))
writable-file-listp1-forward-to-true-listp-and-consptheorem
(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)
writable-file-listpfunction
(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))))))
writable-file-listp-forward-to-true-list-listptheorem
(defthm writable-file-listp-forward-to-true-list-listp (implies (writable-file-listp x) (true-list-listp x)) :rule-classes :forward-chaining)
writeable-files-pfunction
(defun writeable-files-p (x) (declare (xargs :guard t)) (writable-file-listp x))
writeable-files-p-forward-to-writable-file-listptheorem
(defthm writeable-files-p-forward-to-writable-file-listp (implies (writeable-files-p x) (writable-file-listp x)) :rule-classes :forward-chaining)
state-p1function
(defun state-p1 (x) (declare (xargs :guard 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))))
state-p1-forwardtheorem
(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 :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))))
all-boundp-preserves-assoc-equaltheorem
(defthm all-boundp-preserves-assoc-equal (implies (and (all-boundp tbl1 tbl2) (assoc-equal x tbl1)) (assoc-equal x tbl2)) :rule-classes nil)
all-boundp-initial-global-tabletheorem
(defthm all-boundp-initial-global-table (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))))
state-p-implies-and-forward-to-state-p1theorem
(defthm state-p-implies-and-forward-to-state-p1 (implies (state-p state-state) (state-p1 state-state)) :rule-classes (:forward-chaining :rewrite))
build-statemacro
(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)))
*default-state*constant
(defconst *default-state* (list nil nil *initial-global-table* 4000000 nil nil 1 nil nil nil nil nil))
build-state1function
(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)))) (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*))))
coerce-state-to-objectfunction
(defun coerce-state-to-object (x) (declare (xargs :guard t)) x)
coerce-object-to-statefunction
(defun coerce-object-to-state (x) (declare (xargs :guard t)) x)
other
(verify-termination-boot-strap create-state)
global-table-cars1function
(defun global-table-cars1 (state-state) (declare (xargs :guard (state-p1 state-state))) (strip-cars (global-table state-state)))
global-table-carsfunction
(defun global-table-cars (state-state) (declare (xargs :guard (state-p1 state-state))) (global-table-cars1 state-state))
boundp-global1function
(defun boundp-global1 (x state-state) (declare (xargs :guard (and (symbolp x) (state-p1 state-state)))) (cond ((assoc x (global-table state-state)) t) (t nil)))
boundp-globalfunction
(defun boundp-global (x state-state) (declare (xargs :guard (and (symbolp x) (state-p1 state-state)))) (boundp-global1 x state-state))
f-boundp-globalmacro
(defmacro f-boundp-global (x st) (list 'boundp-global x st))
makunbound-globalfunction
(defun makunbound-global (x state-state) (declare (xargs :guard (and (symbolp x) (state-p1 state-state)))) (update-global-table (remove1-assoc-eq x (global-table state-state)) state-state))
get-globalfunction
(defun get-global (x state-state) (declare (xargs :guard (and (symbolp x) (state-p1 state-state) (boundp-global1 x state-state)))) (cdr (assoc x (global-table state-state))))
put-globalfunction
(defun put-global (key value state-state) (declare (xargs :guard (and (symbolp key) (state-p1 state-state)))) (update-global-table (add-pair key value (global-table state-state)) state-state))
f-put-globalmacro
(defmacro f-put-global (key value st) (list 'put-global key value st))
inhibit-er-hardfunction
(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))))
always-boundp-globalfunction
(defun always-boundp-global (x) (declare (xargs :guard (symbolp x))) (assoc-eq x *initial-global-table*))
state-global-let*-bindings-pfunction
(defun state-global-let*-bindings-p (lst) (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))))))
state-global-let*-get-globalsfunction
(defun state-global-let*-get-globals (bindings) (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))))))
*state-global-let*-untouchable-alist*constant
(defconst *state-global-let*-untouchable-alist* '((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)))
state-global-let*-put-globalsfunction
(defun state-global-let*-put-globals (bindings) (declare (xargs :guard (state-global-let*-bindings-p bindings))) (cond ((endp bindings) nil) ((let ((binding (car bindings))) (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)) ,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 `(,(CDR X) ,VAL-FORM state)) (t `(f-put-global ',(CAAR BINDINGS) ,VAL-FORM state))))))) (state-global-let*-put-globals (cdr bindings))))))
state-global-let*-cleanupfunction
(defun state-global-let*-cleanup (bindings index) (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 `(,(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)))))))
with-parallelism-hazard-warningsmacro
(defmacro with-parallelism-hazard-warnings (body) body)
warn-about-parallelism-hazardmacro
(defmacro warn-about-parallelism-hazard (call body) (declare (ignore call)) body)
with-ensured-parallelism-finishingmacro
(defmacro with-ensured-parallelism-finishing (form) form)
state-global-let*-fnfunction
(defun state-global-let*-fn (bindings body) (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 '(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)))))
state-global-let*macro
(defmacro state-global-let* (bindings body) (state-global-let*-fn bindings body))
local
(local (skip-proofs (defthm justify-integer-floor-recursion (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)))
other
(verify-termination-boot-strap explode-nonnegative-integer (declare (xargs :mode :logic :verify-guards nil :hints (("Goal" :in-theory (disable acl2-count floor))))))
true-listp-explode-nonnegative-integertheorem
(defthm true-listp-explode-nonnegative-integer (implies (true-listp ans) (true-listp (explode-nonnegative-integer n print-base ans))) :rule-classes :type-prescription)
local
(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
(local (defthm integerp-mod (implies (and (integerp n) (< 0 n) (print-base-p print-base)) (integerp (mod n print-base))) :rule-classes :type-prescription))
other
(verify-guards explode-nonnegative-integer :hints (("Goal" :in-theory (disable mod))))
local
(local (defthm character-listp-explode-nonnegative-integer (implies (character-listp z) (character-listp (explode-nonnegative-integer x y z)))))
encapsulate
(encapsulate nil (local (defthm take-guard-lemma-1 (equal (first-n-ac i l ac) (revappend ac (take i l))))) (verify-guards take))
other
(verify-termination-boot-strap butlast)
integer-range-pfunction
(defun integer-range-p (lower upper x) (declare (type integer lower upper)) (and (integerp x) (<= lower x) (< x upper)))
local
(local (defthm natp-expt (implies (and (integerp base) (integerp n) (<= 0 n)) (integerp (expt base n))) :rule-classes :type-prescription))
signed-byte-pfunction
(defun signed-byte-p (bits x) (declare (xargs :guard t)) (and (integerp bits) (< 0 bits) (let ((y (expt 2 (1- bits)))) (integer-range-p (- y) y x))))
unsigned-byte-pfunction
(defun unsigned-byte-p (bits x) (declare (xargs :guard t)) (and (integerp bits) (<= 0 bits) (integer-range-p 0 (expt 2 bits) x)))
integer-range-p-forwardtheorem
(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)
signed-byte-p-forward-to-integerptheorem
(defthm signed-byte-p-forward-to-integerp (implies (signed-byte-p n x) (integerp x)) :rule-classes :forward-chaining)
unsigned-byte-p-forward-to-nonnegative-integerptheorem
(defthm unsigned-byte-p-forward-to-nonnegative-integerp (implies (unsigned-byte-p n x) (and (integerp x) (<= 0 x))) :rule-classes :forward-chaining)
local
(local (defthm character-listp-substitute-ac (implies (and (characterp new) (character-listp x) (character-listp acc)) (character-listp (substitute-ac new old x acc)))))
other
(verify-guards substitute)
local
(local (encapsulate nil (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)))))))
other
(verify-guards all-vars1)
other
(verify-guards all-vars)
local
(local (defthm symbol-listp-implies-true-listp (implies (symbol-listp x) (true-listp x))))
completion-of-symbol-nameaxiom
(defaxiom completion-of-symbol-name (equal (symbol-name x) (if (symbolp x) (symbol-name x) "")) :rule-classes nil)
default-symbol-nametheorem
(defthm default-symbol-name (implies (not (symbolp x)) (equal (symbol-name x) "")) :hints (("Goal" :use completion-of-symbol-name)))
completion-of-symbol-package-nameaxiom
(defaxiom completion-of-symbol-package-name (equal (symbol-package-name x) (if (symbolp x) (symbol-package-name x) "")) :rule-classes nil)
default-symbol-package-nametheorem
(defthm default-symbol-package-name (implies (not (symbolp x)) (equal (symbol-package-name x) "")) :hints (("Goal" :use completion-of-symbol-package-name)))
symbol-equalitytheorem
(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))))))
string<-l-asymmetricencapsulate
(encapsulate nil (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))
logandmacro
(defmacro logand (&rest args) (cond ((null args) -1) ((null (cdr args)) `(the integer ,(CAR ARGS))) (t (xxxjoin 'binary-logand args))))
logeqvmacro
(defmacro logeqv (&rest args) (cond ((null args) -1) ((null (cdr args)) `(the integer ,(CAR ARGS))) (t (xxxjoin 'binary-logeqv args))))
logiormacro
(defmacro logior (&rest args) (cond ((null args) 0) ((null (cdr args)) `(the integer ,(CAR ARGS))) (t (xxxjoin 'binary-logior args))))
logxormacro
(defmacro logxor (&rest args) (cond ((null args) 0) ((null (cdr args)) `(the integer ,(CAR ARGS))) (t (xxxjoin 'binary-logxor args))))
integer-lengthfunction
(defun integer-length (i) (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))))))
binary-logandfunction
(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)))))))
lognandfunction
(defun lognand (i j) (declare (xargs :guard (and (integerp i) (integerp j)))) (lognot (logand i j)))
binary-logiorfunction
(defun binary-logior (i j) (declare (xargs :guard (and (integerp i) (integerp j)))) (lognot (logand (lognot i) (lognot j))))
logorc1function
(defun logorc1 (i j) (declare (xargs :guard (and (integerp i) (integerp j)))) (logior (lognot i) j))
logorc2function
(defun logorc2 (i j) (declare (xargs :guard (and (integerp i) (integerp j)))) (logior i (lognot j)))
logandc1function
(defun logandc1 (i j) (declare (xargs :guard (and (integerp i) (integerp j)))) (logand (lognot i) j))
logandc2function
(defun logandc2 (i j) (declare (xargs :guard (and (integerp i) (integerp j)))) (logand i (lognot j)))
binary-logeqvfunction
(defun binary-logeqv (i j) (declare (xargs :guard (and (integerp i) (integerp j)))) (logand (logorc1 i j) (logorc1 j i)))
binary-logxorfunction
(defun binary-logxor (i j) (declare (xargs :guard (and (integerp i) (integerp j)))) (lognot (logeqv i j)))
lognorfunction
(defun lognor (i j) (declare (xargs :guard (and (integerp i) (integerp j)))) (lognot (logior i j)))
logtestfunction
(defun logtest (x y) (declare (xargs :guard (and (integerp x) (integerp y)))) (not (zerop (logand x y))))
*boole-and*constant
(defconst *boole-and* 2)
*boole-andc1*constant
(defconst *boole-andc1* 3)
*boole-andc2*constant
(defconst *boole-andc2* 4)
*boole-c1*constant
(defconst *boole-c1* 5)
*boole-c2*constant
(defconst *boole-c2* 6)
*boole-clr*constant
(defconst *boole-clr* 7)
*boole-eqv*constant
(defconst *boole-eqv* 8)
*boole-ior*constant
(defconst *boole-ior* 9)
*boole-nand*constant
(defconst *boole-nand* 10)
*boole-nor*constant
(defconst *boole-nor* 11)
*boole-orc1*constant
(defconst *boole-orc1* 12)
*boole-orc2*constant
(defconst *boole-orc2* 13)
*boole-set*constant
(defconst *boole-set* 14)
*boole-xor*constant
(defconst *boole-xor* 15)
boole$function
(defun boole$ (op i1 i2) (declare (type (integer 0 15) op) (type integer i1 i2)) (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)))
set-forms-from-bindingsfunction
(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))))))
*print-control-defaults*constant
(defconst *print-control-defaults* `((print-base ',(CDR (ASSOC-EQ 'PRINT-BASE *INITIAL-GLOBAL-TABLE*)) set-print-base) (print-case ',(CDR (ASSOC-EQ 'PRINT-CASE *INITIAL-GLOBAL-TABLE*)) set-print-case) (print-circle ',(CDR (ASSOC-EQ 'PRINT-CIRCLE *INITIAL-GLOBAL-TABLE*)) set-print-circle) (print-escape ',(CDR (ASSOC-EQ 'PRINT-ESCAPE *INITIAL-GLOBAL-TABLE*)) set-print-escape) (print-length ',(CDR (ASSOC-EQ 'PRINT-LENGTH *INITIAL-GLOBAL-TABLE*)) set-print-length) (print-level ',(CDR (ASSOC-EQ 'PRINT-LEVEL *INITIAL-GLOBAL-TABLE*)) set-print-level) (print-lines ',(CDR (ASSOC-EQ 'PRINT-LINES *INITIAL-GLOBAL-TABLE*)) set-print-lines) (print-pretty ',(CDR (ASSOC-EQ 'PRINT-PRETTY *INITIAL-GLOBAL-TABLE*)) set-print-pretty) (print-radix ',(CDR (ASSOC-EQ 'PRINT-RADIX *INITIAL-GLOBAL-TABLE*)) set-print-radix) (print-readably ',(CDR (ASSOC-EQ 'PRINT-READABLY *INITIAL-GLOBAL-TABLE*)) set-print-readably) (print-right-margin ',(CDR (ASSOC-EQ 'PRINT-RIGHT-MARGIN *INITIAL-GLOBAL-TABLE*)) set-print-right-margin)))
alist-difference-eqfunction
(defun alist-difference-eq (alist1 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)))))
with-print-defaultsmacro
(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))
reset-print-controlmacro
(defmacro reset-print-control nil (cons 'pprogn (set-forms-from-bindings *print-control-defaults*)))
explode-atomfunction
(defun explode-atom (x print-base) (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 #\ (append (explode-atom (imagpart x) print-base) '(#\))))))) ((characterp x) (list x)) ((stringp x) (coerce x 'list)) ((symbolp x) (coerce (symbol-name x) 'list)) (t (coerce "SOME BAD ATOM" 'list))))
other
(verify-termination-boot-strap explode-atom (declare (xargs :mode :logic)))
explode-atom+function
(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 #\ (append (explode-atom+ (imagpart x) print-base print-radix) '(#\))))))) (t (explode-atom x print-base))))
other
(verify-termination-boot-strap explode-atom+ (declare (xargs :mode :logic)))
true-list-listp-forward-to-true-listp-assoc-equaltheorem
(defthm true-list-listp-forward-to-true-listp-assoc-equal (implies (true-list-listp l) (true-listp (assoc-equal key l))) :rule-classes (:type-prescription (:forward-chaining :trigger-terms ((assoc-equal key l)))))
true-listp-cadr-assoc-eq-for-open-channels-ptheorem
(defthm true-listp-cadr-assoc-eq-for-open-channels-p (implies (open-channels-p alist) (true-listp (cadr (assoc-eq key alist)))) :rule-classes ((:forward-chaining :trigger-terms ((cadr (assoc-eq key alist))))))
local
(local (in-theory (disable nth open-channels-p)))
open-input-channel-p1function
(defun open-input-channel-p1 (channel typ state-state) (declare (xargs :guard (and (symbolp channel) (state-p1 state-state) (member-eq typ *file-types*)))) (let ((pair (assoc-eq channel (open-input-channels state-state)))) (and pair (eq (cadr (car (cdr pair))) typ))))
open-output-channel-p1function
(defun open-output-channel-p1 (channel typ state-state) (declare (xargs :guard (and (symbolp channel) (state-p1 state-state) (member-eq typ *file-types*)))) (let ((pair (assoc-eq channel (open-output-channels state-state)))) (and pair (eq (cadr (car (cdr pair))) typ))))
open-input-channel-pfunction
(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))
open-output-channel-pfunction
(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))
open-output-channel-any-p1function
(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)))
open-output-channel-any-pfunction
(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))
open-input-channel-any-p1function
(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)))
open-input-channel-any-pfunction
(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))
non-free-var-runesfunction
(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)))))
free-var-runesfunction
(defun free-var-runes (flg wrld) (declare (xargs :guard (plist-worldp wrld))) (cond ((eq flg :once) (global-val 'free-var-runes-once wrld)) (t (global-val 'free-var-runes-all wrld))))
natp-position-actheorem
(defthm natp-position-ac (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)
*directory-separator*constant
(defconst *directory-separator* #\/)
*directory-separator-string*constant
(defconst *directory-separator-string* (string *directory-separator*))
os-ermacro
(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))))
osfunction
(defun os (wrld) (declare (xargs :guard (plist-worldp wrld))) (global-val 'operating-system wrld))
absolute-pathname-string-pfunction
(defun absolute-pathname-string-p (str directoryp os) (declare (xargs :guard (stringp str))) (let ((len (length str))) (and (< 0 len) (cond ((and (eq os :mswindows) (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 (and (eql (char str 0) #\~) (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))))
illegal-ruler-extenders-valuesfunction
(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)))))
table-alistfunction
(defun table-alist (name wrld) (declare (xargs :guard (and (symbolp name) (plist-worldp wrld)))) (getpropc name 'table-alist nil wrld))
ruler-extenders-msg-auxfunction
(defun ruler-extenders-msg-aux (vals 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))))))))
ruler-extenders-msgfunction
(defun ruler-extenders-msg (x wrld) (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))))))
strict-symbol<-sortedpfunction
(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))))))
chk-ruler-extendersmacro
(defmacro chk-ruler-extenders (x type ctx wrld) (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))))))))
*default-step-limit*constant
(defconst *default-step-limit* (fixnum-bound))
include-book-dir-alist-entry-pfunction
(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)))
include-book-dir-alistpfunction
(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)))))
*check-invariant-risk-values*constant
(defconst *check-invariant-risk-values* '(t nil :error :warning))
ttagfunction
(defun ttag (wrld) (declare (xargs :guard (and (plist-worldp wrld) (alistp (table-alist 'acl2-defaults-table wrld))))) (cdr (assoc-eq :ttag (table-alist 'acl2-defaults-table wrld))))
get-register-invariant-risk-worldfunction
(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 t))))
set-table-guardmacro
(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 `(MSG "The :guard requires ~x0." ',GUARD)) ',(OR TOPIC NAME) (let ((coda ,CODA)) (if coda (msg " ~@0" coda) "")))))))
other
(set-table-guard acl2-defaults-table (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) (= (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) (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))) ((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) (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) (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) (alistp val)) ((eq key :in-theory-redundant-okp) (booleanp val)) ((eq key :subgoal-loop-limits) (and (consp val) (or (null (car val)) (natp (car val))) (or (null (cdr val)) (and (natp (cdr val)) (< 0 (cdr val)))))) ((eq key :constraint-tracking) (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)))
print-casemacro
(defmacro print-case nil '(f-get-global 'print-case state))
acl2-print-casemacro
(defmacro acl2-print-case (&optional (st 'state)) `(print-case ,ST))
check-print-casefunction
(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)))))
set-print-casefunction
(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)))
print-basemacro
(defmacro print-base (&optional (st 'state)) `(f-get-global 'print-base ,ST))
acl2-print-basemacro
(defmacro acl2-print-base (&optional (st 'state)) `(print-base ,ST))
print-radixmacro
(defmacro print-radix (&optional (st 'state)) `(f-get-global 'print-radix ,ST))
acl2-print-radixmacro
(defmacro acl2-print-radix (&optional (st 'state)) `(print-radix ,ST))
check-print-basefunction
(defun check-print-base (print-base ctx) (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)))))
set-print-basefunction
(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)))
set-print-circlefunction
(defun set-print-circle (x state) (declare (xargs :guard (state-p state))) (f-put-global 'print-circle x state))
set-print-escapefunction
(defun set-print-escape (x state) (declare (xargs :guard (state-p state))) (f-put-global 'print-escape x state))
set-print-prettyfunction
(defun set-print-pretty (x state) (declare (xargs :guard (state-p state))) (f-put-global 'print-pretty x state))
set-print-radixfunction
(defun set-print-radix (x state) (declare (xargs :guard (state-p state))) (f-put-global 'print-radix x state))
set-print-readablyfunction
(defun set-print-readably (x state) (declare (xargs :guard (state-p state))) (f-put-global 'print-readably x state))
check-null-or-natpfunction
(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)))))
set-print-lengthfunction
(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)))
set-print-levelfunction
(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)))
set-print-linesfunction
(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)))
set-print-right-marginfunction
(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)))
raw-print-vars-alistfunction
(defun raw-print-vars-alist (print-control-defaults-tail) (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))))))
*raw-print-vars-alist*constant
(defconst *raw-print-vars-alist* (raw-print-vars-alist *print-control-defaults*))
all-function-symbolpsfunction
(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)))))
*unknown-constraints*constant
(defconst *unknown-constraints* :unknown-constraints)
non-trivial-encapsulate-ee-entriesfunction
(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)))))
unknown-constraints-table-guardfunction
(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)))))
other
(table unknown-constraints-table nil nil :guard (unknown-constraints-table-guard key val world))
set-unknown-constraints-supportersmacro
(defmacro set-unknown-constraints-supporters (&rest fns) `(table unknown-constraints-table :supporters (let ((ee-entries (non-trivial-encapsulate-ee-entries (global-val 'embedded-event-lst world)))) (union-equal (strip-cars (cadr (car ee-entries))) ',FNS))))
assignmacro
(defmacro assign (x y) (declare (type symbol x)) `(pprogn (f-put-global ',X ,Y state) (mv nil (f-get-global ',X state) state)))
@macro
(defmacro @ (x) (declare (type symbol x)) `(f-get-global ',X state))
chk-inhibit-output-lst-msgfunction
(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)))
set-inhibit-output-lst-statefunction
(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)))))
logicmacro
(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))))
programmacro
(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))))
encapsulate
(encapsulate nil (logic) (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))) nil (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 (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 (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 (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)))))))
alpha-char-pfunction
(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))))
upper-case-pfunction
(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))))
lower-case-pfunction
(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))))
char-upcasefunction
(defun char-upcase (x) (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))))
char-downcasefunction
(defun char-downcase (x) (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))))
lower-case-p-forward-to-alpha-char-ptheorem
(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)
upper-case-p-forward-to-alpha-char-ptheorem
(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)
standard-char-p-forward-to-characterptheorem
(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)
characterp-char-downcasetheorem
(defthm characterp-char-downcase (characterp (char-downcase x)) :rule-classes :type-prescription)
characterp-char-upcasetheorem
(defthm characterp-char-upcase (characterp (char-upcase x)) :rule-classes :type-prescription)
lower-case-p-char-downcasetheorem
(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)))))
upper-case-p-char-upcasetheorem
(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)))))
string-downcase1function
(defun string-downcase1 (l) (declare (xargs :guard (character-listp l))) (if (atom l) nil (cons (char-downcase (car l)) (string-downcase1 (cdr l)))))
character-listp-string-downcase-1theorem
(defthm character-listp-string-downcase-1 (character-listp (string-downcase1 x)))
string-downcasefunction
(defun string-downcase (x) (declare (xargs :guard (stringp x))) (coerce (string-downcase1 (coerce x 'list)) 'string))
string-upcase1function
(defun string-upcase1 (l) (declare (xargs :guard (character-listp l))) (if (atom l) nil (cons (char-upcase (car l)) (string-upcase1 (cdr l)))))
character-listp-string-upcase1-1theorem
(defthm character-listp-string-upcase1-1 (character-listp (string-upcase1 x)))
string-upcasefunction
(defun string-upcase (x) (declare (xargs :guard (stringp x))) (coerce (string-upcase1 (coerce x 'list)) 'string))
char-equalfunction
(defun char-equal (x y) (declare (xargs :guard (and (characterp x) (characterp y)))) (eql (char-downcase x) (char-downcase y)))
string-equal1function
(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))))))
string-equalfunction
(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))))
member-string-equalfunction
(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))))))
string-alistpfunction
(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))))))
string-alistp-forward-to-alistptheorem
(defthm string-alistp-forward-to-alistp (implies (string-alistp x) (alistp x)) :rule-classes :forward-chaining)
assoc-string-equalfunction
(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
(encapsulate nil (local (defthm hack (implies (integerp i) (equal (+ -1 1 i) i)))) (verify-termination-boot-strap string-equal1))
standard-char-p-nththeorem
(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))))
other
(verify-termination-boot-strap xxxjoin)
in-theory
(in-theory (disable alpha-char-p upper-case-p lower-case-p char-upcase char-downcase print-base-p))
princ$function
(defun princ$ (x channel state-state) (declare (xargs :guard (and (atom x) (state-p1 state-state) (symbolp channel) (open-output-channel-p1 channel :character state-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) (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)))
write-byte$function
(defun write-byte$ (x channel state-state) (declare (xargs :guard (and (integerp x) (>= x 0) (< x 256) (state-p1 state-state) (symbolp channel) (open-output-channel-p1 channel :byte state-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)))
wfunction
(defun w (state) (declare (xargs :guard (state-p state) :verify-guards nil)) (f-get-global 'current-acl2-world state))
get-serialize-characterfunction
(defun get-serialize-character (state) (declare (xargs :guard t)) (f-get-global 'serialize-character state))
set-serialize-character-fnfunction
(defun set-serialize-character-fn (c system-p state) (declare (xargs :verify-guards nil :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 (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)))))
set-serialize-characterfunction
(defun set-serialize-character (c state) (declare (xargs :verify-guards nil :guard (and (state-p state) (or (null c) (member c '(#\Y #\Z)))))) (set-serialize-character-fn c nil state))
set-serialize-character-systemfunction
(defun set-serialize-character-system (c state) (declare (xargs :verify-guards nil :guard (and (state-p state) (or (null c) (member c '(#\Y #\Z)))))) (set-serialize-character-fn c t state))
print-object$+-alistfunction
(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))))))))
make-input-channelfunction
(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"))
make-output-channelfunction
(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"))
local
(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)))))
nth-update-nththeorem
(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))))
true-listp-update-nththeorem
(defthm true-listp-update-nth (implies (true-listp l) (true-listp (update-nth key val l))) :rule-classes :type-prescription)
open-input-channelfunction
(defun open-input-channel (file-name typ state-state) (declare (xargs :guard (and (stringp file-name) (member-eq typ *file-types*) (state-p1 state-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
(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))))))
nth-update-nth-arraytheorem
(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))))
close-input-channelfunction
(defun close-input-channel (channel state-state) (declare (xargs :guard (and (not (member-eq channel '(standard-character-input-0 standard-object-input-0))) (state-p1 state-state) (symbolp channel) (open-input-channel-any-p1 channel state-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) (car header-entries) (caddr header-entries) (file-clock state-state)) (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)))))
open-output-channelfunction
(defun open-output-channel (file-name typ state-state) (declare (xargs :guard (and (or (stringp file-name) (eq file-name :string)) (member-eq typ *file-types*) (state-p1 state-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)))))
len-update-nthencapsulate
(encapsulate nil (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)))))
assoc-add-pairtheorem
(defthm assoc-add-pair (equal (assoc sym1 (add-pair sym2 val alist)) (if (equal sym1 sym2) (cons sym1 val) (assoc sym1 alist))))
add-pair-preserves-all-boundptheorem
(defthm add-pair-preserves-all-boundp (implies (all-boundp alist1 alist2) (all-boundp alist1 (add-pair sym val alist2))))
nth-0-constheorem
(defthm nth-0-cons (equal (nth 0 (cons a l)) a) :hints (("Goal" :in-theory (enable nth))))
nth-add1theorem
(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
(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
(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
(local (defthm state-p1-mv-nth-1-open-output-channel (implies (and (stringp file-name) (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))))))
open-output-channel!function
(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)) (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)))))
assert$macro
(defmacro assert$ (test form) `(prog2$ (or ,TEST (er hard 'assert$ "Assertion failed:~%~x0" '(assert$ ,TEST ,FORM))) ,FORM))
assert$?macro
(defmacro assert$? (test form) `(prog2$ (or ,TEST (er hard? 'assert$? "Assertion failed:~%~x0" '(assert$? ,TEST ,FORM))) ,FORM))
comment-window-cofunction
(defun comment-window-co nil (declare (xargs :guard t)) *standard-co*)
fmt-to-comment-windowfunction
(defun fmt-to-comment-window (str alist col evisc-tuple print-base-radix) (declare (xargs :guard t) (ignore str alist col evisc-tuple print-base-radix)) nil)
fmt-to-comment-window!function
(defun fmt-to-comment-window! (str alist col evisc-tuple print-base-radix) (declare (xargs :guard t) (ignore str alist col evisc-tuple print-base-radix)) nil)
fmt-to-comment-window+function
(defun fmt-to-comment-window+ (str alist col evisc-tuple print-base-radix) (declare (xargs :guard t) (ignore str alist col evisc-tuple print-base-radix)) nil)
fmt-to-comment-window!+function
(defun fmt-to-comment-window!+ (str alist col evisc-tuple print-base-radix) (declare (xargs :guard t) (ignore str alist col evisc-tuple print-base-radix)) nil)
pairlis2function
(defun pairlis2 (x y) (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))))))
cwmacro
(defmacro cw (str &rest args) `(fmt-to-comment-window ,STR (pairlis2 *base-10-chars* (list ,@ARGS)) 0 nil nil))
cw!macro
(defmacro cw! (str &rest args) `(fmt-to-comment-window! ,STR (pairlis2 *base-10-chars* (list ,@ARGS)) 0 nil nil))
cw+macro
(defmacro cw+ (str &rest args) `(fmt-to-comment-window+ ,STR (pairlis2 *base-10-chars* (list ,@ARGS)) 0 nil nil))
cw!+macro
(defmacro cw!+ (str &rest args) `(fmt-to-comment-window!+ ,STR (pairlis2 *base-10-chars* (list ,@ARGS)) 0 nil nil))
cw-print-base-radixmacro
(defmacro cw-print-base-radix (print-base-radix str &rest args) `(fmt-to-comment-window ,STR (pairlis2 *base-10-chars* (list ,@ARGS)) 0 nil ,PRINT-BASE-RADIX))
cw-print-base-radix!macro
(defmacro cw-print-base-radix! (print-base-radix str &rest args) `(fmt-to-comment-window! ,STR (pairlis2 *base-10-chars* (list ,@ARGS)) 0 nil ,PRINT-BASE-RADIX))
subseq-listfunction
(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)))
subseqfunction
(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)))))
lock-symbol-name-pfunction
(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)) #\*)))))
assign-lockfunction
(defun assign-lock (key) (declare (xargs :guard (lock-symbol-name-p key))) (declare (ignore key)) t)
other
(table lock-table nil nil :guard (and (lock-symbol-name-p key) (assign-lock key)))
with-lockmacro
(defmacro with-lock (bound-symbol &rest forms) (declare (xargs :guard (lock-symbol-name-p bound-symbol))) `(translate-and-test (lambda (x) (prog2$ x (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)))
deflockmacro
(defmacro deflock (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) (defmacro ,MACRO-SYMBOL (&rest args) (list* 'with-lock ',LOCK-SYMBOL args)))))
other
(deflock *output-lock*)
other
(deflock *local-state-lock*)
local
(local (defthm typed-io-listp-of-character (equal (typed-io-listp l ':character) (character-listp l))))
local
(local (defthm character-listp-cdr-when-open-channel1 (implies (and (open-channel1 chan) (equal (cadr (car chan)) ':character)) (character-listp (cdr chan)))))
local
(local (defthm len-cdr-car-when-open-channel1 (implies (open-channel1 chan) (equal (len (cdr (car chan))) 3))))
local
(local (defthm not-equal-string-nth-2-car-when-open-channel1 (implies (open-channel1 chan) (not (equal (nth 2 (car chan)) :string)))))
local
(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))))))
get-output-stream-string$-fnfunction
(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))))) (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)))))
get-output-stream-string$macro
(defmacro get-output-stream-string$ (channel state-state &optional (close-p 't) (ctx ''get-output-stream-string$)) (declare (xargs :guard (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))))))))
close-output-channelfunction
(defun close-output-channel (channel state-state) (declare (xargs :guard (and (not (eq channel *standard-co*)) (state-p1 state-state) (symbolp channel) (open-output-channel-any-p1 channel state-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) (car header-entries) (caddr header-entries) (file-clock state-state)) (cdr (cdr pair))) (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)))))
maybe-finish-output$function
(defun maybe-finish-output$ (channel state) (declare (xargs :guard (and (symbolp channel) (state-p state) (open-output-channel-any-p channel state))) (ignorable channel state)) nil)
read-char$function
(defun read-char$ (channel state-state) (declare (xargs :guard (and (state-p1 state-state) (symbolp channel) (open-input-channel-p1 channel :character state-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))))
peek-char$function
(defun peek-char$ (channel state-state) (declare (xargs :guard (and (state-p1 state-state) (symbolp channel) (open-input-channel-p1 channel :character state-state)))) (let ((entry (cdr (assoc-eq channel (open-input-channels state-state))))) (car (cdr entry))))
read-byte$function
(defun read-byte$ (channel state-state) (declare (xargs :guard (and (state-p1 state-state) (symbolp channel) (open-input-channel-p1 channel :byte state-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))))
raw-mode-pfunction
(defun raw-mode-p (state) (declare (xargs :guard t)) (f-get-global 'acl2-raw-mode-p state))
read-acl2-oraclefunction
(defun read-acl2-oracle (state-state) (declare (xargs :guard (state-p1 state-state))) (mv (null (acl2-oracle state-state)) (car (acl2-oracle state-state)) (update-acl2-oracle (cdr (acl2-oracle state-state)) state-state)))
true-list-fix-execfunction
(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))
true-list-fixfunction
(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))))
fix-true-listmacro
(defmacro fix-true-list (x) `(true-list-fix ,X))
encapsulate
(encapsulate nil (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
(in-theory (disable true-list-fix-exec))
pairlis$-true-list-fixtheorem
(defthm pairlis$-true-list-fix (equal (pairlis$ x (true-list-fix y)) (pairlis$ x y)))
state-p1-read-acl2-oracletheorem
(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))))
iprint-last-index*function
(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) (car x) x)))
iprint-array-pfunction
(defun iprint-array-p (ar max) (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)))))
iprint-falpfunction
(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))))))
iprint-oracle-updatesencapsulate
(encapsulate nil (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) (declare (xargs :stobjs 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 (car (dimensions 'iprint-ar iprint-ar))) (= (maximum-length 'iprint-ar iprint-ar) (* 4 (car (dimensions 'iprint-ar iprint-ar)))) (<= (* 4 (1+ iprint-hard-bound)) (array-maximum-length-bound)) (iprint-falp iprint-fal) (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))))))
read-objectfunction
(defun read-object (channel state-state) (declare (xargs :guard (and (state-p1 state-state) (symbolp channel) (open-input-channel-p1 channel :object state-state)))) (let ((state-state (non-exec (iprint-oracle-updates 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))))))
read-object-with-casefunction
(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 '(:upcase :downcase :preserve :invert))))) (declare (ignore mode)) (read-object channel state))
read-object-suppressfunction
(defun read-object-suppress (channel state) (declare (xargs :guard (and (state-p state) (symbolp channel) (open-input-channel-p channel :object state)))) (let nil (mv-let (eof val state) (read-object channel state) (declare (ignore val)) (mv eof state))))
*suspiciously-first-numeric-chars*constant
(defconst *suspiciously-first-numeric-chars* '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\+ #\- #\. #\^ #\_))
*suspiciously-first-hex-chars*constant
(defconst *suspiciously-first-hex-chars* '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\A #\B #\C #\D #\E #\F #\a #\b #\c #\d #\e #\f #\+ #\- #\. #\^ #\_))
*hex-chars*constant
(defconst *hex-chars* '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\A #\B #\C #\D #\E #\F #\a #\b #\c #\d #\e #\f))
*letter-chars*constant
(defconst *letter-chars* '(#\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))
*slashable-chars*constant
(defconst *slashable-chars* (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))))
some-slashablefunction
(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
(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
(local (in-theory (disable channel-headerp)))
local
(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
(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
(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
(local (defthm character-listp-expode-atom (character-listp (explode-atom x print-base))))
local
(local (defthm character-listp-expode-atom+ (character-listp (explode-atom+ x print-base print-radix)) :hints (("Goal" :in-theory (disable explode-atom)))))
local
(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
(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))))))
prin1-with-slashes1function
(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
(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
(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)))))
prin1-with-slashesfunction
(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)))) (prin1-with-slashes1 (coerce s 'list) slash-char channel state))
suspiciously-first-numeric-charsmacro
(defmacro suspiciously-first-numeric-chars (print-base) `(if (eql ,PRINT-BASE 16) *suspiciously-first-hex-chars* *suspiciously-first-numeric-chars*))
numeric-charsmacro
(defmacro numeric-chars (print-base) `(if (eql ,PRINT-BASE 16) *hex-chars* *base-10-chars*))
may-need-slashes1function
(defun may-need-slashes1 (lst flg potnum-chars) (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)))
local
(local (defthm character-listp-cdr (implies (character-listp x) (character-listp (cdr x))) :rule-classes :forward-chaining))
all-dotsfunction
(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))))))
may-need-slashes-fnfunction
(defun may-need-slashes-fn (x print-base) (declare (type string x)) (or (all-dots x (length x)) (let* ((l (coerce x 'list)) (print-base (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) (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)))))
may-need-slashesmacro
(defmacro may-need-slashes (x &optional (print-base '10)) `(may-need-slashes-fn ,X ,PRINT-BASE))
needs-slashesfunction
(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))))
make-list-acfunction
(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)))))
make-listmacro
(defmacro make-list (size &key initial-element) `(make-list-ac ,SIZE ,INITIAL-ELEMENT nil))
encapsulate
(encapsulate nil (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))
stringp-subseq-type-prescriptiontheorem
(defthm stringp-subseq-type-prescription (implies (stringp seq) (stringp (subseq seq start end))) :rule-classes :type-prescription)
true-listp-subseq-type-prescriptiontheorem
(defthm true-listp-subseq-type-prescription (implies (not (stringp seq)) (true-listp (subseq seq start end))) :rule-classes :type-prescription)
local
(local (in-theory (enable boundp-global1)))
other
(verify-guards w)
other
(verify-guards set-serialize-character)
mswindows-drive1function
(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)) (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))))
user-stobj-alistfunction
(defun user-stobj-alist (state-state) (declare (xargs :guard (state-p1 state-state))) (user-stobj-alist1 state-state))
update-user-stobj-alistfunction
(defun update-user-stobj-alist (x state-state) (declare (xargs :guard (and (symbol-alistp x) (state-p1 state-state)))) (update-user-stobj-alist1 x state-state))
power-evalfunction
(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)))))
read-idatefunction
(defun read-idate (state-state) (declare (xargs :guard (state-p1 state-state))) (mv (cond ((null (idates state-state)) 0) (t (car (idates state-state)))) (update-idates (cdr (idates state-state)) state-state)))
read-run-timefunction
(defun read-run-time (state-state) (declare (xargs :guard (state-p1 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)))
read-acl2-oracle@parfunction
(defun read-acl2-oracle@par (state-state) (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))
standard-evisc-tuplepfunction
(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)))))
brr-evisc-tuple-oracle-updatefunction
(defun brr-evisc-tuple-oracle-update (state) (declare (xargs :guard (state-p 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)))
getenv$function
(defun getenv$ (str state) (declare (xargs :stobjs state :guard (stringp str))) (declare (ignore str)) (read-acl2-oracle state))
setenv$function
(defun setenv$ (str val) (declare (xargs :guard (and (stringp str) (stringp val)))) (declare (ignore str val)) nil)
random$function
(defun random$ (limit state) (declare (type (integer 1 *) limit) (xargs :stobjs state)) (mv-let (erp val state) (read-acl2-oracle state) (mv (cond ((and (null erp) (natp val) (< val limit)) val) (t 0)) state)))
natp-random$theorem
(defthm natp-random$ (natp (car (random$ n state))) :rule-classes :type-prescription)
random$-lineartheorem
(defthm random$-linear (and (<= 0 (car (random$ n state))) (implies (posp n) (< (car (random$ n state)) n))) :rule-classes :linear)
in-theory
(in-theory (disable random$ natp-random$ random$-linear))
sys-callfunction
(defun sys-call (command-string args) (declare (xargs :guard (and (stringp command-string) (string-listp args)))) (declare (ignore command-string args)) nil)
sys-call-statusfunction
(defun sys-call-status (state) (declare (xargs :stobjs state)) (mv-let (erp val state) (read-acl2-oracle state) (declare (ignore erp)) (mv val state)))
update-acl2-oracle-preserves-state-p1theorem
(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
(in-theory (disable update-acl2-oracle))
sys-call+function
(defun sys-call+ (command-string args state) (declare (xargs :stobjs state :guard (and (stringp command-string) (string-listp args)))) (declare (ignore command-string args)) (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))))
sys-call*function
(defun sys-call* (command-string args state) (declare (xargs :stobjs state :guard (and (stringp command-string) (string-listp args)))) (declare (ignore command-string args)) (mv-let (erp1 erp state) (read-acl2-oracle state) (declare (ignore erp1)) (mv (and (integerp erp) (not (eql 0 erp)) erp) nil state)))
local
(local (defthm rational-listp-cdr (implies (rational-listp x) (rational-listp (cdr x)))))
read-run-time-preserves-state-p1theorem
(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))))
read-acl2-oracle-preserves-state-p1theorem
(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
(in-theory (disable read-acl2-oracle))
local
(local (defthm rational-listp-implies-rationalp-car (implies (and (rational-listp x) x) (rationalp (car x)))))
nth-0-read-run-time-type-prescriptiontheorem
(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
(in-theory (disable read-run-time))
local
(local (defthm mv-nth-is-nth (equal (mv-nth n x) (nth n x)) :hints (("Goal" :in-theory (enable nth)))))
main-timerfunction
(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)))))
other
(defun-with-guard-check put-assoc-eq-exec (name val alist) (if (symbolp name) (alistp alist) (symbol-alistp alist)) (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))))))
other
(defun-with-guard-check put-assoc-eql-exec (name val alist) (if (eqlablep name) (alistp alist) (eqlable-alistp alist)) (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))))))
put-assoc-equalfunction
(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))))))
put-assoc-eqmacro
(defmacro put-assoc-eq (name val alist) `(put-assoc ,NAME ,VAL ,ALIST :test 'eq))
put-assoc-eqlmacro
(defmacro put-assoc-eql (name val alist) `(put-assoc ,NAME ,VAL ,ALIST :test 'eql))
put-assoc-eq-exec-is-put-assoc-equaltheorem
(defthm put-assoc-eq-exec-is-put-assoc-equal (equal (put-assoc-eq-exec name val alist) (put-assoc-equal name val alist)))
put-assoc-eql-exec-is-put-assoc-equaltheorem
(defthm put-assoc-eql-exec-is-put-assoc-equal (equal (put-assoc-eql-exec name val alist) (put-assoc-equal name val alist)))
put-assocmacro
(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 `(put-assoc-equal ,NAME ,VAL ,ALIST))))
all-boundp-initial-global-table-alttheorem
(defthm all-boundp-initial-global-table-alt (implies (and (state-p1 state) (assoc-eq x *initial-global-table*)) (boundp-global1 x state)))
local
(local (in-theory (disable boundp-global1)))
local
(local (defthm timer-alist-bound-in-state-p (implies (state-p s) (boundp-global1 'timer-alist s))))
set-timerfunction
(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))
get-timerfunction
(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
(local (defthm timer-alistp-implies-rational-listp-assoc-eq (implies (and (symbolp name) (timer-alistp alist)) (rational-listp (cdr (assoc-eq name alist))))))
push-timerfunction
(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))
rationalp-+theorem
(defthm rationalp-+ (implies (and (rationalp x) (rationalp y)) (rationalp (+ x y))))
rationalp-*theorem
(defthm rationalp-* (implies (and (rationalp x) (rationalp y)) (rationalp (* x y))))
rationalp-unary--theorem
(defthm rationalp-unary-- (implies (rationalp x) (rationalp (- x))))
rationalp-unary-/theorem
(defthm rationalp-unary-/ (implies (rationalp x) (rationalp (/ x))))
rationalp-implies-acl2-numberptheorem
(defthm rationalp-implies-acl2-numberp (implies (rationalp x) (acl2-numberp x)))
pop-timerfunction
(defun pop-timer (name flg state) (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)))
add-timersfunction
(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)))
ordered-symbol-alistp-add-pair-forwardtheorem
(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)))))
state-p1-update-main-timertheorem
(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)))))
increment-timerfunction
(defun increment-timer (name state) (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))))
print-rational-as-decimalfunction
(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)))))))
print-timerfunction
(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))
state-p1-update-print-basetheorem
(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)))))
set-print-base-radixfunction
(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))))
known-package-alistfunction
(defun known-package-alist (state) (declare (xargs :guard (state-p state))) (getpropc 'known-package-alist 'global-value))
symbol-in-current-package-pfunction
(defun symbol-in-current-package-p (x state) (declare (xargs :guard (symbolp x))) (or (equal (symbol-package-name x) (f-get-global 'current-package state)) (and (ec-call (member-equal x (package-entry-imports (find-package-entry (f-get-global 'current-package state) (known-package-alist state))))) t)))
prin1$function
(defun prin1$ (x channel state) (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))))) (cond ((acl2-numberp x) (princ$ x channel state)) ((characterp x) (pprogn (princ$ "#\" channel state) (princ$ (case x (#\ "Newline") (#\ "Space") (#\ "Page") (#\ "Tab") (#\ "Rubout") (#\ "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))))
local
(local (in-theory (enable boundp-global1)))
current-packagefunction
(defun current-package (state) (declare (xargs :guard (state-p state))) (f-get-global 'current-package state))
state-p1-update-nth-2-worldtheorem
(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)))))
*initial-untouchable-fns*constant
(defconst *initial-untouchable-fns* '(coerce-state-to-object coerce-object-to-state create-state user-stobj-alist f-put-ld-specials 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! install-event defuns-fn1 process-embedded-events encapsulate-pass-2 include-book-fn1 maybe-add-command-landmark ubt-ubu-fn1 install-event-defuns defthm-fn1 defuns-fn0 ld-read-eval-print ld-loop ld-fn-body ld-fn0 ld-fn1 update-user-stobj-alist big-n decrement-big-n zp-big-n protected-eval 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 trace-evisceration-alist update-enabled-structure-array apply-user-stobj-alist-or-kwote doppelganger-apply$-userfn doppelganger-badge-userfn aset1-trusted))
*initial-untouchable-vars*constant
(defconst *initial-untouchable-vars* '(temp-touchable-vars temp-touchable-fns user-home-dir acl2-version certify-book-info connected-book-directory axiomsp current-acl2-world undone-worlds-kill-ring acl2-world-alist timer-alist main-timer wormhole-name wormhole-status proof-tree fmt-soft-right-margin fmt-hard-right-margin inhibit-output-lst inhibited-summary-types in-verify-flg mswindows-drive 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 checkpoint-summary-limit 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 total-parallelism-work-limit-error waterfall-parallelism waterfall-printing redundant-with-raw-code-okp print-base print-case print-length print-level print-lines print-right-margin iprint-ar iprint-fal iprint-hard-bound iprint-soft-bound term-evisc-tuple abbrev-evisc-tuple gag-mode-evisc-tuple brr-evisc-tuple serialize-character serialize-character-system 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 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))
ld-skip-proofspfunction
(defun ld-skip-proofsp (state) (declare (xargs :guard (state-p state))) (f-get-global 'ld-skip-proofsp state))
subst-for-nth-argfunction
(defun subst-for-nth-arg (new n args) (declare (xargs :mode :program)) (cond ((int= n 0) (cons new (cdr args))) (t (cons (car args) (subst-for-nth-arg new (1- n) (cdr args))))))
the-mvmacro
(defmacro the-mv (args type body &optional state-pos) (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))))))
other
(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))))
other
(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))))
intersection-equalfunction
(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))))
intersection-eqmacro
(defmacro intersection-eq (&rest lst) `(intersection$ ,@LST :test 'eq))
intersection-eq-exec-is-intersection-equaltheorem
(defthm intersection-eq-exec-is-intersection-equal (equal (intersection-eq-exec l1 l2) (intersection-equal l1 l2)))
intersection-eql-exec-is-intersection-equaltheorem
(defthm intersection-eql-exec-is-intersection-equal (equal (intersection-eql-exec l1 l2) (intersection-equal l1 l2)))
intersection-equal-with-intersection-eq-exec-guardmacro
(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))))
intersection-equal-with-intersection-eql-exec-guardmacro
(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))))
intersection$macro
(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 :logic ,(XXXJOIN 'INTERSECTION-EQUAL-WITH-INTERSECTION-EQ-EXEC-GUARD VARS) :exec ,(XXXJOIN 'INTERSECTION-EQ-EXEC VARS))) ((equal test ''eql) `(let-mbe ,BINDINGS :guardp nil :logic ,(XXXJOIN 'INTERSECTION-EQUAL-WITH-INTERSECTION-EQL-EXEC-GUARD VARS) :exec ,(XXXJOIN 'INTERSECTION-EQL-EXEC VARS))) (t (xxxjoin 'intersection-equal args))))))))
set-enforce-redundancymacro
(defmacro set-enforce-redundancy (x) `(with-output :off (event summary) (progn (table acl2-defaults-table :enforce-redundancy ,X) (table acl2-defaults-table :enforce-redundancy))))
get-enforce-redundancyfunction
(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))))
default-verify-guards-eagerness-from-tablemacro
(defmacro default-verify-guards-eagerness-from-table (alist) `(or (cdr (assoc-eq :verify-guards-eagerness ,ALIST)) 1))
default-verify-guards-eagernessfunction
(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)))
set-verify-guards-eagernessmacro
(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))))
default-compile-fnsfunction
(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))))
set-compile-fnsmacro
(defmacro set-compile-fns (x) `(with-output :off (event summary) (progn (table acl2-defaults-table :compile-fns ,X) (table acl2-defaults-table :compile-fns))))
set-compiler-enabledfunction
(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))))
set-port-file-enabledfunction
(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))))
default-measure-functionfunction
(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))
set-measure-functionmacro
(defmacro set-measure-function (name) `(with-output :off (event summary) (progn (table acl2-defaults-table :measure-function ',NAME) (table acl2-defaults-table :measure-function))))
default-well-founded-relationfunction
(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<))
set-well-founded-relationmacro
(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))))
default-defun-mode-from-tablemacro
(defmacro default-defun-mode-from-table (alist) `(let ((val (cdr (assoc-eq :defun-mode ,ALIST)))) (if (member-eq val '(:logic :program)) val :program)))
default-defun-modefunction
(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)))
default-defun-mode-from-statefunction
(defun default-defun-mode-from-state (state) (declare (xargs :guard (state-p state))) (default-defun-mode (w state)))
invisible-fns-tablefunction
(defun invisible-fns-table (wrld) (declare (xargs :guard (plist-worldp wrld))) (table-alist 'invisible-fns-table wrld))
set-invisible-fns-tablemacro
(defmacro set-invisible-fns-table (alist) `(table invisible-fns-table nil ',(COND ((EQ ALIST T) '((BINARY-+ UNARY--) (BINARY-* UNARY-/) (UNARY-- UNARY--) (UNARY-/ UNARY-/))) (T ALIST)) :clear))
unary-function-symbol-listpfunction
(defun unary-function-symbol-listp (lst wrld) (declare (xargs :guard (plist-worldp wrld))) (cond ((atom lst) (null lst)) (t (and (symbolp (car lst)) (let ((formals (getpropc (car lst) 'formals nil wrld))) (and (consp formals) (null (cdr formals)))) (unary-function-symbol-listp (cdr lst) wrld)))))
get-non-unary-function-symbolfunction
(defun get-non-unary-function-symbol (lst wrld) (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)))))
invisible-fns-entrypfunction
(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))))
other
(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))))
other
(set-invisible-fns-table t)
add-invisible-fnsmacro
(defmacro add-invisible-fns (top-fn &rest unary-fns) (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))
remove-invisible-fnsmacro
(defmacro remove-invisible-fns (top-fn &rest unary-fns) (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))
set-invisible-fns-alistmacro
(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."))
invisible-fns-alistmacro
(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."))
set-bogus-defun-hints-okmacro
(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))))
set-bogus-measure-okmacro
(defmacro set-bogus-measure-ok (x) `(set-bogus-defun-hints-ok ,X))
set-bogus-mutual-recursion-okmacro
(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))))
set-irrelevant-formals-okmacro
(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))))
set-ignore-okmacro
(defmacro set-ignore-ok (x) `(with-output :off (event summary) (progn (table acl2-defaults-table :ignore-ok ,X) (table acl2-defaults-table :ignore-ok))))
other
(set-table-guard inhibit-warnings-table (stringp key) :topic set-inhibit-warnings)
set-inhibit-warnings!macro
(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))))
set-inhibit-warningsmacro
(defmacro set-inhibit-warnings (&rest lst) `(local (set-inhibit-warnings! ,@LST)))
remove1-assoc-string-equalfunction
(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))))))
toggle-inhibit-warning!macro
(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))
toggle-inhibit-warningmacro
(defmacro toggle-inhibit-warning (str) `(local (toggle-inhibit-warning! ,STR)))
other
(set-table-guard inhibit-ero-table (stringp key) :topic set-inhibit-er)
set-inhibit-er!macro
(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))))
set-inhibit-ermacro
(defmacro set-inhibit-er (&rest lst) `(local (set-inhibit-er! ,@LST)))
toggle-inhibit-er!macro
(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))
toggle-inhibit-ermacro
(defmacro toggle-inhibit-er (str) `(local (toggle-inhibit-er! ,STR)))
chk-inhibited-summary-typesfunction
(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)))
set-inhibited-summary-types-statefunction
(defun set-inhibited-summary-types-state (lst state) (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)))))
set-state-okmacro
(defmacro set-state-ok (x) `(with-output :off (event summary) (progn (table acl2-defaults-table :state-ok ,X) (table acl2-defaults-table :state-ok))))
set-let*-abstractionpmacro
(defmacro set-let*-abstractionp (x) `(with-output :off (event summary) (progn (table acl2-defaults-table :let*-abstractionp ,X) (table acl2-defaults-table :let*-abstractionp))))
set-let*-abstractionmacro
(defmacro set-let*-abstraction (x) `(set-let*-abstractionp ,X))
let*-abstractionpfunction
(defun let*-abstractionp (state) (declare (xargs :mode :program)) (and (cdr (assoc-eq :let*-abstractionp (table-alist 'acl2-defaults-table (w state)))) (pkg-witness (current-package state))))
*initial-backchain-limit*constant
(defconst *initial-backchain-limit* '(nil nil))
*initial-default-backchain-limit*constant
(defconst *initial-default-backchain-limit* '(nil nil))
set-backchain-limitmacro
(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))))
backchain-limitfunction
(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))))
set-default-backchain-limitmacro
(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))))
default-backchain-limitfunction
(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))))
step-limit-from-tablefunction
(defun step-limit-from-table (wrld) (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*))
set-prover-step-limitmacro
(defmacro set-prover-step-limit (limit) `(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 (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)))))
*default-rewrite-stack-limit*constant
(defconst *default-rewrite-stack-limit* 1000)
set-rewrite-stack-limitmacro
(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))))
rewrite-stack-limitfunction
(defun rewrite-stack-limit (wrld) (declare (xargs :guard (and (plist-worldp wrld) (alistp (table-alist 'acl2-defaults-table wrld))))) (or (cdr (assoc-eq :rewrite-stack-limit (table-alist 'acl2-defaults-table wrld))) *default-rewrite-stack-limit*))
case-split-limitationsfunction
(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))))
sr-limitmacro
(defmacro sr-limit (wrld) `(car (case-split-limitations ,WRLD)))
case-limitmacro
(defmacro case-limit (wrld) `(cadr (case-split-limitations ,WRLD)))
set-case-split-limitationsmacro
(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))))
*initial-acl2-defaults-table*constant
(defconst *initial-acl2-defaults-table* `((:defun-mode . :logic) (:include-book-dir-alist) (:case-split-limitations 500 100) (:tau-auto-modep . ,(CDDR *TAU-STATUS-BOOT-STRAP-SETTINGS*)) (:subgoal-loop-limits 1000 . 2)))
untrans-tablefunction
(defun untrans-table (wrld) (declare (xargs :guard (plist-worldp wrld))) (table-alist 'untrans-table wrld))
other
(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)
add-macro-fnmacro
(defmacro add-macro-fn (macro macro-fn &optional right-associate-p) `(progn (add-macro-alias ,MACRO ,MACRO-FN) (table untrans-table (deref-macro-name ',MACRO-FN (macro-aliases world)) '(,MACRO . ,RIGHT-ASSOCIATE-P))))
add-binopmacro
(defmacro add-binop (macro macro-fn) `(add-macro-fn ,MACRO ,MACRO-FN t))
remove-macro-fnmacro
(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))
remove-binopmacro
(defmacro remove-binop (macro-fn) `(remove-macro-fn ,MACRO-FN))
match-free-defaultfunction
(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))))
set-match-free-defaultmacro
(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))))
set-match-free-errormacro
(defmacro set-match-free-error (x) (declare (xargs :guard (booleanp x))) `(f-put-global 'match-free-error ,X state))
match-free-overridefunction
(defun match-free-override (wrld) (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)))))
add-match-free-overridemacro
(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)) '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))))))))))))
add-include-book-dirmacro
(defmacro add-include-book-dir (keyword dir) `(change-include-book-dir ',KEYWORD ',DIR 'add-include-book-dir state))
delete-include-book-dirmacro
(defmacro delete-include-book-dir (keyword) `(change-include-book-dir ,KEYWORD nil 'delete-include-book-dir state))
other
(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!)
raw-include-book-dir-pfunction
(defun raw-include-book-dir-p (state) (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)))
add-include-book-dir!macro
(defmacro add-include-book-dir! (keyword dir) `(change-include-book-dir ',KEYWORD ',DIR 'add-include-book-dir! state))
delete-include-book-dir!macro
(defmacro delete-include-book-dir! (keyword) `(change-include-book-dir ,KEYWORD nil 'delete-include-book-dir! state))
*non-linear-rounds-value*constant
(defconst *non-linear-rounds-value* 3)
non-linearpfunction
(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)))
set-non-linearpmacro
(defmacro set-non-linearp (toggle) `(with-output :off (event summary) (progn (table acl2-defaults-table :non-linearp ,TOGGLE) (table acl2-defaults-table :non-linearp))))
set-non-linearmacro
(defmacro set-non-linear (toggle) `(set-non-linearp ,TOGGLE))
tau-auto-modepfunction
(defun tau-auto-modep (wrld) (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*) nil)) (t (cdr temp)))))
set-tau-auto-modemacro
(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))))
subgoal-loop-limitsfunction
(defun subgoal-loop-limits (wrld) (declare (xargs :guard (and (plist-worldp wrld) (alistp (table-alist 'acl2-defaults-table wrld))))) (cdr (assoc-eq :subgoal-loop-limits (table-alist 'acl2-defaults-table wrld))))
set-subgoal-loop-limitsmacro
(defmacro set-subgoal-loop-limits (val) `(with-output :off (event summary) (progn (table acl2-defaults-table :subgoal-loop-limits (let ((val ,VAL)) (cond ((eq val nil) '(nil)) ((eq val t) '(nil . 2)) ((natp val) (cons val 2)) ((eq val :default) '(1000 . 2)) (t val)))) (table acl2-defaults-table :subgoal-loop-limits))))
constraint-trackingfunction
(defun constraint-tracking (wrld) (declare (xargs :guard (and (plist-worldp wrld) (alistp (table-alist 'acl2-defaults-table wrld))))) (cdr (assoc-eq :constraint-tracking (table-alist 'acl2-defaults-table wrld))))
set-constraint-trackingmacro
(defmacro set-constraint-tracking (val) `(with-output :off (event summary) (progn (table acl2-defaults-table :constraint-tracking ,VAL) (table acl2-defaults-table :constraint-tracking))))
get-in-theory-redundant-okpfunction
(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 nil))))
defttagmacro
(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))))
other
(set-table-guard macro-aliases-table (and (symbolp key) (not (eq (getpropc key 'macro-args t world) t)) (symbolp val)))
other
(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)
macro-aliasesfunction
(defun macro-aliases (wrld) (declare (xargs :guard (plist-worldp wrld))) (table-alist 'macro-aliases-table wrld))
add-macro-aliasmacro
(defmacro add-macro-alias (macro-name fn-name) `(table macro-aliases-table ',MACRO-NAME (deref-macro-name ',FN-NAME (macro-aliases world))))
deref-macro-namefunction
(defun deref-macro-name (macro-name macro-aliases) (declare (xargs :guard (if (symbolp macro-name) (alistp macro-aliases) (symbol-alistp macro-aliases)))) (let ((entry (assoc-eq macro-name macro-aliases))) (if entry (cdr entry) macro-name)))
other
(add-macro-alias real/rationalp rationalp)
other
(add-macro-alias member-eq member-equal)
other
(add-macro-alias member member-equal)
other
(add-macro-alias assoc-eq assoc-equal)
other
(add-macro-alias assoc assoc-equal)
other
(add-macro-alias subsetp-eq subsetp-equal)
other
(add-macro-alias subsetp subsetp-equal)
other
(add-macro-alias rassoc-eq rassoc-equal)
other
(add-macro-alias rassoc rassoc-equal)
other
(add-macro-alias remove-eq remove-equal)
other
(add-macro-alias remove remove-equal)
other
(add-macro-alias remove1-eq remove1-equal)
other
(add-macro-alias remove1 remove1-equal)
other
(add-macro-alias position-eq position-equal)
other
(add-macro-alias position position-equal)
other
(add-macro-alias put-assoc put-assoc-equal)
other
(add-macro-alias union-eq union-equal)
other
(add-macro-alias union$ union-equal)
delete-assoc-eq-execmacro
(defmacro delete-assoc-eq-exec (key alist) `(remove1-assoc-eq-exec ,KEY ,ALIST))
other
(add-macro-alias delete-assoc-eq-exec remove1-assoc-eq-exec)
delete-assoc-eql-execmacro
(defmacro delete-assoc-eql-exec (key alist) `(remove1-assoc-eql-exec ,KEY ,ALIST))
other
(add-macro-alias delete-assoc-eql-exec remove1-assoc-eql-exec)
delete-assoc-equalmacro
(defmacro delete-assoc-equal (key alist) `(remove1-assoc-equal ,KEY ,ALIST))
delete-assoc-eqmacro
(defmacro delete-assoc-eq (key alist) `(remove1-assoc-eq ,KEY ,ALIST))
delete-assocmacro
(defmacro delete-assoc (key alist) `(remove1-assoc ,KEY ,ALIST))
remove-macro-aliasmacro
(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))
other
(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))))
other
(table nth-aliases-table nil nil :clear)
nth-aliasesfunction
(defun nth-aliases (wrld) (declare (xargs :guard (plist-worldp wrld))) (table-alist 'nth-aliases-table wrld))
add-nth-aliasmacro
(defmacro add-nth-alias (alias-name name) `(table nth-aliases-table ',ALIAS-NAME ',NAME))
remove-nth-aliasmacro
(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))
default-hintsfunction
(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))))
set-default-hintsmacro
(defmacro set-default-hints (lst) `(local (set-default-hints! ,LST)))
set-default-hints!macro
(defmacro set-default-hints! (lst) `(with-output :off (event summary) (progn (table default-hints-table t ,LST) (table default-hints-table t))))
add-default-hintsmacro
(defmacro add-default-hints (lst &key at-end) `(local (add-default-hints! ,LST :at-end ,AT-END)))
add-default-hints!macro
(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))))
remove-default-hintsmacro
(defmacro remove-default-hints (lst) `(local (remove-default-hints! ,LST)))
remove-default-hints!macro
(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))))
set-override-hints-macromacro
(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)))
add-override-hints!macro
(defmacro add-override-hints! (lst &key at-end) (declare (xargs :guard (booleanp at-end))) `(set-override-hints-macro ,LST ,AT-END 'add-override-hints!))
add-override-hintsmacro
(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)))
set-override-hints!macro
(defmacro set-override-hints! (lst) `(set-override-hints-macro ,LST :clear 'set-override-hints!))
set-override-hintsmacro
(defmacro set-override-hints (lst) `(local (set-override-hints-macro ,LST :clear 'set-override-hints)))
remove-override-hints!macro
(defmacro remove-override-hints! (lst) `(set-override-hints-macro ,LST :remove 'remove-override-hints!))
remove-override-hintsmacro
(defmacro remove-override-hints (lst) `(local (set-override-hints-macro ,LST :remove 'remove-override-hints)))
set-dwp!macro
(defmacro set-dwp! (dwp) `(with-output :off (event summary) (progn (table dwp-table t ,DWP) (table dwp-table t))))
get-dwpfunction
(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))))
set-rw-cache-statemacro
(defmacro set-rw-cache-state (val) `(local (set-rw-cache-state! ,VAL)))
set-rw-cache-state!macro
(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))))
*legal-rw-cache-states*constant
(defconst *legal-rw-cache-states* '(t nil :disabled :atom))
other
(set-table-guard rw-cache-state-table (case key ((t) (member-eq val *legal-rw-cache-states*)) (t nil)) :topic set-rw-cache-state)
other
(set-table-guard induction-depth-limit-table (and (eq key t) (or (null val) (natp val))) :topic set-induction-depth-limit)
*induction-depth-limit-default*constant
(defconst *induction-depth-limit-default* 9)
other
(table induction-depth-limit-table t *induction-depth-limit-default*)
set-induction-depth-limit!macro
(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))))
set-induction-depth-limitmacro
(defmacro set-induction-depth-limit (val) `(local (set-induction-depth-limit! ,VAL)))
completion-of-+axiom
(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)
default-+-1theorem
(defthm default-+-1 (implies (not (acl2-numberp x)) (equal (+ x y) (fix y))) :hints (("Goal" :use completion-of-+)))
default-+-2theorem
(defthm default-+-2 (implies (not (acl2-numberp y)) (equal (+ x y) (fix x))) :hints (("Goal" :use completion-of-+)))
completion-of-*axiom
(defaxiom completion-of-* (equal (* x y) (if (acl2-numberp x) (if (acl2-numberp y) (* x y) 0) 0)) :rule-classes nil)
default-*-1theorem
(defthm default-*-1 (implies (not (acl2-numberp x)) (equal (* x y) 0)))
default-*-2theorem
(defthm default-*-2 (implies (not (acl2-numberp y)) (equal (* x y) 0)))
completion-of-unary-minusaxiom
(defaxiom completion-of-unary-minus (equal (- x) (if (acl2-numberp x) (- x) 0)) :rule-classes nil)
default-unary-minustheorem
(defthm default-unary-minus (implies (not (acl2-numberp x)) (equal (- x) 0)))
completion-of-unary-/axiom
(defaxiom completion-of-unary-/ (equal (/ x) (if (and (acl2-numberp x) (not (equal x 0))) (/ x) 0)) :rule-classes nil)
default-unary-/theorem
(defthm default-unary-/ (implies (or (not (acl2-numberp x)) (equal x 0)) (equal (/ x) 0)))
completion-of-<axiom
(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)
default-<-1theorem
(defthm default-<-1 (implies (not (acl2-numberp x)) (equal (< x y) (< 0 y))) :hints (("Goal" :use (completion-of-< (:instance completion-of-< (x 0))))))
default-<-2theorem
(defthm default-<-2 (implies (not (acl2-numberp y)) (equal (< x y) (< x 0))) :hints (("Goal" :use (completion-of-< (:instance completion-of-< (y 0))))))
completion-of-caraxiom
(defaxiom completion-of-car (equal (car x) (cond ((consp x) (car x)) (t nil))) :rule-classes nil)
default-cartheorem
(defthm default-car (implies (not (consp x)) (equal (car x) nil)))
completion-of-cdraxiom
(defaxiom completion-of-cdr (equal (cdr x) (cond ((consp x) (cdr x)) (t nil))) :rule-classes nil)
default-cdrtheorem
(defthm default-cdr (implies (not (consp x)) (equal (cdr x) nil)))
cons-car-cdrtheorem
(defthm cons-car-cdr (equal (cons (car x) (cdr x)) (if (consp x) x (cons nil nil))))
completion-of-char-codeaxiom
(defaxiom completion-of-char-code (equal (char-code x) (if (characterp x) (char-code x) 0)) :rule-classes nil)
default-char-codetheorem
(defthm default-char-code (implies (not (characterp x)) (equal (char-code x) 0)) :hints (("Goal" :use completion-of-char-code)))
completion-of-code-charaxiom
(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)
default-code-chartheorem
(defthm default-code-char (implies (and (syntaxp (not (equal x ''0))) (not (and (integerp x) (>= x 0) (< x 256)))) (equal (code-char x) *null-char*)) :hints (("Goal" :use completion-of-code-char)))
completion-of-complexaxiom
(defaxiom completion-of-complex (equal (complex x y) (complex (if (real/rationalp x) x 0) (if (real/rationalp y) y 0))) :rule-classes nil)
default-complex-1theorem
(defthm default-complex-1 (implies (not (real/rationalp x)) (equal (complex x y) (complex 0 y))) :hints (("Goal" :use completion-of-complex)))
default-complex-2theorem
(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))))))
complex-0theorem
(defthm complex-0 (equal (complex x 0) (realfix x)) :hints (("Goal" :use ((:instance complex-definition (y 0))))))
add-def-complextheorem
(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)
realpart-+theorem
(defthm realpart-+ (equal (realpart (+ x y)) (+ (realpart x) (realpart y))) :hints (("Goal" :use add-def-complex)))
imagpart-+theorem
(defthm imagpart-+ (equal (imagpart (+ x y)) (+ (imagpart x) (imagpart y))) :hints (("Goal" :use add-def-complex)))
encapsulate
(encapsulate nil (logic) (verify-termination-boot-strap make-character-list))
completion-of-coerceaxiom
(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)
default-coerce-1theorem
(defthm default-coerce-1 (implies (not (stringp x)) (equal (coerce x 'list) nil)) :hints (("Goal" :use (:instance completion-of-coerce (y 'list)))))
make-character-list-make-character-listtheorem
(defthm make-character-list-make-character-list (equal (make-character-list (make-character-list x)) (make-character-list x)))
default-coerce-2theorem
(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))))))
default-coerce-3theorem
(defthm default-coerce-3 (implies (not (consp x)) (equal (coerce x 'string) "")) :hints (("Goal" :use (:instance completion-of-coerce (y 'string)))))
completion-of-denominatoraxiom
(defaxiom completion-of-denominator (equal (denominator x) (if (rationalp x) (denominator x) 1)) :rule-classes nil)
default-denominatortheorem
(defthm default-denominator (implies (not (rationalp x)) (equal (denominator x) 1)) :hints (("Goal" :use completion-of-denominator)))
completion-of-imagpartaxiom
(defaxiom completion-of-imagpart (equal (imagpart x) (if (acl2-numberp x) (imagpart x) 0)) :rule-classes nil)
default-imagparttheorem
(defthm default-imagpart (implies (not (acl2-numberp x)) (equal (imagpart x) 0)))
completion-of-intern-in-package-of-symbolaxiom
(defaxiom completion-of-intern-in-package-of-symbol (equal (intern-in-package-of-symbol x y) (if (and (stringp x) (symbolp y)) (intern-in-package-of-symbol x y) nil)) :rule-classes nil)
default-intern-in-package-of-symboltheorem
(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)))
completion-of-numeratoraxiom
(defaxiom completion-of-numerator (equal (numerator x) (if (rationalp x) (numerator x) 0)) :rule-classes nil)
default-numeratortheorem
(defthm default-numerator (implies (not (rationalp x)) (equal (numerator x) 0)))
completion-of-realpartaxiom
(defaxiom completion-of-realpart (equal (realpart x) (if (acl2-numberp x) (realpart x) 0)) :rule-classes nil)
default-realparttheorem
(defthm default-realpart (implies (not (acl2-numberp x)) (equal (realpart x) 0)))
double-rewritefunction
(defun double-rewrite (x) (declare (xargs :guard t)) x)
chk-with-prover-time-limit-argfunction
(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)))))
with-prover-time-limit1macro
(defmacro with-prover-time-limit1 (time form) `(return-last 'with-prover-time-limit1-raw ,TIME ,FORM))
with-prover-time-limitmacro
(defmacro with-prover-time-limit (time form) `(with-prover-time-limit1 (chk-with-prover-time-limit-arg ,TIME) ,FORM))
catch-time-limit5macro
(defmacro catch-time-limit5 (form) `(mv-let (step-limit x1 x2 x3 x4 state) ,FORM (pprogn (f-put-global 'last-step-limit step-limit state) (mv-let (nullp temp state) (read-acl2-oracle state) (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)))))))
*interrupt-string*constant
(defconst *interrupt-string* "Aborting due to an interrupt.")
time-limit5-reached-pfunction
(defun time-limit5-reached-p (msg) (declare (xargs :guard t)) (declare (ignore msg)) nil)
catch-step-limitmacro
(defmacro catch-step-limit (form) `(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))))))
*guard-checking-values*constant
(defconst *guard-checking-values* '(t nil :nowarn :all :none))
chk-with-guard-checking-argfunction
(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))))))
with-guard-checking1macro
(defmacro with-guard-checking1 (val gated-form) `(return-last 'with-guard-checking1-raw ,VAL ,GATED-FORM))
with-guard-checking-gatefunction
(defun with-guard-checking-gate (form) (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))))
with-guard-checkingmacro
(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) ,FORM)))
with-guard-checking-error-triplemacro
(defmacro with-guard-checking-error-triple (val form) `(prog2$ (chk-with-guard-checking-arg ,VAL) (state-global-let* ((guard-checking-on ,VAL)) ,FORM)))
with-guard-checking-eventmacro
(defmacro with-guard-checking-event (val form) `(with-guard-checking-error-triple ,VAL ,FORM))
in-theory
(in-theory (disable abort! (:executable-counterpart abort!) p! (:executable-counterpart p!) (:executable-counterpart hide)))
bind-acl2-time-limitmacro
(defmacro bind-acl2-time-limit (form) form)
our-with-terminal-inputmacro
(defmacro our-with-terminal-input (x) x)
wormhole1function
(defun wormhole1 (name input form ld-specials) (declare (xargs :guard t)) (declare (ignore name input form ld-specials)) nil)
wormhole-pfunction
(defun wormhole-p (state) (declare (xargs :guard (state-p state))) (read-acl2-oracle state))
duplicatesfunction
(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)))))
set-equalp-equalfunction
(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)))
other
(progn (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)))))))))))))) (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))))))))))))))))
|Access REWRITE-CONSTANT record field CURRENT-CLAUSE|macro
(defmacro |Access REWRITE-CONSTANT record field CURRENT-CLAUSE| (current-clause) (cons 'let (cons (cons (cons 'current-clause (cons current-clause 'nil)) 'nil) (cons '(cdr (car (cdr (cdr (cdr current-clause))))) 'nil))))
record-errorfunction
(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))
record-accessor-function-namefunction
(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))
accessmacro
(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)))))
mfc-clausefunction
(defun mfc-clause (mfc) (declare (xargs :guard t)) (if (and (true-listp mfc) (true-listp (access metafunction-context mfc :rcnst)) (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))
mfc-rdepthfunction
(defun mfc-rdepth (mfc) (declare (xargs :guard t)) (if (true-listp mfc) (access metafunction-context mfc :rdepth) nil))
type-alist-entrypfunction
(defun type-alist-entryp (x) (declare (xargs :guard t)) (and (consp x) (pseudo-termp (car x)) (consp (cdr x)) (integerp (cadr x)) (<= -16384 (cadr x)) (<= (cadr x) 16383)))
type-alistpfunction
(defun type-alistp (x) (declare (xargs :guard t)) (if (consp x) (and (type-alist-entryp (car x)) (type-alistp (cdr x))) (eq x nil)))
mfc-type-alistfunction
(defun mfc-type-alist (mfc) (declare (xargs :guard t)) (if (and (true-listp mfc) (type-alistp (access metafunction-context mfc :type-alist))) (access metafunction-context mfc :type-alist) nil))
mfc-ancestorsfunction
(defun mfc-ancestors (mfc) (declare (xargs :guard t)) (if (and (true-listp mfc) (true-listp (access metafunction-context mfc :ancestors))) (access metafunction-context mfc :ancestors) nil))
mfc-unify-substfunction
(defun mfc-unify-subst (mfc) (declare (xargs :guard t)) (if (true-listp mfc) (access metafunction-context mfc :unify-subst) nil))
mfc-worldfunction
(defun mfc-world (mfc) (declare (xargs :guard t)) (if (true-listp mfc) (access metafunction-context mfc :wrld) nil))
pseudo-term-listp-mfc-clausetheorem
(defthm pseudo-term-listp-mfc-clause (pseudo-term-listp (mfc-clause mfc)))
type-alistp-mfc-type-alisttheorem
(defthm type-alistp-mfc-type-alist (type-alistp (mfc-type-alist mfc)))
bad-atomfunction
(defun bad-atom (x) (declare (xargs :guard t :mode :logic)) (not (or (consp x) (acl2-numberp x) (symbolp x) (characterp x) (stringp x))))
bad-atom-compound-recognizertheorem
(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)
booleanp-bad-atom<=axiom
(defaxiom booleanp-bad-atom<= (or (equal (bad-atom<= x y) t) (equal (bad-atom<= x y) nil)) :rule-classes :type-prescription)
bad-atom<=-antisymmetricaxiom
(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)
bad-atom<=-transitiveaxiom
(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)))
bad-atom<=-totalaxiom
(defaxiom bad-atom<=-total (implies (and (bad-atom x) (bad-atom y)) (or (bad-atom<= x y) (bad-atom<= y x))) :rule-classes nil)
alphorderfunction
(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 (cond ((symbolp x) (cond ((symbolp y) (not (symbol< y x))) (t t))) ((symbolp y) nil) (t (bad-atom<= x y))))))
lexorderfunction
(defun lexorder (x y) (declare (xargs :guard t)) (cond ((atom x) (cond ((atom y) (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
(local (defthm bad-atom<=-reflexive (implies (bad-atom x) (bad-atom<= x x)) :hints (("Goal" :by (:instance bad-atom<=-total (y x))))))
local
(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
(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)))))
alphorder-reflexivetheorem
(defthm alphorder-reflexive (implies (not (consp x)) (alphorder x x)))
local
(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))))))
alphorder-transitivetheorem
(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<))))
alphorder-anti-symmetrictheorem
(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))))))
alphorder-totaltheorem
(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)))))
lexorder-reflexivetheorem
(defthm lexorder-reflexive (lexorder x x))
lexorder-anti-symmetrictheorem
(defthm lexorder-anti-symmetric (implies (and (lexorder x y) (lexorder y x)) (equal x y)) :rule-classes :forward-chaining)
lexorder-transitivetheorem
(defthm lexorder-transitive (implies (and (lexorder x y) (lexorder y z)) (lexorder x z)) :rule-classes ((:rewrite :match-free :all)))
lexorder-totaltheorem
(defthm lexorder-total (or (lexorder x y) (lexorder y x)) :rule-classes ((:forward-chaining :corollary (implies (not (lexorder x y)) (lexorder y x)))))
merge-lexorderfunction
(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
(local (defthm <=-len-evens (<= (len (evens l)) (len l)) :rule-classes :linear :hints (("Goal" :induct (evens l)))))
local
(local (defthm <-len-evens (implies (consp (cdr l)) (< (len (evens l)) (len l))) :rule-classes :linear))
true-listp-merge-sort-lexordertheorem
(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)
merge-sort-lexorderfunction
(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))))
resize-list-execfunction
(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)))
resize-listfunction
(defun resize-list (lst n default-value) (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 (resize-list-exec lst n default-value nil)))
resize-list-exec-is-resize-listtheorem
(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)))))
other
(verify-guards resize-list)
e/d-fnfunction
(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))))
e/dmacro
(defmacro e/d (&rest theories) (declare (xargs :guard (true-list-listp theories))) (cond ((atom theories) '(current-theory :here)) (t (e/d-fn '(current-theory :here) theories t))))
rewrite-lambda-objects-theorymacro
(defmacro rewrite-lambda-objects-theory nil '(e/d ((:e rewrite-lambda-modep) (:d rewrite-lambda-modep)) nil))
syntactically-clean-lambda-objects-theorymacro
(defmacro syntactically-clean-lambda-objects-theory nil '(e/d ((:e rewrite-lambda-modep)) ((:d rewrite-lambda-modep))))
hands-off-lambda-objects-theorymacro
(defmacro hands-off-lambda-objects-theory nil '(e/d nil ((:e rewrite-lambda-modep))))
other
(f-put-global 'ld-skip-proofsp nil state)
encapsulate
(encapsulate nil (logic) (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) (verify-termination-boot-strap acl2-count) (verify-termination-boot-strap nonnegative-integer-quotient) (verify-termination-boot-strap floor) (verify-termination-boot-strap symbol-listp) (verify-termination-boot-strap binary-append) (verify-termination-boot-strap string-append) (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))
mod-exptfunction
(defun 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))))) (mod (expt base exp) mod))
conjoin-clausesfunction
(defun conjoin-clauses (clause-list) (declare (xargs :guard (true-list-listp clause-list))) (conjoin (disjoin-lst clause-list)))
*true-clause*constant
(defconst *true-clause* (list *t*))
*false-clause*constant
(defconst *false-clause* nil)
clauses-resultfunction
(defun clauses-result (tuple) (declare (xargs :guard (true-listp tuple))) (cond ((car tuple) (list *false-clause*)) (t (cadr tuple))))
*top-hint-keywords*constant
(defconst *top-hint-keywords* '(:use :cases :by :bdd :clause-processor :or))
*hint-keywords*constant
(defconst *hint-keywords* (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)))
other
(set-table-guard custom-keywords-table (and (not (member-eq key *hint-keywords*)) (true-listp val) (equal (length val) 2)) :topic add-custom-keyword-hint)
add-custom-keyword-hintmacro
(defmacro add-custom-keyword-hint (key uterm1 &key (checker '(value t))) `(add-custom-keyword-hint-fn ',KEY ',UTERM1 ',CHECKER state))
remove-custom-keyword-hintmacro
(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))
splice-keyword-alistfunction
(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)))))))
show-custom-keyword-hint-expansionmacro
(defmacro show-custom-keyword-hint-expansion (flg) `(f-put-global 'show-custom-keyword-hint-expansion ,FLG state))
search-fn-guardfunction
(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))))))
search-from-startfunction
(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)))))
search-from-endfunction
(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)))))))
search-fnencapsulate
(encapsulate nil (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))))) (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) (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))))))))
searchmacro
(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))
eqlablep-nththeorem
(defthm eqlablep-nth (implies (eqlable-listp x) (eqlablep (nth n x))) :hints (("Goal" :in-theory (enable nth))))
count-stringpfunction
(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))))
count-listpfunction
(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)))))
count-fnencapsulate
(encapsulate nil (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)))))))
countmacro
(defmacro count (item sequence &key (start '0) end) `(count-fn ,ITEM ,SEQUENCE ,START ,END))
other
(verify-termination-boot-strap cpu-core-count)
other
(verify-termination-boot-strap dumb-occur-var)
other
(verify-termination-boot-strap trivial-lambda-p)
make-sharp-atsignfunction
(defun make-sharp-atsign (i) (declare (xargs :guard (natp i) :mode :program)) (concatenate 'string "#@" (coerce (explode-nonnegative-integer i 10 nil) 'string) "#"))
sharp-atsign-alistfunction
(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)))))
time$1macro
(defmacro time$1 (val form) `(return-last 'time$1-raw ,VAL ,FORM))
time$macro
(defmacro time$ (x &key (mintime '0 mintime-p) (real-mintime 'nil real-mintime-p) run-mintime minalloc msg args) (declare (xargs :guard t)) (cond ((and real-mintime-p mintime-p) (er hard 'time$ "It is illegal for a ~x0 form to specify both :real-mintime and ~ :mintime." 'time$)) (t (let ((real-mintime (or real-mintime mintime))) `(time$1 (list ,REAL-MINTIME ,RUN-MINTIME ,MINALLOC ,MSG ,ARGS) ,X)))))
encapsulate
(encapsulate nil (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))
gc-verbose-fnfunction
(defun gc-verbose-fn (arg1 arg2) (declare (ignore arg1 arg2) (xargs :guard t)) nil)
gc-verbosemacro
(defmacro gc-verbose (arg1 &optional arg2) `(gc-verbose-fn ,ARG1 ,ARG2))
get-persistent-whsfunction
(defun get-persistent-whs (name state) (declare (xargs :guard (state-p state)) (ignore name)) (read-acl2-oracle state))
file-write-date$function
(defun file-write-date$ (file state) (declare (xargs :guard (stringp file) :stobjs state) (ignorable file)) (mv-let (erp val state) (read-acl2-oracle state) (mv (and (null erp) (posp val) val) state)))
delete-file$function
(defun delete-file$ (file state) (declare (xargs :guard (stringp file) :stobjs state)) (declare (ignore file)) (mv-let (erp val state) (read-acl2-oracle state) (declare (ignore val)) (mv (null erp) state)))
debugger-enablefunction
(defun debugger-enable (state) (declare (xargs :guard t)) (f-get-global 'debugger-enable state))
print-call-historyfunction
(defun print-call-history nil (declare (xargs :guard t)) nil)
debugger-enabledp-valmacro
(defmacro debugger-enabledp-val (val) `(and (member-eq ,VAL '(t :break :break-bt :bt-break)) t))
debugger-enabledpfunction
(defun debugger-enabledp (state) (declare (xargs :guard t)) (debugger-enabledp-val (f-get-global 'debugger-enable state)))
maybe-print-call-historyfunction
(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)))
with-reckless-readtablemacro
(defmacro with-reckless-readtable (form) form)
set-debugger-enablemacro
(defmacro set-debugger-enable (val) `(set-debugger-enable-fn ,VAL state))
set-debugger-enable-fnfunction
(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)))))) (pprogn (f-put-global 'debugger-enable val state) (if (consp (f-get-global 'dmrp state)) (f-put-global 'dmrp t state) state)))
in-theory
(in-theory (disable true-listp-cadr-assoc-eq-for-open-channels-p))
in-theory
(in-theory (disable (:type-prescription consp-assoc-equal)))
in-theory
(in-theory (disable (:type-prescription true-list-listp-forward-to-true-listp-assoc-equal)))
add-@par-suffixfunction
(defun add-@par-suffix (symbol) (declare (xargs :guard (symbolp symbol))) (intern (string-append (symbol-name symbol) "@PAR") "ACL2"))
generate-@par-mappingsfunction
(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))))))
*@par-mappings*constant
(defconst *@par-mappings* (generate-@par-mappings '(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$ 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 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)))
make-identity-for-@par-mappingsfunction
(defun make-identity-for-@par-mappings (mappings) (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))))))
define-@par-macrosmacro
(defmacro define-@par-macros nil `(progn ,@(MAKE-IDENTITY-FOR-@PAR-MAPPINGS *@PAR-MAPPINGS*)))
other
(define-@par-macros)
replace-defun@par-with-defunfunction
(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))))))
mutual-recursion@parmacro
(defmacro mutual-recursion@par (&rest forms) `(mutual-recursion ,@(REPLACE-DEFUN@PAR-WITH-DEFUN FORMS)))
serial-first-form-parallel-second-formmacro
(defmacro serial-first-form-parallel-second-form (x y) (declare (ignore y)) x)
serial-onlymacro
(defmacro serial-only (x) x)
parallel-onlymacro
(defmacro parallel-only (x) (declare (ignore x)) nil)
error-in-parallelism-modemacro
(defmacro error-in-parallelism-mode (fake-return-value form) (declare (ignore fake-return-value)) form)
*waterfall-printing-values*constant
(defconst *waterfall-printing-values* '(:full :limited :very-limited))
*waterfall-parallelism-values*constant
(defconst *waterfall-parallelism-values* '(nil t :full :top-level :resource-based :resource-and-timing-based :pseudo-parallel))
symbol-constant-fnfunction
(defun symbol-constant-fn (prefix sym) (declare (xargs :guard (and (symbolp prefix) (symbolp sym)))) (intern (concatenate 'string (symbol-name prefix) "-" (symbol-name sym)) "ACL2"))
stobjs-infunction
(defun stobjs-in (fn w) (declare (xargs :guard (and (symbolp fn) (plist-worldp w)))) (if (eq fn 'cons) '(nil nil) (getpropc fn 'stobjs-in nil w)))
all-nilsfunction
(defun all-nils (lst) (declare (xargs :guard (true-listp lst))) (cond ((endp lst) t) (t (and (eq (car lst) nil) (all-nils (cdr lst))))))
*ttag-fns*constant
(defconst *ttag-fns* `((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+)))
logicpfunction
(defun logicp (fn wrld) (declare (xargs :guard (and (plist-worldp wrld) (symbolp fn)))) (or (eq fn 'cons) (not (eq (getpropc fn 'symbol-class nil wrld) :program))))
*stobjs-out-invalid*constant
(defconst *stobjs-out-invalid* '(if return-last do$ read-user-stobj-alist))
stobjs-outfunction
(defun stobjs-out (fn w) (declare (xargs :guard (and (symbolp fn) (plist-worldp w) (not (member-eq fn *stobjs-out-invalid*))))) (cond ((eq fn 'cons) '(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))))
all-nils-or-dfsfunction
(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))))))
ev-fncall-w-guard1function
(defun ev-fncall-w-guard1 (fn wrld temp-touchable-fns) (declare (xargs :guard t)) (and (plist-worldp wrld) (symbolp fn) (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))) (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))) (not (and (null formals) (getpropc fn 'stobj-function nil wrld))) (true-listp stobjs-in) (all-nils-or-dfs stobjs-in) (let ((data (list* (len formals) (programp fn wrld) (if (eq fn 'return-last) '(nil) (stobjs-out fn wrld))))) data)))))
ev-fncall-w-guardfunction
(defun ev-fncall-w-guard (fn args wrld temp-touchable-fns) (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))))
time-tracker-fnfunction
(defun time-tracker-fn (tag kwd kwdp times interval min-time msg) (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) 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 nil)))
time-trackermacro
(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))
set-absstobj-debug-fnfunction
(defun set-absstobj-debug-fn (val) (declare (xargs :guard t :verify-guards t :mode :logic)) val)
set-absstobj-debugmacro
(defmacro set-absstobj-debug (val) (declare (xargs :guard t)) `(value-triple (set-absstobj-debug-fn ,VAL) :on-skip-proofs t))
<?function
(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)))))))
tau-interval-domainpfunction
(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)) (t t)))
tau-interval-domfunction
(defun tau-interval-dom (x) (declare (xargs :guard (consp x))) (car x))
tau-interval-lo-relfunction
(defun tau-interval-lo-rel (x) (declare (xargs :guard (and (consp x) (consp (cdr x)) (consp (cadr x))))) (car (cadr x)))
tau-interval-lofunction
(defun tau-interval-lo (x) (declare (xargs :guard (and (consp x) (consp (cdr x)) (consp (cadr x))))) (cdr (cadr x)))
tau-interval-hi-relfunction
(defun tau-interval-hi-rel (x) (declare (xargs :guard (and (consp x) (consp (cdr x)) (consp (cddr x))))) (car (cddr x)))
tau-interval-hifunction
(defun tau-interval-hi (x) (declare (xargs :guard (and (consp x) (consp (cdr x)) (consp (cddr x))))) (cdr (cddr x)))
make-tau-intervalfunction
(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))))
tau-intervalpfunction
(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))
in-tau-intervalpfunction
(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))))
decimal-string-to-numberfunction
(defun decimal-string-to-number (s bound expo) (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)))))))
check-dcl-guardianfunction
(defun check-dcl-guardian (val term) (declare (xargs :guard val)) (declare (ignore val term)) t)
*gc-strategy-alist*constant
(defconst *gc-strategy-alist* '((:egc . set-gc-strategy-builtin-egc) (:delay . set-gc-strategy-builtin-delay)))
set-gc-strategy-fnfunction
(defun set-gc-strategy-fn (op threshold) (declare (xargs :guard (or (eq op :current) (assoc-eq op *gc-strategy-alist*))) (ignorable threshold)) op)
set-gc-strategymacro
(defmacro set-gc-strategy (op &optional threshold) `(set-gc-strategy-fn ,OP ,THRESHOLD))
gc-strategyfunction
(defun gc-strategy (state) (declare (xargs :stobjs state)) (read-acl2-oracle state))
*expandable-boot-strap-non-rec-fns*constant
(defconst *expandable-boot-strap-non-rec-fns* '(not implies eq atom eql = /= null endp zerop from-df synp plusp minusp listp return-last mv-list cons-with-hint the-check wormhole-eval force case-split double-rewrite))
*definition-minimal-theory*constant
(defconst *definition-minimal-theory* (list* 'mv-nth 'iff *expandable-boot-strap-non-rec-fns*))
*bbody-alist*constant
(defconst *bbody-alist* '((/= 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)))
bbody-fnfunction
(defun bbody-fn (fn) (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*)))))
bbodymacro
(defmacro bbody (fn) (cond ((and (consp fn) (consp (cdr fn)) (eq (car fn) 'quote)) (kwote (bbody-fn (cadr fn)))) (t `(bbody-fn ,FN))))
file-length$function
(defun file-length$ (file state) (declare (xargs :guard (stringp file) :stobjs state)) (declare (ignore file)) (mv-let (erp val state) (read-acl2-oracle state) (mv (and (null erp) (natp val) val) state)))
constant-t-function-arity-0function
(defun constant-t-function-arity-0 nil (declare (xargs :mode :logic :guard t)) t)
constant-nil-function-arity-0function
(defun constant-nil-function-arity-0 nil (declare (xargs :mode :logic :guard t)) nil)
constant-all-function-arity-0function
(defun constant-all-function-arity-0 nil (declare (xargs :mode :logic :guard t)) :all)
encapsulate
(encapsulate nil (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))
*read-file-into-string-bound*constant
(defconst *read-file-into-string-bound* (1- (ash 1 60)))
read-file-into-string1function
(defun read-file-into-string1 (channel state ans bound) (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) (mv nil state)) (t (mv-let (val state) (read-char$ channel state) (cond ((not (characterp val)) (mv (coerce (reverse ans) 'string) state)) (t (read-file-into-string1 channel state (cons val ans) (1- bound))))))))
read-file-into-string2-logicalfunction
(defun read-file-into-string2-logical (filename start bytes state) (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) (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 (close-input-channel chan state)) (mv nil val state)))))) (declare (ignore erp state)) (and (stringp val) (<= start (length val)) (subseq val start (if bytes (min (+ start bytes) (length val)) (length val)))))))
increment-file-clockfunction
(defun increment-file-clock (state) (declare (xargs :stobjs state)) (let ((state (non-exec (update-file-clock (1+ (file-clock state)) state)))) state))
read-file-into-string2function
(defun read-file-into-string2 (filename start bytes close state) (declare (xargs :stobjs state :guard (and (stringp filename) (natp start) (or (null bytes) (natp bytes)))) (ignore close)) (read-file-into-string2-logical filename start bytes state))
read-file-into-stringmacro
(defmacro read-file-into-string (filename &key (start '0) bytes (close ':default)) `(read-file-into-string2 ,FILENAME ,START ,BYTES ,CLOSE state))
other
(defmacro-untouchable when-pass-2 (&rest x) (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)) (set-compile-fns t) ,@X (set-compile-fns nil))))
print-cl-cache-fnfunction
(defun print-cl-cache-fn (i j) (declare (xargs :guard t) (ignore i j)) nil)
print-cl-cachemacro
(defmacro print-cl-cache (&optional i j) `(print-cl-cache-fn ,I ,J))
hons-remove-assocfunction
(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)))))
count-keysfunction
(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)))))
get-cpu-timefunction
(defun get-cpu-time (state) (declare (xargs :stobjs state)) (read-run-time state))
get-real-timefunction
(defun get-real-time (state) (declare (xargs :stobjs state)) (read-run-time state))
the-numberfunction
(defun the-number (x) (declare (xargs :guard (acl2-numberp x))) (mbe :logic (fix x) :exec x))
the-true-listfunction
(defun the-true-list (x) (declare (xargs :guard (true-listp x))) (mbe :logic (true-list-fix x) :exec x))
acl2-count-car-cdr-lineartheorem
(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)
*inline-suffix-len-minus-1*constant
(defconst *inline-suffix-len-minus-1* (1- (length *inline-suffix*)))
*notinline-suffix*constant
(defconst *notinline-suffix* "$NOTINLINE")
*notinline-suffix-len-minus-1*constant
(defconst *notinline-suffix-len-minus-1* (1- (length *notinline-suffix*)))
number-of-stringsfunction
(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)))))
get-stringfunction
(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)))))
remove-stringsfunction
(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-inline-formfunction
(defun defun-inline-form (name formals lst defun-type 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))))
defun-inlinemacro
(defmacro defun-inline (name formals &rest lst) (defun-inline-form name formals lst 'defun *inline-suffix*))
defund-inlinemacro
(defmacro defund-inline (name formals &rest lst) (defun-inline-form name formals lst 'defund *inline-suffix*))
defun-notinlinemacro
(defmacro defun-notinline (name formals &rest lst) (defun-inline-form name formals lst 'defun *notinline-suffix*))
defund-notinlinemacro
(defmacro defund-notinline (name formals &rest lst) (defun-inline-form name formals lst 'defund *notinline-suffix*))
*fixnat-type*constant
(defconst *fixnat-type* `(unsigned-byte ,*FIXNAT-BITS*))
fixnat-guardfunction
(defun fixnat-guard (val) (declare (xargs :guard t)) (unsigned-byte-p *fixnat-bits* val))
the-fixnatmacro
(defmacro the-fixnat (n) (list 'the *fixnat-type* n))
*fixnat-bits+1*constant
(defconst *fixnat-bits+1* (+ 1 *fixnat-bits*))
*fixnat-bits+2*constant
(defconst *fixnat-bits+2* (+ 2 *fixnat-bits*))
*small-bits*constant
(defconst *small-bits* (- *fixnum-bits* 3))
*small-nat-bits*constant
(defconst *small-nat-bits* (- *small-bits* 1))
*small-type*constant
(defconst *small-type* `(signed-byte ,*SMALL-BITS*))
*small-nat-type*constant
(defconst *small-nat-type* `(unsigned-byte ,*SMALL-NAT-BITS*))
*small-lo*constant
(defconst *small-lo* (- (expt 2 *small-nat-bits*)))
*small-hi*constant
(defconst *small-hi* (- (expt 2 *small-nat-bits*) 1))
small-nat-guardfunction
(defun small-nat-guard (val) (declare (xargs :guard t)) (and (natp val) (<= val *small-hi*)))
the-smallmacro
(defmacro the-small (flg x) (declare (xargs :guard (or (eq flg t) (eq flg nil)))) `(the ,(IF FLG *SMALL-NAT-TYPE* *SMALL-TYPE*) ,X))
other
(defun-inline round-to-small (flg x) (declare (type (signed-byte 61) x)) (let ((lo (if flg 0 *small-lo*))) (if (integerp x) (if (< x lo) lo (let ((hi *small-hi*)) (if (< hi x) hi x))) 0)))
make-the-smallsfunction
(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))))))
+gmacro
(defmacro +g (&rest args) (declare (xargs :guard (< (len args) 6))) `(round-to-small nil (the-fixnum (+ ,@(MAKE-THE-SMALLS ARGS)))))
+g!macro
(defmacro +g! (&rest args) (declare (xargs :guard (< (len args) 6))) `(round-to-small t (the-fixnum (+ ,@(MAKE-THE-SMALLS ARGS)))))
-gmacro
(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)))))))
-g!macro
(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)))))))
>=-lenfunction
(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)))))
all->=-lenfunction
(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))))
strip-cadrsfunction
(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))))))
strip-cddrsfunction
(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))))))
strict-table-guardfunction
(defun strict-table-guard (x) (declare (xargs :guard t)) x)