other
(in-package "ACL2")
chk-legal-defconst-namefunction
(defun chk-legal-defconst-name (name state) (cond ((legal-constantp name) (value nil)) ((legal-variable-or-constant-namep name) (er soft (cons 'defconst name) "The symbol ~x0 may not be declared as a constant because ~ it does not begin and end with the character *." name)) (t (er soft (cons 'defconst name) "Constant symbols must ~*0. Thus, ~x1 may not be ~ declared as a constant. See :DOC name and :DOC ~ defconst." (tilde-@-illegal-variable-or-constant-name-phrase name) name))))
defconst-fn1function
(defun defconst-fn1 (name val w state) (let ((w (putprop name 'const (kwote val) w))) (value w)))
other
(defrec hcomp-book-ht-entry ((status . fn-ht) (const-ht . macro-ht) cert-obj . cert-filename) t)
with-debugmacro
(defmacro with-debug (form string &rest args) `(progn (when *debug-on* (format t "; DEBUG: ") (format t ,STRING ,@ARGS)) ,FORM))
defconst-valfunction
(defun defconst-val (name form ctx wrld state) (declare (ignore name)) (er-let* ((pair (state-global-let* ((safe-mode t)) (simple-translate-and-eval form nil nil "The second argument of defconst" ctx wrld state nil)))) (value (cdr pair))))
large-conspfunction
(defun large-consp (x) (eql (the (unsigned-byte 60) (cons-count-bounded x)) (the (unsigned-byte 60) (fn-count-evg-max-val))))
defconst-fnfunction
(defun defconst-fn (name form state event-form) (with-ctx-summarized (cons 'defconst name) (let ((wrld1 (w state)) (event-form (or event-form (list 'defconst name form)))) (er-progn (chk-all-but-new-name name ctx 'const wrld1 state) (chk-legal-defconst-name name state) (let ((const-prop (getpropc name 'const nil wrld1))) (cond ((and const-prop (not (ld-redefinition-action state)) (not (large-consp event-form)) (equal event-form (get-event name wrld1))) (stop-redundant-event ctx state :name name)) (t (er-let* ((val (defconst-val name form ctx wrld1 state))) (cond ((and (consp const-prop) (equal (cadr const-prop) val)) (stop-redundant-event ctx state :name name)) (t (enforce-redundancy event-form ctx wrld1 (er-let* ((wrld2 (chk-just-new-name name nil 'const nil ctx wrld1 state)) (wrld3 (defconst-fn1 name val wrld2 state))) (install-event name event-form 'defconst name nil (list 'defconst name form val) nil nil wrld3 state)))))))))))))
defmacro-fn1function
(defun defmacro-fn1 (name args guard body w state) (let ((w (putprop name 'macro-args args (putprop name 'macro-body body (putprop-unless name 'guard guard *t* w))))) (value w)))
redundant-defmacropfunction
(defun redundant-defmacrop (name args guard body w) (and (getpropc name 'absolute-event-number nil w) (equal (getpropc name 'macro-body nil w) body) (equal (macro-args name w) args) (equal (guard name nil w) guard)))
defmacro-fnfunction
(defun defmacro-fn (mdef state event-form) (with-ctx-summarized (cons 'defmacro (car mdef)) (let ((wrld (w state)) (event-form (or event-form (cons 'defmacro mdef)))) (er-let* ((val (chk-acceptable-defmacro mdef nil ctx wrld state))) (let ((name (car val)) (args (cadr val)) (edcls (caddr val)) (body (cadddr val)) (guard (cddddr val))) (er-let* ((tguard (translate guard '(nil) nil nil ctx wrld state))) (mv-let (ctx1 tbody) (translate-cmp body '(nil) nil nil ctx wrld (default-state-vars t)) (cond (ctx1 (cond ((null tbody) (er soft ctx "An error occurred in attempting to translate ~ the body of the macro. It is very unusual ~ however to see this message; feel free to ~ contact the ACL2 implementors if you are ~ willing to help them debug how this message ~ occurred.")) ((member-eq 'state args) (er soft ctx "~@0~|~%You might find it useful to understand ~ that although you used STATE as a formal ~ parameter, it does not refer to the ACL2 ~ state. It is just a parameter bound to some ~ piece of syntax during macroexpansion. See ~ :DOC defmacro." tbody)) (t (er soft ctx "~@0" tbody)))) (t (er-progn (chk-macro-ancestors name tguard tbody ctx wrld state) (cond ((redundant-defmacrop name args tguard tbody wrld) (cond ((and (not (f-get-global 'in-local-flg state)) (not (f-get-global 'boot-strap-flg state)) (not (f-get-global 'redundant-with-raw-code-okp state)) (member-eq name (f-get-global 'macros-with-raw-code state))) (er soft ctx "~@0" (redundant-predefined-error-msg name wrld))) (t (stop-redundant-event ctx state :name name)))) (t (enforce-redundancy event-form ctx wrld (er-let* ((wrld2 (chk-just-new-name name nil 'macro nil ctx wrld state)) (ignored (value (ignore-vars edcls))) (ignorables (value (ignorable-vars edcls)))) (er-progn (chk-xargs-keywords1 edcls '(:guard) ctx state) (chk-free-and-ignored-vars name (macro-vars args) tguard *nil* *no-measure* ignored ignorables tbody ctx state) (er-let* ((wrld3 (defmacro-fn1 name args tguard tbody wrld2 state))) (install-event name event-form 'defmacro name nil (cons 'defmacro mdef) nil nil wrld3 state)))))))))))))))))
*initial-event-defmacros*constant
(defconst *initial-event-defmacros* '((defmacro in-package (str) (list 'in-package-fn (list 'quote str) 'state)) (defmacro defpkg (&whole event-form name form &optional doc book-path) (list 'defpkg-fn (list 'quote name) (list 'quote form) 'state (list 'quote doc) (list 'quote book-path) (list 'quote hidden-p) (list 'quote event-form))) (defmacro defchoose (&whole event-form &rest def) (list 'defchoose-fn (list 'quote def) 'state (list 'quote event-form))) (defmacro defun (&whole event-form &rest def) (list 'defun-fn (list 'quote def) 'state (list 'quote event-form))) (defmacro defuns (&whole event-form &rest def-lst) (list 'defuns-fn (list 'quote def-lst) 'state (list 'quote event-form))) (defmacro verify-termination-boot-strap (&whole event-form &rest lst) (list 'verify-termination-boot-strap-fn (list 'quote lst) 'state (list 'quote event-form))) (defmacro verify-guards (&whole event-form name &key (hints '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))) (defmacro defmacro (&whole event-form &rest mdef) (list 'defmacro-fn (list 'quote mdef) 'state (list 'quote event-form))) (defmacro defconst (&whole event-form name form &optional doc) (list 'defconst-fn (list 'quote name) (list 'quote form) 'state (list 'quote event-form))) (defmacro defstobj (&whole event-form name &rest args) (list 'defstobj-fn (list 'quote name) (list 'quote args) 'state (list 'quote event-form))) (defmacro defthm (&whole event-form name term &key (rule-classes '(:rewrite)) instructions hints otf-flg) (list 'defthm-fn (list 'quote name) (list 'quote term) 'state (list 'quote rule-classes) (list 'quote instructions) (list 'quote hints) (list 'quote otf-flg) (list 'quote event-form))) (defmacro defaxiom (&whole event-form name term &key (rule-classes '(:rewrite))) (list 'defaxiom-fn (list 'quote name) (list 'quote term) 'state (list 'quote rule-classes) (list 'quote event-form))) (defmacro deflabel (&whole event-form name) (list 'deflabel-fn (list 'quote name) 'state (list 'quote event-form))) (defmacro deftheory (&whole event-form name expr) (list 'deftheory-fn (list 'quote name) (list 'quote expr) 'state (list 'quote redundant-okp) (list 'quote ctx) (list 'quote event-form))) (defmacro in-theory (&whole event-form expr) (list 'in-theory-fn (list 'quote expr) 'state (list 'quote event-form))) (defmacro in-arithmetic-theory (&whole event-form expr) (list 'in-arithmetic-theory-fn (list 'quote expr) 'state (list 'quote event-form))) (defmacro regenerate-tau-database (&whole event-form) (list 'regenerate-tau-database-fn 'state (list 'quote event-form))) (defmacro push-untouchable (&whole event-form name fn-p) (list 'push-untouchable-fn (list 'quote name) (list 'quote fn-p) 'state (list 'quote event-form))) (defmacro set-body (&whole event-form fn name-or-rune) (list 'set-body-fn (list 'quote fn) (list 'quote name-or-rune) 'state (list 'quote event-form))) (defmacro table (&whole event-form name &rest args) (list 'table-fn (list 'quote name) (list 'quote args) 'state (list 'quote event-form))) (defmacro progn (&rest r) (list 'progn-fn (list 'quote r) 'state)) (defmacro encapsulate (&whole event-form signatures &rest cmd-lst) (list 'encapsulate-fn (list 'quote signatures) (list 'quote cmd-lst) 'state (list 'quote event-form))) (defmacro include-book (&whole event-form user-book-name &key (load-compiled-file ':default) (uncertified-okp 't) (defaxioms-okp 't) (skip-proofs-okp 't) (ttags 'nil) dir) (list 'include-book-fn (list 'quote user-book-name) 'state (list 'quote load-compiled-file) (list 'quote nil) (list 'quote uncertified-okp) (list 'quote defaxioms-okp) (list 'quote skip-proofs-okp) (list 'quote ttags) (list 'quote dir) (list 'quote event-form))) (defmacro local (x) (list 'if '(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)))) (defmacro defattach (&whole event-form &rest args) (list 'defattach-fn (list 'quote args) 'state (list 'quote event-form)))))
boot-translatefunction
(defun boot-translate (x) (cond ((atom x) (cond ((eq x nil) *nil*) ((eq x t) *t*) ((keywordp x) (kwote x)) ((symbolp x) x) (t (kwote x)))) ((eq (car x) 'quote) x) ((eq (car x) 'if) (list 'if (boot-translate (cadr x)) (boot-translate (caddr x)) (boot-translate (cadddr x)))) ((eq (car x) 'equal) (list 'equal (boot-translate (cadr x)) (boot-translate (caddr x)))) ((eq (car x) 'ld-skip-proofsp) (list 'ld-skip-proofsp (boot-translate (cadr x)))) ((or (eq (car x) 'list) (eq (car x) 'mv)) (cond ((null (cdr x)) *nil*) (t (list 'cons (boot-translate (cadr x)) (boot-translate (cons 'list (cddr x))))))) ((eq (car x) 'when-logic) (list 'if '(eq (default-defun-mode-from-state state) ':program) (list 'skip-when-logic (list 'quote (cadr x)) 'state) (boot-translate (caddr x)))) (t (er hard 'boot-translate "Boot-translate was called on ~x0, which is ~ unrecognized. If you want to use such a form in one ~ of the *initial-event-defmacros* then you must modify ~ boot-translate so that it can translate the form." x))))
primordial-event-macro-and-fn1function
(defun primordial-event-macro-and-fn1 (actuals) (cond ((null actuals) nil) ((equal (car actuals) ''state) (cons 'state (primordial-event-macro-and-fn1 (cdr actuals)))) ((and (consp (car actuals)) (eq (car (car actuals)) 'list) (equal (cadr (car actuals)) ''quote)) (cons (caddr (car actuals)) (primordial-event-macro-and-fn1 (cdr actuals)))) (t (er hard 'primordial-event-macro-and-fn1 "We encountered an unrecognized form of actual, ~x0, ~ in trying to extract the formals from the actuals in ~ some member of *initial-event-defmacros*. If you ~ want to use such a form in one of the initial event ~ defmacros, you must modify ~ primordial-event-macro-and-fn1 so that it can recover ~ the corresponding formal name from the actual form." (car actuals)))))
primordial-event-macro-and-fnfunction
(defun primordial-event-macro-and-fn (form wrld) (case-match form (('defmacro 'local macro-args macro-body) (putprop 'local 'macro-args macro-args (putprop 'local 'macro-body (boot-translate macro-body) (putprop 'ld-skip-proofsp 'symbol-class :common-lisp-compliant (putprop 'ld-skip-proofsp 'formals '(state) (putprop 'ld-skip-proofsp 'stobjs-in '(state) (putprop 'ld-skip-proofsp 'stobjs-out '(nil) (putprop 'ld-skip-proofsp 'def-bodies (list (make def-body :formals '(state) :hyp nil :concl '(ld-skip-proofsp state) :equiv 'equal :rune *fake-rune-for-anonymous-enabled-rule* :nume 0 :recursivep nil :controller-alist nil)) (putprop 'default-defun-mode-from-state 'symbol-class :common-lisp-compliant (putprop 'default-defun-mode-from-state 'formals '(state) (putprop 'default-defun-mode-from-state 'stobjs-in '(state) (putprop 'default-defun-mode-from-state 'stobjs-out '(nil) (putprop 'default-defun-mode-from-state 'def-bodies (list (make def-body :formals '(str state) :hyp nil :concl '(default-defun-mode-from-state state) :equiv 'equal :rune *fake-rune-for-anonymous-enabled-rule* :nume 0 :recursivep nil :controller-alist nil)) (putprop 'skip-when-logic 'symbol-class :common-lisp-compliant (putprop 'skip-when-logic 'formals '(str state) (putprop 'skip-when-logic 'stobjs-in '(nil state) (putprop 'skip-when-logic 'stobjs-out *error-triple-sig* (putprop 'skip-when-logic 'def-bodies (list (make def-body :formals '(str state) :hyp nil :concl '(skip-when-logic str state) :equiv 'equal :rune *fake-rune-for-anonymous-enabled-rule* :nume 0 :recursivep nil :controller-alist nil)) wrld)))))))))))))))))) (('defmacro name macro-args ('list ('quote name-fn) . actuals)) (let* ((formals (primordial-event-macro-and-fn1 actuals)) (stobjs-in (compute-stobj-flags formals t nil wrld)) (macro-body (boot-translate (list* 'list (kwote name-fn) actuals)))) (putprop name 'macro-args macro-args (putprop name 'macro-body macro-body (putprop name-fn 'symbol-class :program (putprop name-fn 'formals formals (putprop name-fn 'stobjs-in stobjs-in (putprop name-fn 'stobjs-out *error-triple-sig* wrld)))))))) (& (er hard 'primordial-event-macro-and-fn "The supplied form ~x0 was not of the required shape. ~ Every element of *initial-event-defmacros* must be of ~ the form expected by this function. Either change the ~ event defmacro or modify this function." form))))
primordial-event-macros-and-fnsfunction
(defun primordial-event-macros-and-fns (lst wrld) (cond ((null lst) wrld) (t (primordial-event-macros-and-fns (cdr lst) (primordial-event-macro-and-fn (car lst) wrld)))))
*initial-type-prescriptions*constant
(defconst *initial-type-prescriptions* (list (list 'o-p (make type-prescription :rune *fake-rune-for-anonymous-enabled-rule* :nume nil :term '(o-p x) :hyps nil :backchain-limit-lst nil :basic-ts *ts-boolean* :vars nil :corollary '(booleanp (o-p x)))) (list 'o< (make type-prescription :rune *fake-rune-for-anonymous-enabled-rule* :nume nil :term '(o< x y) :hyps nil :backchain-limit-lst nil :basic-ts *ts-boolean* :vars nil :corollary '(booleanp (o< x y))))))
collect-world-globalsfunction
(defun collect-world-globals (wrld ans) (cond ((null wrld) ans) ((eq (cadar wrld) 'global-value) (collect-world-globals (cdr wrld) (add-to-set-eq (caar wrld) ans))) (t (collect-world-globals (cdr wrld) ans))))
primordial-world-globalsfunction
(defun primordial-world-globals (operating-system project-dir-alist) (let ((wrld (global-set-lst (list* (list 'event-landmark (make-event-tuple -1 0 nil nil 0 nil nil nil)) (list 'command-landmark (make-command-tuple -1 :logic nil nil nil)) (list 'known-package-alist *initial-known-package-alist*) (list 'well-founded-relation-alist (list (cons 'o< (cons 'o-p *fake-rune-for-anonymous-enabled-rule*)) (cons 'l< (cons 'lexp *fake-rune-for-anonymous-enabled-rule*)))) (list 'built-in-clauses (classify-and-store-built-in-clause-rules *initial-built-in-clauses* nil nil)) (list 'half-length-built-in-clauses (floor (length *initial-built-in-clauses*) 2)) (list 'type-set-inverter-rules *initial-type-set-inverter-rules*) (list 'global-arithmetic-enabled-structure (initial-global-enabled-structure "ARITHMETIC-ENABLED-ARRAY-")) (let ((globals `((event-index nil) (command-index nil) (event-number-baseline 0) (embedded-event-lst nil) (cltl-command nil) (top-level-cltl-command-stack nil) (include-book-alist nil) (include-book-alist-all nil) (pcert-books nil) (include-book-path nil) (certification-tuple nil) (proved-functional-instances-alist nil) (nonconstructive-axiom-names nil) (standard-theories (nil nil nil nil)) (current-theory nil) (current-theory-length 0) (current-theory-augmented nil) (current-theory-index -1) (generalize-rules nil) (tau-runes nil) (tau-next-index 0) (tau-conjunctive-rules nil) (tau-mv-nth-synonyms nil) (tau-lost-runes nil) (clause-processor-rules nil) (boot-strap-flg t) (boot-strap-pass-2 nil) (skip-proofs-seen nil) (redef-seen nil) (cert-replay nil) (free-var-runes-all nil) (free-var-runes-once nil) (translate-cert-data nil) (chk-new-name-lst (if iff implies not in-package defpkg defun defuns mutual-recursion defmacro defconst defstobj defthm defaxiom progn encapsulate include-book deflabel deftheory in-theory in-arithmetic-theory regenerate-tau-database push-untouchable remove-untouchable set-body table reset-prehistory verify-guards verify-termination-boot-strap local defchoose ld-skip-proofsp in-package-fn defpkg-fn defun-fn defuns-fn mutual-recursion-fn defmacro-fn defconst-fn defstobj-fn defthm-fn defaxiom-fn progn-fn encapsulate-fn include-book-fn deflabel-fn deftheory-fn in-theory-fn in-arithmetic-theory-fn regenerate-tau-database-fn push-untouchable-fn remove-untouchable-fn reset-prehistory-fn set-body-fn table-fn verify-guards-fn verify-termination-boot-strap-fn defchoose-fn apply o-p o< defattach defattach-fn default-defun-mode-from-state skip-when-logic state declare apropos finding-documentation enter-boot-strap-mode exit-boot-strap-mode lp acl2-defaults-table let let* complex complex-rationalp ,@(STRIP-CARS *INITIAL-RECOGNIZER-ALIST*))) (ttags-seen nil) (never-untouchable-fns nil) (untouchable-fns nil) (untouchable-vars nil) (defined-hereditarily-constrained-fns nil) (attach-nil-lst nil) (attachment-records nil) (attachments-at-ground-zero nil) (proof-supporters-alist nil) (lambda$-alist nil) (loop$-alist nil) (common-lisp-compliant-lambdas nil) (rewrite-quoted-constant-rules nil) (project-dir-alist ,PROJECT-DIR-ALIST) (projects/apply/base-includedp nil) (ext-gens nil) (ext-gen-barriers nil)))) (list* `(operating-system ,OPERATING-SYSTEM) `(command-number-baseline-info ,(MAKE COMMAND-NUMBER-BASELINE-INFO :CURRENT 0 :PERMANENT-P T :ORIGINAL 0)) globals))) nil))) (global-set 'world-globals (collect-world-globals wrld '(world-globals)) wrld)))
arglists-to-nilsfunction
(defun arglists-to-nils (arglists) (declare (xargs :guard (true-list-listp arglists))) (cond ((endp arglists) nil) (t (cons (make-list (length (car arglists))) (arglists-to-nils (cdr arglists))))))
*unattachable-primitives*constant
(defconst *unattachable-primitives* '(big-n decrement-big-n zp-big-n badge-userfn apply$-userfn))
putprop-recognizer-alistfunction
(defun putprop-recognizer-alist (alist wrld) (cond ((endp alist) wrld) (t (putprop-recognizer-alist (cdr alist) (let* ((recog-tuple (car alist)) (fn (access recognizer-tuple recog-tuple :fn))) (putprop fn 'recognizer-alist (cons recog-tuple (getpropc fn 'recognizer-alist nil wrld)) wrld))))))
primordial-worldfunction
(defun primordial-world (operating-system project-dir-alist) (let ((names (strip-cars *primitive-formals-and-guards*)) (arglists (strip-cadrs *primitive-formals-and-guards*)) (guards (strip-caddrs *primitive-formals-and-guards*)) (ns-names nil)) (add-command-landmark :logic (list 'enter-boot-strap-mode operating-system) nil nil (add-event-landmark (list 'enter-boot-strap-mode operating-system) 'enter-boot-strap-mode (append (strip-cars *primitive-formals-and-guards*) (strip-non-hidden-package-names *initial-known-package-alist*)) (initialize-tau-preds *primitive-monadic-booleans* (putprop 'equal 'coarsenings '(equal) (putprop-x-lst1 names 'absolute-event-number 0 (putprop-x-lst1 names 'predefined t (putprop-defun-runic-mapping-pairs names nil (putprop-x-lst1 ns-names 'classicalp nil (putprop-x-lst1 ns-names 'constrainedp t (putprop-x-lst1 names 'symbol-class :common-lisp-compliant (putprop-x-lst2-unless names 'guard guards *t* (putprop-x-lst2 names 'formals arglists (putprop-x-lst2 (strip-cars *initial-type-prescriptions*) 'type-prescriptions (strip-cdrs *initial-type-prescriptions*) (putprop-x-lst1 names 'coarsenings nil (putprop-x-lst1 names 'congruences nil (putprop-x-lst1 names 'pequivs nil (putprop-x-lst2 names 'stobjs-in (arglists-to-nils arglists) (putprop-x-lst1 names 'stobjs-out '(nil) (primordial-event-macros-and-fns *initial-event-defmacros* (putprop 'state 'stobj '(*the-live-state*) (putprop-recognizer-alist *initial-recognizer-alist* (primordial-world-globals operating-system project-dir-alist)))))))))))))))))))) t nil nil))))
same-name-twicefunction
(defun same-name-twice (l) (cond ((null l) nil) ((null (cdr l)) nil) ((equal (symbol-name (car l)) (symbol-name (cadr l))) (list (car l) (cadr l))) (t (same-name-twice (cdr l)))))
conflicting-importsfunction
(defun conflicting-imports (l) (same-name-twice l))
chk-new-stringp-namefunction
(defun chk-new-stringp-name (ev-type name ctx w state) (cond ((not (if (eq ev-type 'defpkg) (stringp name) (book-name-p name))) (er soft ctx "The first argument to ~s0 must be a ~s1. You provided the object ~ ~x2. See :DOC ~s0." (cond ((eq ev-type 'defpkg) "defpkg") (t "include-book")) (cond ((eq ev-type 'defpkg) "string") (t "book-name")) name)) (t (let ((entry (and (stringp name) (find-package-entry name (global-val 'known-package-alist w))))) (cond ((and entry (not (and (eq ev-type 'defpkg) (package-entry-hidden-p entry)))) (er soft ctx "The name ~x0 is in use as a package name. We do not permit ~ package names~s1 to participate in redefinition. If you must ~ redefine this name, use :ubt to undo the existing definition." name (if (package-entry-hidden-p entry) " (even those that are hidden; see :DOC hidden-death-package" ""))) ((assoc-equal name (global-val 'include-book-alist w)) (cond ((eq ev-type 'include-book) (value name)) (t (er soft ctx "The name ~x0 is in use as a book-name. You are trying to ~ redefine it as a package. We do not permit package names to ~ participate in redefinition. If you must redefine this ~ name, use :ubt to undo the existing definition." name)))) (t (value nil)))))))
chk-package-reincarnation-import-restrictionsfunction
(defun chk-package-reincarnation-import-restrictions (name proposed-imports) (declare (ignore name proposed-imports)) t)
convert-book-string-to-certfunction
(defun convert-book-string-to-cert (x cert-op) (concatenate 'string (remove-lisp-suffix x nil) (case cert-op ((t) "cert") ((:create-pcert :create+convert-pcert) "pcert0") (:convert-pcert "pcert1") (otherwise (er hard 'convert-book-string-to-cert "Bad value of cert-op for convert-book-string-to-cert: ~ ~x0" cert-op)))))
tilde-@-defpkg-error-phrasefunction
(defun tilde-@-defpkg-error-phrase (name package-entry new-not-old old-not-new book-path defpkg-book-path w) (let* ((project-dir-alist (project-dir-alist w)) (ctx 'tilde-@-defpkg-error-phrase) (book-path-strings (book-name-lst-to-filename-lst book-path project-dir-alist ctx)) (defpkg-book-path-strings (book-name-lst-to-filename-lst defpkg-book-path project-dir-alist ctx))) (list "The proposed defpkg conflicts with an existing defpkg for ~ name ~x0~@1. ~#a~[For example, symbol ~s2::~s3 is in the list of ~ imported symbols for the ~s4 definition but not for the other.~/The two ~ have the same lists of imported symbols, but not in the same order.~] ~ The existing defpkg is ~#5~[at the top level.~/in the certificate file ~ for the book ~x7, which is included at the top level.~/in the ~ certificate file for the book ~x7, which is included via the following ~ path, from top-most book down to the above file.~| ~F8~]~@9~@b" (cons #\0 name) (cons #\1 (if (package-entry-hidden-p package-entry) " that no longer exists in the current ACL2 logical world ~ (see :DOC hidden-death-package)" "")) (cons #\a (if (or new-not-old old-not-new) 0 1)) (cons #\2 (symbol-package-name (if new-not-old (car new-not-old) (car old-not-new)))) (cons #\3 (symbol-name (if new-not-old (car new-not-old) (car old-not-new)))) (cons #\4 (if new-not-old "proposed" "existing")) (cons #\5 (zero-one-or-more book-path-strings)) (cons #\7 (car book-path-strings)) (cons #\8 (reverse book-path-strings)) (cons #\9 (if defpkg-book-path-strings "~|This existing defpkg event appears to have been created ~ because of a defpkg that was hidden by a local include-book; ~ see :DOC hidden-death-package." "")) (cons #\b (let ((include-book-path-strings (book-name-lst-to-filename-lst (global-val 'include-book-path w) project-dir-alist ctx))) (if (or include-book-path-strings defpkg-book-path-strings) (msg "~|The proposed defpkg event may be found by ~ following the sequence of include-books below, ~ from top-most book down to the book whose ~ portcullis contains the proposed defpkg event.~| ~ ~F0" (reverse (append defpkg-book-path-strings include-book-path-strings))) ""))))))
*1*-pkg-prefix*constant
(defconst *1*-pkg-prefix* (let ((result "ACL2_*1*_")) result))
chk-acceptable-defpkgfunction
(defun chk-acceptable-defpkg (name form defpkg-book-path hidden-p ctx w state) (let ((package-entry (and (not (f-get-global 'boot-strap-flg state)) (find-package-entry name (global-val 'known-package-alist w))))) (cond ((not (true-listp defpkg-book-path)) (er soft ctx "The book-path argument to defpkg, if supplied, must be a ~ true-listp. It is not recommended to supply this argument, since ~ the system makes use of it for producing useful error messages. ~ The defpkg of ~x0 is thus illegal." name)) ((get-invalid-book-name defpkg-book-path (os w) w) (er soft ctx "A defpkg form for ~x0 specifies an invalid book-path entry, ~x1.~@2" name (get-invalid-book-name defpkg-book-path (os w) w) (let ((x (get-invalid-book-name defpkg-book-path (os w) w))) (if (and (sysfile-p x) (not (project-dir-lookup (sysfile-key x) (project-dir-alist w) nil))) (msg " Note that the keyword ~x0 is not currently bound in ~ the project-dir-alist. Probably it was bound in the ~ project-dir-alist in a previous session, when this ~ defpkg form was written to a book's certificate. See ~ :DOC project-dir-alist." (sysfile-key x)) "")))) ((and package-entry (or hidden-p (not (package-entry-hidden-p package-entry))) (equal (caddr (package-entry-defpkg-event-form package-entry)) form)) (value 'redundant)) (t (er-progn (cond ((or package-entry (eq (ld-skip-proofsp state) 'include-book)) (value nil)) ((not (stringp name)) (er soft ctx "Package names must be string constants and ~x0 is not. See ~ :DOC defpkg." name)) ((equal name "") (er soft ctx "The empty string is not a legal package name for defpkg." name)) ((not (equal (string-upcase name) name)) (er soft ctx "~x0 is not a legal package name for defpkg, which disallows ~ lower case characters in the name." name)) ((equal name "LISP") (er soft ctx "~x0 is disallowed as a a package name for defpkg, because this ~ package name is used under the hood in some Common Lisp ~ implementations." name)) ((let ((len (length *1*-pkg-prefix*))) (and (<= len (length name)) (string-equal (subseq name 0 len) *1*-pkg-prefix*))) (er soft ctx "It is illegal for a package name to start (even ignoring case) ~ with the string "~@0". ACL2 makes internal use of package ~ names starting with that string." *1*-pkg-prefix*)) (t (value nil))) (state-global-let* ((safe-mode (not (f-get-global 'boot-strap-flg state)))) (er-let* ((pair (simple-translate-and-eval form nil nil "The second argument to defpkg" ctx w state nil))) (let ((tform (car pair)) (imports (cdr pair))) (cond ((not (symbol-listp imports)) (er soft ctx "The second argument of defpkg must eval to a list of ~ symbols. See :DOC defpkg.")) (t (let* ((imports (sort-symbol-listp imports)) (conflict (conflicting-imports imports)) (base-symbol (packn (cons name '("-PACKAGE"))))) (cond ((member-symbol-name *pkg-witness-name* imports) (er soft ctx "It is illegal to import symbol ~x0 because its name ~ has been reserved for a symbol in the package being ~ defined." (car (member-symbol-name *pkg-witness-name* imports)))) (conflict (er soft ctx "The value of the second (imports) argument of defpkg ~ may not contain two symbols with the same symbol ~ name, e.g. ~&0. See :DOC defpkg." conflict)) (t (cond ((and package-entry (not (equal imports (package-entry-imports package-entry)))) (er soft ctx "~@0" (tilde-@-defpkg-error-phrase name package-entry (set-difference-eq imports (package-entry-imports package-entry)) (set-difference-eq (package-entry-imports package-entry) imports) (package-entry-book-path package-entry) defpkg-book-path w))) ((and package-entry (or hidden-p (not (package-entry-hidden-p package-entry)))) (prog2$ (chk-package-reincarnation-import-restrictions name imports) (value 'redundant))) (t (er-progn (chk-new-stringp-name 'defpkg name ctx w state) (chk-all-but-new-name base-symbol ctx nil w state) (chk-just-new-name base-symbol nil 'theorem nil ctx w state) (prog2$ (chk-package-reincarnation-import-restrictions name imports) (value (list* tform imports package-entry)))))))))))))))))))
defpkg-fnfunction
(defun defpkg-fn (name form state doc book-path hidden-p event-form) (with-ctx-summarized (cons 'defpkg name) (let ((w (w state)) (event-form (or event-form (list* 'defpkg name form (if (or doc book-path) (list doc) nil) (if book-path (list book-path) nil))))) (er-let* ((tform-imports-entry (chk-acceptable-defpkg name form book-path hidden-p ctx w state))) (cond ((eq tform-imports-entry 'redundant) (stop-redundant-event ctx state)) (t (let* ((imports (cadr tform-imports-entry)) (w1 (global-set 'known-package-alist (cons (make-package-entry :name name :imports imports :hidden-p hidden-p :book-path (append book-path (global-val 'include-book-path w)) :defpkg-event-form event-form :tterm (car tform-imports-entry)) (if (cddr tform-imports-entry) (remove-package-entry name (known-package-alist state)) (global-val 'known-package-alist w))) w)) (w2 (cond (hidden-p w1) (t (let ((ax `(equal (pkg-imports ',NAME) ',IMPORTS))) (add-rules (packn (cons name '("-PACKAGE"))) `((:rewrite :corollary ,AX)) ax ax (ens state) w1 state)))))) (install-event name event-form 'defpkg name nil (list 'defpkg name form) :protect ctx w2 state))))))))
theory-fn-callpfunction
(defun theory-fn-callp (x) (and (consp x) (member-eq (car x) '(current-theory disable e/d enable executable-counterpart-theory function-theory intersection-theories set-difference-theories theory union-theories universal-theory)) t))
intersection-augmented-theories-fn1function
(defun intersection-augmented-theories-fn1 (lst1 lst2 ans) (cond ((null lst1) (revappend ans nil)) ((null lst2) (revappend ans nil)) ((= (car (car lst1)) (car (car lst2))) (intersection-augmented-theories-fn1 (cdr lst1) (cdr lst2) (cons (cdr (car lst1)) ans))) ((> (car (car lst1)) (car (car lst2))) (intersection-augmented-theories-fn1 (cdr lst1) lst2 ans)) (t (intersection-augmented-theories-fn1 lst1 (cdr lst2) ans))))
check-theory-msg1function
(defun check-theory-msg1 (lst macro-aliases wrld bad macros theorems) (cond ((endp lst) (mv (reverse bad) (reverse macros) (reverse theorems))) (t (let ((sym (rule-name-designatorp (car lst) macro-aliases wrld))) (cond (sym (check-theory-msg1 (cdr lst) macro-aliases wrld bad macros theorems)) ((not (symbolp (car lst))) (check-theory-msg1 (cdr lst) macro-aliases wrld (cons (car lst) bad) macros theorems)) (t (let ((name (car lst))) (mv-let (macros theorems) (cond ((and (not (eq (getpropc name 'macro-args t wrld) t)) (eq (deref-macro-name name macro-aliases) name)) (mv (cons name macros) theorems)) ((or (body name nil wrld) (getpropc name 'theorem nil wrld) (getpropc name 'defchoose-axiom nil wrld)) (mv macros (cons name theorems))) (t (mv macros theorems))) (check-theory-msg1 (cdr lst) macro-aliases wrld (cons name bad) macros theorems)))))))))
check-theory-msgfunction
(defun check-theory-msg (lst wrld) (cond ((true-listp lst) (mv-let (bad macros theorems) (check-theory-msg1 lst (macro-aliases wrld) wrld nil nil nil) (cond (bad (msg "A theory function has been called on a list that contains ~ ~&0, which ~#0~[does~/do~] not designate a rule or a ~ non-empty list of rules. ~@1See :DOC theories." bad (cond ((or macros theorems) (msg "Note that ~@0~@1~@2. " (cond (macros (msg "~&0 ~#0~[is a macro~/are macros~]; see ~ :DOC add-macro-alias to associate a ~ macro with a function" macros)) (t "")) (cond ((and macros theorems) ". Also note that ") (t "")) (cond (theorems (msg "~&0 ~#0~[names a theorem~/name ~ theorems~] but not any rules" theorems)) (t "")))) (t "")))) (t nil)))) (t (msg "A theory function has been called on the following argument that does ~ not represent a theory because it is not a true-list:~|~Y01.~|" lst (evisc-tuple 5 7 nil nil)))))
check-theory-actionfunction
(defun check-theory-action (lst wrld ctx) (let ((msg (check-theory-msg lst wrld))) (cond (msg (prog2$ (er hard ctx "~@0" msg) t)) (t nil))))
check-theorymacro
(defmacro check-theory (lst wrld ctx form) `(if (check-theory-action ,LST ,WRLD ,CTX) nil ,FORM))
maybe-check-theorymacro
(defmacro maybe-check-theory (skip-check lst wrld ctx form) `(if ,SKIP-CHECK ,FORM (check-theory ,LST ,WRLD ,CTX ,FORM)))
intersection-theories-fnfunction
(defun intersection-theories-fn (lst1 lst2 lst1-known-to-be-runic lst2-known-to-be-runic wrld) (maybe-check-theory lst1-known-to-be-runic lst1 wrld 'intersection-theories-fn (maybe-check-theory lst2-known-to-be-runic lst2 wrld 'intersection-theories-fn (intersection-augmented-theories-fn1 (augment-theory lst1 wrld) (augment-theory lst2 wrld) nil))))
intersection-theoriesmacro
(defmacro intersection-theories (lst1 lst2) (list 'intersection-theories-fn lst1 lst2 (theory-fn-callp lst1) (theory-fn-callp lst2) 'world))
union-augmented-theories-fn1function
(defun union-augmented-theories-fn1 (lst1 lst2 ans) (cond ((null lst1) (revappend ans (strip-cdrs lst2))) ((null lst2) (revappend ans (strip-cdrs lst1))) ((int= (car (car lst1)) (car (car lst2))) (union-augmented-theories-fn1 (cdr lst1) (cdr lst2) (cons (cdr (car lst1)) ans))) ((> (car (car lst1)) (car (car lst2))) (union-augmented-theories-fn1 (cdr lst1) lst2 (cons (cdr (car lst1)) ans))) (t (union-augmented-theories-fn1 lst1 (cdr lst2) (cons (cdr (car lst2)) ans)))))
union-theories-fn1function
(defun union-theories-fn1 (lst1 lst2 nume wrld ans) (cond ((null lst1) (revappend ans (strip-cdrs lst2))) ((null lst2) (revappend ans lst1)) (t (let ((nume (or nume (runep (car lst1) wrld)))) (assert$ nume (cond ((int= nume (car (car lst2))) (union-theories-fn1 (cdr lst1) (cdr lst2) nil wrld (cons (car lst1) ans))) ((> nume (car (car lst2))) (union-theories-fn1 (cdr lst1) lst2 nil wrld (cons (car lst1) ans))) (t (union-theories-fn1 lst1 (cdr lst2) nume wrld (cons (cdar lst2) ans)))))))))
union-theories-fnfunction
(defun union-theories-fn (lst1 lst2 lst1-known-to-be-runic wrld) (cond ((or lst1-known-to-be-runic (runic-theoryp lst1 wrld)) (maybe-check-theory (eq lst1-known-to-be-runic 'both) lst2 wrld 'union-theories-fn (union-theories-fn1 lst1 (augment-theory lst2 wrld) nil wrld nil))) ((runic-theoryp lst2 wrld) (check-theory lst1 wrld 'union-theories-fn (union-theories-fn1 lst2 (augment-theory lst1 wrld) nil wrld nil))) (t (check-theory lst1 wrld 'union-theories-fn (check-theory lst2 wrld 'union-theories-fn (union-augmented-theories-fn1 (duplicitous-sort-car nil (convert-theory-to-unordered-mapping-pairs lst1 wrld)) (augment-theory lst2 wrld) nil))))))
union-augmented-theories-fn1+function
(defun union-augmented-theories-fn1+ (lst1 c1 lst2 ans) (cond ((null lst1) (revappend ans (strip-cdrs lst2))) ((null lst2) (revappend ans c1)) ((int= (car (car lst1)) (car (car lst2))) (union-augmented-theories-fn1+ (cdr lst1) (cdr c1) (cdr lst2) (cons (car c1) ans))) ((> (car (car lst1)) (car (car lst2))) (union-augmented-theories-fn1+ (cdr lst1) (cdr c1) lst2 (cons (car c1) ans))) (t (union-augmented-theories-fn1+ lst1 c1 (cdr lst2) (cons (cdr (car lst2)) ans)))))
set-difference-augmented-theories-fn1function
(defun set-difference-augmented-theories-fn1 (lst1 lst2 ans) (cond ((null lst1) (revappend ans nil)) ((null lst2) (revappend ans (strip-cdrs lst1))) ((= (car (car lst1)) (car (car lst2))) (set-difference-augmented-theories-fn1 (cdr lst1) (cdr lst2) ans)) ((> (car (car lst1)) (car (car lst2))) (set-difference-augmented-theories-fn1 (cdr lst1) lst2 (cons (cdr (car lst1)) ans))) (t (set-difference-augmented-theories-fn1 lst1 (cdr lst2) ans))))
set-difference-augmented-theories-fn1+function
(defun set-difference-augmented-theories-fn1+ (lst1 c1 lst2 ans) (cond ((null lst1) (revappend ans nil)) ((null lst2) (revappend ans c1)) ((= (car (car lst1)) (car (car lst2))) (set-difference-augmented-theories-fn1+ (cdr lst1) (cdr c1) (cdr lst2) ans)) ((> (car (car lst1)) (car (car lst2))) (set-difference-augmented-theories-fn1+ (cdr lst1) (cdr c1) lst2 (cons (car c1) ans))) (t (set-difference-augmented-theories-fn1+ lst1 c1 (cdr lst2) ans))))
set-difference-theories-fn1function
(defun set-difference-theories-fn1 (lst1 lst2 nume wrld ans) (cond ((null lst1) (reverse ans)) ((null lst2) (revappend ans lst1)) (t (let ((nume (or nume (runep (car lst1) wrld)))) (assert$ nume (cond ((int= nume (car (car lst2))) (set-difference-theories-fn1 (cdr lst1) (cdr lst2) nil wrld ans)) ((> nume (car (car lst2))) (set-difference-theories-fn1 (cdr lst1) lst2 nil wrld (cons (car lst1) ans))) (t (set-difference-theories-fn1 lst1 (cdr lst2) nume wrld ans))))))))
set-difference-theories-fnfunction
(defun set-difference-theories-fn (lst1 lst2 lst1-known-to-be-runic lst2-known-to-be-runic wrld) (cond ((or lst1-known-to-be-runic (runic-theoryp lst1 wrld)) (maybe-check-theory lst2-known-to-be-runic lst2 wrld 'set-difference-theories-fn (set-difference-theories-fn1 lst1 (augment-theory lst2 wrld) nil wrld nil))) (t (check-theory lst1 wrld 'set-difference-theories-fn (maybe-check-theory lst2-known-to-be-runic lst2 wrld 'set-difference-theories-fn (set-difference-augmented-theories-fn1 (duplicitous-sort-car nil (convert-theory-to-unordered-mapping-pairs lst1 wrld)) (augment-theory lst2 wrld) nil))))))
no-augmented-rune-based-onfunction
(defun no-augmented-rune-based-on (pairs symbols) (cond ((null pairs) t) ((member-eq (base-symbol (cdar pairs)) symbols) nil) (t (no-augmented-rune-based-on (cdr pairs) symbols))))
revappend-delete-augmented-runes-based-on-symbols1function
(defun revappend-delete-augmented-runes-based-on-symbols1 (pairs symbols ans) (cond ((null pairs) ans) ((member-eq (base-symbol (cdr (car pairs))) symbols) (revappend-delete-augmented-runes-based-on-symbols1 (cdr pairs) symbols ans)) (t (revappend-delete-augmented-runes-based-on-symbols1 (cdr pairs) symbols (cons (car pairs) ans)))))
revappend-delete-augmented-runes-based-on-symbolsfunction
(defun revappend-delete-augmented-runes-based-on-symbols (pairs symbols ans) (cond ((or (null symbols) (no-augmented-rune-based-on pairs symbols)) (revappend ans pairs)) (t (reverse (revappend-delete-augmented-runes-based-on-symbols1 pairs symbols ans)))))
current-theory-fn1function
(defun current-theory-fn1 (wrld1 wrld) (let* ((redefined (collect-redefined wrld nil)) (wrld2 (putprop-x-lst1 redefined 'runic-mapping-pairs *acl2-property-unbound* wrld1))) (assert$-runic-theoryp (current-theory1 wrld2 nil nil) wrld)))
current-theory-fnfunction
(defun current-theory-fn (logical-name wrld) (let ((wrld1 (decode-logical-name logical-name wrld))) (prog2$ (or wrld1 (er hard 'current-theory "The name ~x0 was not found in the current ACL2 logical ~ world; hence no current-theory can be computed for that name." logical-name)) (current-theory-fn1 wrld1 wrld))))
current-theory1-augmentedfunction
(defun current-theory1-augmented (lst ans redefined) (cond ((null lst) (reverse ans)) ((eq (cadr (car lst)) 'runic-mapping-pairs) (cond ((eq (cddr (car lst)) *acl2-property-unbound*) (current-theory1-augmented (cdr lst) ans (add-to-set-eq (car (car lst)) redefined))) ((member-eq (car (car lst)) redefined) (current-theory1-augmented (cdr lst) ans redefined)) (t (current-theory1-augmented (cdr lst) (append (cddr (car lst)) ans) redefined)))) ((and (eq (car (car lst)) 'current-theory-augmented) (eq (cadr (car lst)) 'global-value)) (revappend-delete-augmented-runes-based-on-symbols (cddr (car lst)) redefined ans)) (t (current-theory1-augmented (cdr lst) ans redefined))))
union-current-theory-fnfunction
(defun union-current-theory-fn (lst2 lst2-known-to-be-runic wrld) (maybe-check-theory lst2-known-to-be-runic lst2 wrld 'union-current-theory-fn (let* ((wrld1 (scan-to-event wrld)) (redefined (collect-redefined wrld nil)) (wrld2 (putprop-x-lst1 redefined 'runic-mapping-pairs *acl2-property-unbound* wrld1))) (union-augmented-theories-fn1+ (current-theory1-augmented wrld2 nil nil) (current-theory1 wrld2 nil nil) (augment-theory lst2 wrld) nil))))
union-theoriesmacro
(defmacro union-theories (lst1 lst2) (cond ((equal lst1 '(current-theory :here)) (list 'union-current-theory-fn lst2 (theory-fn-callp lst2) 'world)) ((equal lst2 '(current-theory :here)) (list 'union-current-theory-fn lst1 (theory-fn-callp lst1) 'world)) ((theory-fn-callp lst1) (list 'union-theories-fn lst1 lst2 (if (theory-fn-callp lst2) ''both t) 'world)) ((theory-fn-callp lst2) (list 'union-theories-fn lst2 lst1 t 'world)) (t (list 'union-theories-fn lst1 lst2 nil 'world))))
set-difference-current-theory-fnfunction
(defun set-difference-current-theory-fn (lst2 lst2-known-to-be-runic wrld) (maybe-check-theory lst2-known-to-be-runic lst2 wrld 'set-difference-current-theory-fn (let* ((wrld1 (scan-to-event wrld)) (redefined (collect-redefined wrld nil)) (wrld2 (putprop-x-lst1 redefined 'runic-mapping-pairs *acl2-property-unbound* wrld1))) (set-difference-augmented-theories-fn1+ (current-theory1-augmented wrld2 nil nil) (current-theory1 wrld2 nil nil) (augment-theory lst2 wrld) nil))))
set-difference-theoriesmacro
(defmacro set-difference-theories (lst1 lst2) (cond ((equal lst1 '(current-theory :here)) (list 'set-difference-current-theory-fn lst2 (theory-fn-callp lst2) 'world)) (t (list 'set-difference-theories-fn lst1 lst2 (theory-fn-callp lst1) (theory-fn-callp lst2) 'world))))
universal-theory-fn1function
(defun universal-theory-fn1 (lst ans redefined) (cond ((null lst) (reverse ans)) ((eq (cadr (car lst)) 'runic-mapping-pairs) (cond ((eq (cddr (car lst)) *acl2-property-unbound*) (universal-theory-fn1 (cdr lst) ans (add-to-set-eq (car (car lst)) redefined))) ((member-eq (car (car lst)) redefined) (universal-theory-fn1 (cdr lst) ans redefined)) (t (universal-theory-fn1 (cdr lst) (append-strip-cdrs (cddr (car lst)) ans) redefined)))) ((and (eq (car (car lst)) 'standard-theories) (eq (cadr (car lst)) 'global-value)) (revappend-delete-runes-based-on-symbols (car (cddr (car lst))) redefined ans)) (t (universal-theory-fn1 (cdr lst) ans redefined))))
universal-theory-fnfunction
(defun universal-theory-fn (logical-name wrld) (declare (xargs :guard (logical-namep logical-name wrld))) (let* ((wrld1 (decode-logical-name logical-name wrld)) (redefined (collect-redefined wrld nil)) (wrld2 (putprop-x-lst1 redefined 'runic-mapping-pairs *acl2-property-unbound* wrld1))) (assert$-runic-theoryp (universal-theory-fn1 wrld2 nil nil) wrld)))
universal-theorymacro
(defmacro universal-theory (logical-name) (list 'universal-theory-fn logical-name 'world))
function-theory-fn1function
(defun function-theory-fn1 (token lst ans redefined) (cond ((null lst) (reverse ans)) ((eq (cadr (car lst)) 'runic-mapping-pairs) (cond ((eq (cddr (car lst)) *acl2-property-unbound*) (function-theory-fn1 token (cdr lst) ans (add-to-set-eq (car (car lst)) redefined))) ((member-eq (car (car lst)) redefined) (function-theory-fn1 token (cdr lst) ans redefined)) ((eq (car (cdr (car (cddr (car lst))))) :definition) (function-theory-fn1 token (cdr lst) (cond ((eq token :definition) (cons (cdr (car (cddr (car lst)))) ans)) (t (let ((rune-exec (cdr (cadr (cddr (car lst)))))) (case token (:executable-counterpart (if (null rune-exec) ans (cons rune-exec ans))) (otherwise (cons (cdr (car (cddr (car lst)))) (if (null rune-exec) ans (cons rune-exec ans)))))))) redefined)) (t (function-theory-fn1 token (cdr lst) ans redefined)))) ((and (eq (car (car lst)) 'standard-theories) (eq (cadr (car lst)) 'global-value)) (revappend-delete-runes-based-on-symbols (case token (:definition (cadr (cddr (car lst)))) (:executable-counterpart (caddr (cddr (car lst)))) (otherwise (cadddr (cddr (car lst))))) redefined ans)) (t (function-theory-fn1 token (cdr lst) ans redefined))))
function-theory-fnfunction
(defun function-theory-fn (logical-name wrld) (declare (xargs :guard (logical-namep logical-name wrld))) (let* ((wrld1 (decode-logical-name logical-name wrld)) (redefined (collect-redefined wrld nil)) (wrld2 (putprop-x-lst1 redefined 'runic-mapping-pairs *acl2-property-unbound* wrld1))) (assert$-runic-theoryp (function-theory-fn1 :definition wrld2 nil nil) wrld)))
function-theorymacro
(defmacro function-theory (logical-name) (list 'function-theory-fn logical-name 'world))
executable-counterpart-theory-fnfunction
(defun executable-counterpart-theory-fn (logical-name wrld) (declare (xargs :guard (logical-namep logical-name wrld))) (let* ((wrld1 (decode-logical-name logical-name wrld)) (redefined (collect-redefined wrld nil)) (wrld2 (putprop-x-lst1 redefined 'runic-mapping-pairs *acl2-property-unbound* wrld1))) (function-theory-fn1 :executable-counterpart wrld2 nil nil)))
executable-counterpart-theorymacro
(defmacro executable-counterpart-theory (logical-name) (list 'executable-counterpart-theory-fn logical-name 'world))
standard-theoriesfunction
(defun standard-theories (wrld) (list (universal-theory-fn1 wrld nil nil) (function-theory-fn1 :definition wrld nil nil) (function-theory-fn1 :executable-counterpart wrld nil nil) (function-theory-fn1 :both wrld nil nil)))
current-theorymacro
(defmacro current-theory (logical-name) (list 'current-theory-fn logical-name 'world))
end-prehistoric-worldfunction
(defun end-prehistoric-world (wrld) (let* ((wrld1 (global-set-lst (list (list 'untouchable-fns (append *initial-untouchable-fns* (global-val 'untouchable-fns wrld))) (list 'untouchable-vars (append *initial-untouchable-vars* (global-val 'untouchable-vars wrld))) (list 'standard-theories (standard-theories wrld)) (list 'boot-strap-flg nil) (list 'boot-strap-pass-2 nil) (list 'command-number-baseline-info (let ((command-number-baseline (next-absolute-command-number wrld))) (make command-number-baseline-info :current command-number-baseline :permanent-p t :original command-number-baseline))) (list 'event-number-baseline (next-absolute-event-number wrld)) (list 'skip-proofs-seen nil) (list 'redef-seen nil) (list 'cert-replay nil) (list 'proof-supporters-alist nil) (list 'attachments-at-ground-zero (all-attachments wrld))) (putprop 'acl2-defaults-table 'table-alist *initial-acl2-defaults-table* (putprop 'return-last-table 'table-alist *initial-return-last-table* wrld)))) (thy (current-theory1 wrld nil nil)) (wrld2 (update-current-theory thy (length thy) wrld1))) (add-command-landmark :logic '(exit-boot-strap-mode) nil nil (add-event-landmark '(exit-boot-strap-mode) 'exit-boot-strap-mode 0 wrld2 t nil nil))))
theory-namepfunction
(defun theory-namep (name wrld) (and (symbolp name) (not (eq (getpropc name 'theory t wrld) t))))
theory-fnfunction
(defun theory-fn (name wrld) (declare (xargs :guard t)) (cond ((theory-namep name wrld) (getpropc name 'theory nil wrld)) (t (er hard?! 'theory "The alleged theory name, ~x0, is not the name of a previously ~ executed deftheory event. See :DOC theory." name))))
redundant-deftheory-pfunction
(defun redundant-deftheory-p (name runic-theory wrld) (equal (getpropc name 'theory t wrld) runic-theory))
deftheory-fnfunction
(defun deftheory-fn (name expr state redundant-okp ctx event-form) (when-logic "DEFTHEORY" (with-ctx-summarized (cond (ctx) (t (cons 'deftheory name))) (let ((wrld (w state)) (event-form (or event-form (list 'deftheory name expr)))) (er-progn (chk-all-but-new-name name ctx nil wrld state) (er-let* ((theory0 (translate-in-theory-hint expr nil ctx wrld state))) (cond ((and redundant-okp (redundant-deftheory-p name theory0 wrld)) (stop-redundant-event ctx state)) (t (er-let* ((wrld1 (chk-just-new-name name nil 'theory nil ctx wrld state))) (let ((length0 (length theory0))) (mv-let (theory theory-augmented-ignore) (extend-current-theory (global-val 'current-theory wrld) (global-val 'current-theory-length wrld) theory0 length0 :none wrld) (declare (ignore theory-augmented-ignore)) (let ((wrld2 (putprop name 'theory theory wrld1))) (install-event length0 event-form 'deftheory name nil nil nil nil wrld2 state)))))))))))))
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))))
set-in-theory-redundant-okpmacro
(defmacro set-in-theory-redundant-okp (val) (declare (xargs :guard (booleanp val))) `(with-output :off (event summary) (progn (table acl2-defaults-table :in-theory-redundant-okp ,VAL) (table acl2-defaults-table :in-theory-redundant-okp))))
in-theory-fnfunction
(defun in-theory-fn (expr state event-form) (when-logic "IN-THEORY" (with-ctx-summarized (cond ((atom expr) (msg "( IN-THEORY ~x0)" expr)) ((symbolp (car expr)) (msg "( IN-THEORY (~x0 ...))" (car expr))) (t "( IN-THEORY (...))")) (let ((wrld (w state)) (event-form (or event-form (list 'in-theory expr)))) (er-let* ((theory0 (translate-in-theory-hint expr t ctx wrld state))) (cond ((and (get-in-theory-redundant-okp state) (equal theory0 (current-theory-fn :here wrld))) (stop-redundant-event ctx state)) (t (let* ((ens1 (ens state)) (force-xnume-en1 (enabled-numep *force-xnume* ens1)) (imm-xnume-en1 (enabled-numep *immediate-force-modep-xnume* ens1)) (theory0-length (length theory0)) (wrld1 (update-current-theory theory0 theory0-length wrld)) (val (if (f-get-global 'script-mode state) :current-theory-updated (list :number-of-enabled-runes theory0-length)))) (er-let* ((val (install-event val event-form 'in-theory 0 nil nil :protect nil wrld1 state))) (pprogn (if (member-equal expr '((enable (:executable-counterpart force)) (disable (:executable-counterpart force)) (enable (:executable-counterpart immediate-force-modep)) (disable (:executable-counterpart immediate-force-modep)))) state (maybe-warn-about-theory ens1 force-xnume-en1 imm-xnume-en1 (ens state) ctx wrld state)) (value val)))))))))))
in-arithmetic-theory-fnfunction
(defun in-arithmetic-theory-fn (expr state event-form) (when-logic "IN-ARITHMETIC-THEORY" (with-ctx-summarized (cond ((atom expr) (msg "( IN-ARITHMETIC-THEORY ~x0)" expr)) ((symbolp (car expr)) (msg "( IN-ARITHMETIC-THEORY (~x0 ...))" (car expr))) (t "( IN-ARITHMETIC-THEORY (...))")) (let ((wrld (w state)) (event-form (or event-form (list 'in-arithmetic-theory expr)))) (cond ((not (quotep expr)) (er soft ctx "Arithmetic theory expressions must be quoted constants. ~ See :DOC in-arithmetic-theory.")) (t (er-let* ((theory (translate-in-theory-hint expr t ctx wrld state)) (ens (load-theory-into-enabled-structure expr theory nil (global-val 'global-arithmetic-enabled-structure wrld) nil nil wrld ctx state))) (let ((wrld1 (global-set 'global-arithmetic-enabled-structure ens wrld))) (install-event (length theory) event-form 'in-arithmetic-theory 0 nil nil nil nil wrld1 state)))))))))
disablemacro
(defmacro disable (&rest rst) (list 'set-difference-theories '(current-theory :here) (kwote rst)))
enablemacro
(defmacro enable (&rest rst) (list 'union-theories '(current-theory :here) (kwote rst)))
theory-invariant-table-guardfunction
(defun theory-invariant-table-guard (val world) (declare (xargs :guard (plist-worldp-with-formals world))) (and (weak-theory-invariant-record-p val) (booleanp (access theory-invariant-record val :error)) (let ((book (access theory-invariant-record val :book))) (or (book-name-p book) (null book))) (let ((tterm (access theory-invariant-record val :tterm))) (and (termp tterm world) (subsetp-eq (all-vars tterm) '(ens state))))))
other
(set-table-guard theory-invariant-table (theory-invariant-table-guard val world) :topic theory-invariant)
theory-invariant-fnfunction
(defun theory-invariant-fn (term state key error event-form) (when-logic "THEORY-INVARIANT" (with-ctx-summarized 'theory-invariant (er-let* ((tterm (translate term '(nil) nil '(state) 'theory-invariant (w state) state))) (let* ((inv-table (table-alist 'theory-invariant-table (w state))) (key (or key (1+ (length inv-table))))) (er-let* ((val (with-output! :off summary (table-fn1 'theory-invariant-table key (make theory-invariant-record :tterm tterm :error error :untrans-term term :book (active-book-name (w state) state)) :put nil 'theory-invariant (w state) (ens state) state event-form)))) (cond ((eq val :redundant) (value val)) (t (pprogn (cond ((assoc-equal key inv-table) (warning$ 'theory-invariant "Theory" "An existing theory invariant, named ~x0, is ~ being overwritten by a new theory invariant ~ with that name.~@1" key (cond ((f-get-global 'in-local-flg state) " Moreover, this override is being done ~ LOCALly; see :DOC theory-invariant (in ~ particular, the Local Redefinition ~ Caveat there), especially if an error ~ occurs.") (t "")))) (t state)) (mv-let (erp val state) (revert-world (with-output! :off summary (in-theory-fn '(current-theory :here) state '(in-theory (current-theory :here))))) (declare (ignore val)) (cond (erp (er-soft 'theory-invariant "Theory" "The specified theory invariant fails for the ~ current ACL2 world, and hence is rejected. This ~ failure can probably be overcome by supplying an ~ appropriate in-theory event first.")) (t (value key)))))))))))))
theory-invariantmacro
(defmacro theory-invariant (&whole event-form term &key key (error 't)) (list 'theory-invariant-fn (list 'quote term) 'state (list 'quote key) (list 'quote error) (list 'quote event-form)))
incompatiblemacro
(defmacro incompatible (rune1 rune2 &optional strictp) (let ((active-fn (if strictp 'active-or-non-runep 'active-runep))) (cond ((and (consp rune1) (consp (cdr rune1)) (symbolp (cadr rune1)) (consp rune2) (consp (cdr rune2)) (symbolp (cadr rune2))) `(not (and (,ACTIVE-FN ',RUNE1) (,ACTIVE-FN ',RUNE2)))) (t (er hard 'incompatible "Each argument to ~x0 should have the shape of a rune, ~ (:KEYWORD BASE-SYMBOL), unlike ~x1." 'incompatible (or (and (consp rune1) (consp (cdr rune1)) (symbolp (cadr rune1)) rune2) rune1))))))
incompatible!macro
(defmacro incompatible! (rune1 rune2) `(incompatible ,RUNE1 ,RUNE2 t))
*generic-bad-signature-string*constant
(defconst *generic-bad-signature-string* "The object ~x0 is not a legal signature. A basic signature is of one of ~ the following two forms: ((fn sym1 ... symn) => val) or (fn (var1 ... ~ varn) val). In either case, keywords may also be specified. See :DOC ~ signature.")
*signature-keywords*constant
(defconst *signature-keywords* '(:guard :stobjs :dfs :formals :global-stobjs :transparent))
duplicate-key-in-keyword-value-listpfunction
(defun duplicate-key-in-keyword-value-listp (l) (declare (xargs :guard (keyword-value-listp l))) (cond ((endp l) nil) ((assoc-keyword (car l) (cddr l)) (car l)) (t (duplicate-key-in-keyword-value-listp (cddr l)))))
formals-pretty-flags-mismatch-msgfunction
(defun formals-pretty-flags-mismatch-msg (formals pretty-flags fn formals-top pretty-flags-top) (declare (xargs :guard (symbol-listp pretty-flags))) (cond ((or (atom formals) (endp pretty-flags)) (cond ((and (atom formals) (endp pretty-flags)) nil) (t (msg "the specified list of :FORMALS, ~x0, is of length ~x1, ~ which does not match the arity of ~x2 specified by ~x3" formals-top (length formals-top) (length pretty-flags-top) (cons fn pretty-flags-top))))) ((and (not (equal (symbol-name (car pretty-flags)) "*")) (not (eq (car pretty-flags) (car formals)))) (let ((posn (- (length formals-top) (length formals)))) (msg "the specified list of :FORMALS, ~x0, has stobj ~x1 at ~ (zero-based) position ~x2, but the argument specified by ~x3 ~ at that position is a different stobj, ~x4" formals-top (car formals) posn (cons fn pretty-flags-top) (car pretty-flags)))) (t (formals-pretty-flags-mismatch-msg (cdr formals) (cdr pretty-flags) fn formals-top pretty-flags-top))))
chk-global-stobjs-valuefunction
(defun chk-global-stobjs-value (x guard fn formals val ctx wrld state) (cond ((null x) (value nil)) ((not (and (consp x) (symbol-listp (car x)) (symbol-listp (cdr x)))) (er soft ctx "Illegal signature for ~x0: the value of keyword :GLOBAL-STOBJS ~ must be a cons pair of the form (x . y) where x and y are lists ~ of symbols (in fact, stobj names). The :GLOBAL-STOBJS value ~ ~x1 is thus illegal.~@2" fn x *see-doc-with-global-stobj*)) ((or (duplicates (car x)) (duplicates (cdr x)) (intersection-eq (car x) (cdr x))) (er soft ctx "Illegal signature for ~x0: the value of keyword :GLOBAL-STOBJS ~ contains the name~#1~[~/s~] ~&1 more than once, but duplicates ~ are not allowed.~@2" fn (or (duplicates (car x)) (duplicates (cdr x)) (intersection-eq (car x) (cdr x))) *see-doc-with-global-stobj*)) ((and (not (equal x '(nil))) (not (member-eq 'state formals))) (er soft ctx "In the signature for ~x0, it is illegal to specify any stobjs ~ with the :GLOBAL-STOBJS keyword because ~x1 is not among the ~ formals for ~x0.~@2" fn 'state *see-doc-with-global-stobj*)) ((and (cdr x) (not (eq val 'state)) (not (and (true-listp val) (member-eq 'state val)))) (er soft ctx "In the signature for ~x0, it is illegal to specify any stobjs ~ in the CDR of the value of the :GLOBAL-STOBJS keyword (that is, ~ stobjs that are viewed as updated by WITH-GLOBAL-STOBJ forms) ~ because ~x1 is not returned by ~x0.~@2" fn 'state *see-doc-with-global-stobj*)) (t (er-progn (chk-all-stobj-names (car x) :global-stobjs (msg ":global-stobjs (~x0 . _)" (car x)) ctx wrld state) (chk-all-stobj-names (cdr x) :global-stobjs (msg ":global-stobjs (_ . ~x0)" (cdr x)) ctx wrld state) (er-let* ((tguard (cond (guard (translate guard t t nil ctx wrld state)) (t (value nil))))) (cond ((null tguard) (value nil)) (t (mv-let (reads writes fns-seen) (collect-global-stobjs tguard wrld nil nil nil) (declare (ignore fns-seen)) (cond ((not (subsetp-eq writes (cdr x))) (er soft ctx "The stobj~#0~[~x0 is~/s ~&0 are each~] bound ~ by an updating call of ~x1 in the :GUARD of ~ the signature for ~x2 but not among the ~ written stobjs in the :GLOBAL-STOBJS of that ~ signature.~@3" (set-difference-eq writes (cdr x)) 'with-global-stobj fn *see-doc-with-global-stobj*)) ((not (subsetp-eq reads (append (car x) (cdr x)))) (er soft ctx "The stobj~#0~[~x0 is~/s ~&0 are each~] bound ~ by a call of ~x1 in the :GUARD of the ~ signature for ~x2 but not among the stobjs in ~ the :GLOBAL-STOBJS of that signature.~@3" (set-difference-eq reads (append (car x) (cdr x))) 'with-global-stobj fn *see-doc-with-global-stobj*)) (t (value nil)))))))))))
chk-signaturefunction
(defun chk-signature (x ctx wrld state) (let ((bad-kwd-value-list-string "The object ~x0 is not a legal signature. It appears to specify ~x1 ~ as the keyword alist, which however is not syntactically a ~ keyword-value-listp because ~@2.")) (mv-let (msg fn formals val stobjs dfs kwd-value-list) (case-match x (((fn . pretty-flags1) arrow val . kwd-value-list) (cond ((not (and (symbolp arrow) (equal (symbol-name arrow) "=>"))) (mv (msg *generic-bad-signature-string* x) nil nil nil nil nil nil)) ((not (and (symbol-listp pretty-flags1) (no-duplicatesp-eq (collect-non-*-df pretty-flags1)))) (mv (msg "The object ~x0 is not a legal signature because ~x1 is not ~ applied to a true-list of distinct symbols but to ~x2 instead." x fn pretty-flags1) nil nil nil nil nil nil)) ((not (or (symbolp val) (and (consp val) (eq (car val) 'mv) (symbol-listp (cdr val)) (no-duplicatesp-eq (collect-non-*-df (cdr val)))))) (mv (msg "The object ~x0 is not a legal signature because the result, ~ ... => ~x1, is not a symbol or an MV form containing distinct ~ symbols." x val) nil nil nil nil nil nil)) ((or (member-eq t pretty-flags1) (member-eq nil pretty-flags1) (eq val t) (eq val nil) (and (consp val) (or (member-eq t (cdr val)) (member-eq nil (cdr val))))) (mv (msg "The object ~x0 is not a legal signature because it mentions T ~ or NIL in places that must each be filled by an asterisk (*), ~ :DF, or a single-threaded object name." x) nil nil nil nil nil nil)) ((not (subsetp-eq (collect-non-*-df (if (consp val) (cdr val) (list val))) pretty-flags1)) (mv (msg "The object ~x0 is not a legal signature because the result, ~ ~x1, refers to one or more single-threaded objects, ~&2, not ~ displayed among the inputs in ~x3." x val (collect-non-*-df (set-difference-eq (if (consp val) (cdr val) (list val)) pretty-flags1)) (cons fn pretty-flags1)) nil nil nil nil nil nil)) ((not (keyword-value-listp kwd-value-list)) (mv (msg bad-kwd-value-list-string x kwd-value-list (reason-for-non-keyword-value-listp kwd-value-list)) nil nil nil nil nil nil)) ((duplicate-key-in-keyword-value-listp kwd-value-list) (mv (msg "The object ~x0 is not a legal signature because the ~ keyword ~x1 appears more than once." x (duplicate-key-in-keyword-value-listp kwd-value-list)) nil nil nil nil nil nil)) ((or (assoc-keyword :stobjs kwd-value-list) (assoc-keyword :dfs kwd-value-list)) (mv (msg "The object ~x0 is not a legal signature. The ~ ~#1~[:STOBJS~/:DFS~] keyword is only legal for the older ~ style of signature (but may not be necessary for the ~ newer style that you are using); see :DOC signature." x (if (assoc-keyword :stobjs kwd-value-list) 0 1)) nil nil nil nil nil nil)) ((and (assoc-keyword :guard kwd-value-list) (not (assoc-keyword :formals kwd-value-list))) (mv (msg "The object ~x0 is not a legal signature. The :GUARD ~ keyword is only legal for the newer style of signature ~ when the :FORMALS keyword is also supplied; see :DOC ~ signature." x) nil nil nil nil nil nil)) ((or (not (booleanp (cadr (assoc-keyword :transparent kwd-value-list))))) (mv (msg "The object ~x0 is not a legal signature. The value of ~ the ~x1 keyword must be Boolean; see :DOC signature." x :transparent) nil nil nil nil nil nil)) (t (let* ((formals-tail (assoc-keyword :formals kwd-value-list)) (formals (if formals-tail (cadr formals-tail) (gen-formals-from-pretty-flags pretty-flags1))) (kwd-value-list (if formals-tail (remove-keyword :formals kwd-value-list) kwd-value-list)) (stobjs (collect-non-*-df pretty-flags1)) (dfs (collect-by-position '(:df) pretty-flags1 formals)) (msg (and formals-tail (formals-pretty-flags-mismatch-msg formals pretty-flags1 fn formals pretty-flags1)))) (cond (msg (mv (msg "The object ~x0 is not a legal signature ~ because ~@1. See :DOC signature." x msg) nil nil nil nil nil nil)) (t (mv nil fn formals val stobjs dfs kwd-value-list))))))) ((fn formals val . kwd-value-list) (cond ((not (true-listp formals)) (mv (msg "The object ~x0 is not a legal signature because its second ~ element, representing the formals, is not a true-list." x) nil nil nil nil nil nil)) ((not (keyword-value-listp kwd-value-list)) (mv (msg bad-kwd-value-list-string x kwd-value-list (reason-for-non-keyword-value-listp kwd-value-list)) nil nil nil nil nil nil)) ((duplicate-key-in-keyword-value-listp kwd-value-list) (mv (msg "The object ~x0 is not a legal signature because the keyword ~ ~x1 appears more than once." x (duplicate-key-in-keyword-value-listp kwd-value-list)) nil nil nil nil nil nil)) ((assoc-keyword :formals kwd-value-list) (mv (msg "The object ~x0 is not a legal signature. The :FORMALS ~ keyword is only legal for the newer style of signature; ~ see :DOC signature." x) nil nil nil nil nil nil)) ((or (not (booleanp (cadr (assoc-keyword :transparent kwd-value-list))))) (mv (msg "The object ~x0 is not a legal signature. The value of ~ the ~x1 keyword must be Boolean; see :DOC signature." x :transparent) nil nil nil nil nil nil)) (t (let* ((stobjs-tail (assoc-keyword :stobjs kwd-value-list)) (dfs-tail (assoc-keyword :dfs kwd-value-list)) (dfs (cadr dfs-tail)) (kwd-value-list (if (or stobjs-tail dfs-tail) (remove-keyword :stobjs (remove-keyword :dfs kwd-value-list)) kwd-value-list))) (cond ((not stobjs-tail) (let ((stobjs (if (member-eq 'state formals) '(state) nil))) (mv nil fn formals val stobjs dfs kwd-value-list))) ((or (symbolp (cadr stobjs-tail)) (symbol-listp (cadr stobjs-tail))) (let* ((stobjs0 (if (symbolp (cadr stobjs-tail)) (list (cadr stobjs-tail)) (cadr stobjs-tail))) (stobjs (if (and (member-eq 'state formals) (not (member-eq 'state stobjs0))) (cons 'state stobjs0) stobjs0))) (mv nil fn formals val stobjs dfs kwd-value-list))) (t (mv (msg "The object ~x0 is not a legal signature because ~ the proffered stobj names are ill-formed. The ~ stobj names are expected to be either a single ~ symbol or a true list of symbols." x) nil nil nil nil nil nil))))))) (& (mv (msg *generic-bad-signature-string* x) nil nil nil nil nil nil))) (cond (msg (er soft ctx "~@0" msg)) ((not (subsetp-eq (evens kwd-value-list) *signature-keywords*)) (er soft ctx "The only legal signature keywords are ~&0. The proposed ~ signature ~x1 is thus illegal." *signature-keywords* x)) (t (er-progn (chk-all-but-new-name fn ctx 'constrained-function wrld state) (chk-arglist formals (not (member-eq 'state stobjs)) ctx wrld state) (chk-all-stobj-names stobjs :stobjs? (msg "~x0" x) ctx wrld state) (cond ((not (or (symbolp val) (and (consp val) (eq (car val) 'mv) (symbol-listp (cdr val)) (> (length val) 2)))) (er soft ctx "The purported signature ~x0 is not a legal signature ~ because ~x1 is not a legal output description. Such a ~ description should either be a symbol or of the form (mv ~ sym1 ... symn), where n>=2." x val)) (t (value nil))) (chk-global-stobjs-value (cadr (assoc-keyword :global-stobjs kwd-value-list)) (cadr (assoc-keyword :guard kwd-value-list)) fn formals val ctx wrld state) (let* ((syms (cond ((symbolp val) (list val)) (t (cdr val)))) (stobjs-in (compute-stobj-flags formals stobjs dfs wrld)) (stobjs-out (compute-stobj-flags syms stobjs '(:df) wrld))) (cond ((not (subsetp (collect-non-nil-df stobjs-out) stobjs-in)) (er soft ctx "It is impossible to return single-threaded objects (such as ~ ~&0) that are not among the formals! Thus, the input ~ signature ~x1 and the output signature ~x2 are incompatible." (set-difference-eq (collect-non-nil-df stobjs-out) stobjs-in) formals val)) ((not (no-duplicatesp (collect-non-nil-df stobjs-out))) (er soft ctx "It is illegal to return the same single-threaded object in ~ more than one position of the output signature. Thus, ~x0 ~ is illegal because ~&1 ~#1~[is~/are~] duplicated." val (duplicates (collect-non-nil-df stobjs-out)))) (t (er-let* ((wrld1 (chk-just-new-name fn nil (list* 'function stobjs-in stobjs-out) nil ctx wrld state))) (value (list* (list fn formals stobjs-in stobjs-out) kwd-value-list wrld1))))))))))))
chk-signatures-recfunction
(defun chk-signatures-rec (signatures ctx wrld state) (cond ((atom signatures) (cond ((null signatures) (value (list* nil nil wrld))) (t (er soft ctx "The list of the signatures of the functions ~ constrained by an encapsulation is supposed to ~ be a true list, but yours ends in ~x0. See ~ :DOC encapsulate." signatures)))) ((and (consp (cdr signatures)) (symbolp (cadr signatures)) (equal (symbol-name (cadr signatures)) "=>")) (er soft ctx "The signatures argument of ENCAPSULATE is supposed to ~ be a list of signatures. But you have provided ~x0, ~ which might be a single signature. Try writing ~x1." signatures (list signatures))) (t (er-let* ((trip1 (chk-signature (car signatures) ctx wrld state)) (trip2 (chk-signatures-rec (cdr signatures) ctx (cddr trip1) state))) (let ((insig (car trip1)) (kwd-value-list (cadr trip1)) (insig-lst (car trip2)) (kwd-value-list-lst (cadr trip2)) (wrld1 (cddr trip2))) (cond ((assoc-eq (car insig) insig-lst) (er soft ctx "The name ~x0 is mentioned twice in the ~ signatures of this encapsulation. See :DOC ~ encapsulate." (car insig))) (t (value (list* (cons insig insig-lst) (cons kwd-value-list kwd-value-list-lst) wrld1)))))))))
chk-transparentfunction
(defun chk-transparent (name val insig-lst kwd-value-list-lst ctx state) (cond ((endp kwd-value-list-lst) (value nil)) ((eq val (cadr (assoc-keyword :transparent (car kwd-value-list-lst)))) (chk-transparent name val (cdr insig-lst) (cdr kwd-value-list-lst) ctx state)) (t (er soft ctx "The signature for ~x0 specifies :transparent t, but the ~ signature for ~x1 does not. This is illegal because if any ~ signature in an encapsulate event specifies :transparent t, ~ then all must do so. See :DOC encapsulate." (if val name (caar insig-lst)) (if val (caar insig-lst) name)))))
chk-signaturesfunction
(defun chk-signatures (signatures ctx wrld state) (er-let* ((trip (chk-signatures-rec signatures ctx wrld state)) (insig-lst (value (car trip))) (kwd-value-list-lst (value (cadr trip)))) (er-progn (cond ((or (null kwd-value-list-lst) (null (cdr kwd-value-list-lst))) (value nil)) (t (chk-transparent (caar insig-lst) (cadr (assoc-keyword :transparent (car kwd-value-list-lst))) (cdr insig-lst) (cdr kwd-value-list-lst) ctx state))) (value trip))))
chk-acceptable-encapsulate1function
(defun chk-acceptable-encapsulate1 (signatures form-lst ctx wrld state) (er-progn (cond ((not (and (true-listp form-lst) (consp form-lst) (consp (car form-lst)))) (er soft ctx "The arguments to encapsulate, after the first, are ~ each supposed to be embedded event forms. There must ~ be at least one form. See :DOC encapsulate and :DOC ~ embedded-event-form.")) (t (value nil))) (chk-signatures signatures ctx wrld state)))
name-introducedfunction
(defun name-introduced (trip functionp) (cond ((eq (cddr trip) *acl2-property-unbound*) nil) ((eq (cadr trip) 'formals) (car trip)) (functionp nil) ((member-eq (cadr trip) '(theorem const macro-body label theory stobj)) (car trip)) ((and (eq (car trip) 'certification-tuple) (eq (cadr trip) 'global-value) (cddr trip)) (car (cddr trip))) (t nil)))
chk-embedded-event-form-orig-form-msgfunction
(defun chk-embedded-event-form-orig-form-msg (orig-form state) (cond (orig-form (msg " Note: the above form was encountered during processing of ~X01." orig-form (term-evisc-tuple t state))) (t "")))
*acl2-defaults-table-macros*constant
(defconst *acl2-defaults-table-macros* '(add-include-book-dir add-match-free-override defttag delete-include-book-dir logic program set-backchain-limit set-bogus-defun-hints-ok set-bogus-mutual-recursion-ok set-case-split-limitations set-compile-fns set-default-backchain-limit set-enforce-redundancy set-ignore-ok set-irrelevant-formals-ok set-let*-abstractionp set-match-free-default set-measure-function set-non-linearp set-prover-step-limit set-rewrite-stack-limit set-ruler-extenders set-state-ok set-subgoal-loop-limits set-tau-auto-mode set-verify-guards-eagerness set-well-founded-relation))
chk-embedded-event-formfunction
(defun chk-embedded-event-form (form orig-form wrld ctx state names in-local-flg in-encapsulatep make-event-chk) (let* ((er-str "The form ~x0 is not an embedded event form~@1. See :DOC ~ embedded-event-form.~@2~@3") (local-str "The form ~x0 is not an embedded event form in the ~ context of LOCAL~@1. See :DOC embedded-event-form.~@2~@3") (encap-str "The form ~x0 is not an embedded event form in the ~ context of ENCAPSULATE~@1. See :DOC ~ embedded-event-form.~@2~@3")) (cond ((or (atom form) (not (symbolp (car form))) (not (true-listp (cdr form)))) (er soft ctx er-str form "" (chk-embedded-event-form-orig-form-msg orig-form state) "")) ((and (eq (car form) 'local) (consp (cdr form)) (null (cddr form))) (cond ((eq (ld-skip-proofsp state) 'include-book) (value nil)) (t (er-let* ((new-form (chk-embedded-event-form (cadr form) orig-form wrld ctx state names t in-encapsulatep make-event-chk))) (value (and new-form (list (car form) new-form))))))) ((and (eq in-local-flg t) (consp form) (eq (car form) 'table) (consp (cdr form)) (eq (cadr form) 'acl2-defaults-table)) (er soft ctx local-str form " because it sets the acl2-defaults-table in a local context. ~ A local context is not useful when setting this table, since ~ the acl2-defaults-table is restored upon completion of ~ encapsulate, include-book, and certify-book forms; that is, ~ no changes to the acl2-defaults-table are exported" (chk-embedded-event-form-orig-form-msg orig-form state) "")) ((and (eq in-local-flg t) (consp form) (member-eq (car form) *acl2-defaults-table-macros*)) (er soft ctx local-str form " because it implicitly sets the acl2-defaults-table in a ~ local context; see :DOC acl2-defaults-table, in particular ~ the explanation about this error message" (chk-embedded-event-form-orig-form-msg orig-form state) "")) ((and in-local-flg (eq (car form) 'defaxiom)) (er soft ctx local-str form " because it adds an axiom whose traces will disappear" (chk-embedded-event-form-orig-form-msg orig-form state) "")) ((and in-encapsulatep (eq (car form) 'defaxiom)) (er soft ctx encap-str form " because we do not permit defaxiom events in the scope of an ~ encapsulate" (chk-embedded-event-form-orig-form-msg orig-form state) "")) ((and in-local-flg (member-eq (car form) '(add-include-book-dir! delete-include-book-dir!))) (er soft ctx local-str form (msg " (see :DOC ~x0)" (car form)) (chk-embedded-event-form-orig-form-msg orig-form state) "")) ((and (eq (car form) 'include-book) in-encapsulatep (or (eq in-local-flg nil) (eq in-local-flg 'local-encapsulate))) (er soft ctx encap-str form " because we do not permit non-local include-book forms in the ~ scope of an encapsulate. Consider moving your include-book ~ form outside the encapsulates, or else making it local" (chk-embedded-event-form-orig-form-msg orig-form state) "")) ((member-eq (car form) names) (value form)) ((and (eq (car form) 'skip-proofs) (consp (cdr form)) (null (cddr form))) (pprogn (cond ((global-val 'embedded-event-lst wrld) (warning$ ctx "Skip-proofs" "ACL2 has encountered a SKIP-PROOFS form, ~x0, ~ in the context of a book or an encapsulate ~ event. Therefore, no logical claims may be ~ soundly made in this context. See :DOC ~ SKIP-PROOFS." form)) (t state)) (er-let* ((new-form (chk-embedded-event-form (cadr form) orig-form wrld ctx state names in-local-flg in-encapsulatep make-event-chk))) (value (and new-form (list (car form) new-form)))))) ((and (member-eq (car form) '(with-cbd with-current-package with-guard-checking-event with-output with-prover-step-limit with-prover-time-limit)) (true-listp form)) (cond ((and (eq (car form) 'with-guard-checking-event) (or (atom (cdr form)) (let ((val (cadr form))) (not (case-match val (('quote x) (member-eq x *guard-checking-values*)) (& (member-eq val *guard-checking-values*))))))) (er soft ctx er-str form "" (chk-embedded-event-form-orig-form-msg orig-form state) (msg "~|The macro ~x0 requires the second argument to be a ~ constant from the list ~x1, or of the form (QUOTE X) ~ for such a constant, X." 'with-guard-checking-event *guard-checking-values*))) ((and (member-eq (car form) '(with-cbd with-current-package)) (not (stringp (cadr form)))) (er soft ctx er-str form "" (chk-embedded-event-form-orig-form-msg orig-form state) (msg "~|The macro ~x0 requires the second argument to be a ~ string when used in an event context." (car form)))) (t (er-let* ((new-form (chk-embedded-event-form (car (last form)) orig-form wrld ctx state names in-local-flg in-encapsulatep make-event-chk))) (value (and new-form (append (butlast form 1) (list new-form)))))))) ((eq (car form) 'make-event) (cond ((and make-event-chk (not (and (true-listp form) (or (consp (cadr (member-eq :check-expansion form))) (consp (cadr (member-eq :expansion? form)))))) (not (ld-redefinition-action state))) (er soft ctx "Either the :check-expansion or :expansion? argument of ~ make-event is normally a consp in the present context. ~ ~ This is not surprising in some cases, for example, ~ when including an uncertified book or calling ~x0 ~ explicitly. But other cases could be evidence of an ~ ACL2 bug; consider contacting the ACL2 implementors. ~ Current form:~|~%~X12" 'record-expansion form nil)) (t (value form)))) ((eq (car form) 'record-expansion) (cond ((not (and (cdr form) (cddr form) (null (cdddr form)))) (er soft ctx "The macro ~x0 takes two arguments, so ~x1 is illegal." 'record-expansion form)) (t (er-progn (chk-embedded-event-form (cadr form) nil wrld ctx state names in-local-flg in-encapsulatep nil) (chk-embedded-event-form (caddr form) (or orig-form form) wrld ctx state names in-local-flg in-encapsulatep t))))) ((getpropc (car form) 'macro-body nil wrld) (cond ((member-eq (car form) '(mv mv-let translate-and-test with-local-stobj with-global-stobj)) (er soft ctx er-str form "" (chk-embedded-event-form-orig-form-msg orig-form state) (msg "~|Calls of the macro ~x0 do not generate an event, ~ because this macro has special meaning that is not ~ handled by ACL2's event-generation mechanism." (car form)))) (t (er-let* ((expansion (macroexpand1 form ctx state))) (chk-embedded-event-form expansion (or orig-form form) wrld ctx state names in-local-flg in-encapsulatep make-event-chk))))) (t (er soft ctx er-str form "" (chk-embedded-event-form-orig-form-msg orig-form state) "")))))
*destructure-expansion-wrappers*constant
(defconst *destructure-expansion-wrappers* '(local skip-proofs with-cbd with-current-package with-guard-checking-event with-output with-prover-step-limit with-prover-time-limit))
destructure-expansionfunction
(defun destructure-expansion (form) (declare (xargs :guard (true-listp form))) (cond ((member-eq (car form) *destructure-expansion-wrappers*) (mv-let (wrappers base-form) (destructure-expansion (car (last form))) (mv (cons (butlast form 1) wrappers) base-form))) (t (mv nil form))))
rebuild-expansionfunction
(defun rebuild-expansion (wrappers form) (cond ((endp wrappers) form) (t (append (car wrappers) (list (rebuild-expansion (cdr wrappers) form))))))
set-raw-mode-onfunction
(defun set-raw-mode-on (state) (pprogn (cond ((raw-mode-p state) state) (t (f-put-global 'acl2-raw-mode-p t state))) (value :invisible)))
set-raw-mode-offfunction
(defun set-raw-mode-off (state) (pprogn (cond ((raw-mode-p state) (f-put-global 'acl2-raw-mode-p nil state)) (t state)) (value :invisible)))
set-raw-mode-on!macro
(defmacro set-raw-mode-on! nil '(er-progn (ld '((defttag :raw-mode-hack) (set-raw-mode-on state)) :ld-prompt nil :ld-verbose nil :ld-post-eval-print nil :ld-user-stobjs-modified-warning :same) (value :invisible)))
set-raw-modemacro
(defmacro set-raw-mode (flg) (declare (xargs :guard (member-equal flg '(t 't nil 'nil)))) (if (or (null flg) (equal flg ''nil)) '(set-raw-mode-off state) '(set-raw-mode-on state)))
alist-to-bindingsfunction
(defun alist-to-bindings (alist) (cond ((endp alist) nil) (t (cons (list (caar alist) (kwote (cdar alist))) (alist-to-bindings (cdr alist))))))
acl2-raw-evalfunction
(defun acl2-raw-eval (form state) (trans-eval-no-warning form 'top-level state t))
get-and-chk-last-make-event-expansionfunction
(defun get-and-chk-last-make-event-expansion (form wrld ctx state names) (let ((expansion (f-get-global 'last-make-event-expansion state))) (cond (expansion (mv-let (erp val state) (state-global-let* ((inhibit-output-lst *valid-output-names*)) (chk-embedded-event-form form nil wrld ctx state names nil nil nil)) (declare (ignore val)) (cond (erp (er soft ctx "Make-event is only legal in event contexts, where it ~ can be tracked properly; see :DOC make-event. The ~ form ~p0 has thus generated an illegal call of ~ make-event. This form's evaluation will have no ~ effect on the ACL2 logical world." form)) (t (value expansion))))) (t (value nil)))))
*local-value-triple-elided*constant
(defconst *local-value-triple-elided* '(local (value-triple :elided)))
elide-localsmacro
(defmacro elide-locals (form) `(mv-let (changed-p x) (elide-locals-rec ,FORM) (declare (ignore changed-p)) x))
elide-locals-recmutual-recursion
(mutual-recursion (defun elide-locals-rec (form) (cond ((atom form) (mv nil form)) ((equal form *local-value-triple-elided*) (mv nil form)) ((eq (car form) 'local) (mv t *local-value-triple-elided*)) ((eq (car form) 'encapsulate) (mv-let (changed-p x) (elide-locals-lst (cddr form)) (cond (changed-p (mv t (list* (car form) (cadr form) x))) (t (mv nil form))))) ((member-eq (car form) '(skip-proofs with-cbd with-current-package with-guard-checking-event with-output with-prover-time-limit with-prover-step-limit record-expansion time$)) (mv-let (changed-p x) (elide-locals-rec (car (last form))) (cond ((and (consp x) (eq (car x) 'local) (not (eq (car form) 'record-expansion))) (mv t x)) (changed-p (mv t (append (butlast form 1) (list x)))) (t (mv nil form))))) ((or (eq (car form) 'progn) (and (eq (car form) 'progn!) (not (and (consp (cdr form)) (eq (cadr form) :state-global-bindings))))) (mv-let (changed-p x) (elide-locals-lst (cdr form)) (cond (changed-p (mv t (cons (car form) x))) (t (mv nil form))))) ((eq (car form) 'progn!) (mv-let (changed-p x) (elide-locals-lst (cddr form)) (cond (changed-p (mv t (list* (car form) (cadr form) x))) (t (mv nil form))))) (t (mv nil form)))) (defun elide-locals-lst (x) (cond ((endp x) (mv nil nil)) (t (mv-let (changedp1 first) (elide-locals-rec (car x)) (mv-let (changedp2 rest) (elide-locals-lst (cdr x)) (cond ((or changedp1 changedp2) (mv t (cons first rest))) (t (mv nil x)))))))))
make-record-expansion?function
(defun make-record-expansion? (event expansion r-e-p) (cond ((not r-e-p) expansion) (t (case-match event (('record-expansion a &) (list 'record-expansion a expansion)) (& (list 'record-expansion event expansion))))))
table-putmacro
(defmacro table-put (name key val) `(table-fn ',NAME '(,KEY ,VAL) state '(table ,NAME ,KEY ,VAL)))
maybe-add-event-landmarkfunction
(defun maybe-add-event-landmark (state) (cond ((let ((wrld (w state))) (not (and (eq (caar wrld) 'event-landmark) (eq (cadar wrld) 'global-value)))) (state-global-let* ((inhibit-output-lst (add-to-set-eq 'summary (f-get-global 'inhibit-output-lst state)))) (table-put acl2-system-table 'empty-event-key (not (cdr (assoc-eq 'empty-event-key (table-alist 'acl2-system-table world))))))) (t (value nil))))
eval-event-lstfunction
(defun eval-event-lst (index expansion-alist ev-lst quietp environment in-local-flg last-val other-control kpa caller ctx channel state) (flet ((event-macros (caller) (if (eq caller 'eval-some-portcullis-cmds) (cons 'defpkg (primitive-event-macros)) (primitive-event-macros)))) (cond ((null ev-lst) (pprogn (f-put-global 'last-make-event-expansion nil state) (mv nil last-val (reverse expansion-alist) kpa state))) (t (let ((old-wrld (w state))) (pprogn (cond (quietp state) (t (io? event nil state (channel ev-lst) (fms "~%~@0~sr ~@1~*2~#3~[~Q45~/~]~|" (list (cons #\0 (f-get-global 'current-package state)) (cons #\1 (defun-mode-prompt-string state)) (cons #\2 (list "" ">" ">" ">" (make-list-ac (1+ (f-get-global 'ld-level state)) nil nil))) (cons #\3 (if (eq (ld-pre-eval-print state) :never) 1 0)) (cons #\4 (car ev-lst)) (cons #\5 (term-evisc-tuple nil state)) (cons #\r "")) channel state nil)))) (mv-let (erp form state) (cond ((eq other-control :non-event-ok) (mv nil (car ev-lst) state)) (t (chk-embedded-event-form (car ev-lst) nil (w state) ctx state (event-macros caller) in-local-flg (member-eq 'encapsulate environment) other-control))) (cond (erp (pprogn (f-put-global 'last-make-event-expansion nil state) (mv 'non-event index nil nil state))) ((null form) (eval-event-lst (1+ index) expansion-alist (cdr ev-lst) quietp environment in-local-flg nil other-control kpa caller ctx channel state)) (t (mv-let (erp trans-ans state) (pprogn (f-put-global 'last-make-event-expansion nil state) (if (raw-mode-p state) (acl2-raw-eval form state) (trans-eval-no-warning form ctx state t))) (let* ((tuple (cond ((eq other-control :non-event-ok) (let* ((stobjs-out (car trans-ans)) (result (replace-stobjs stobjs-out (cdr trans-ans)))) (if (null (cdr stobjs-out)) (list nil result) result))) (t (cdr trans-ans)))) (erp-prime (car tuple)) (val-prime (cadr tuple))) (cond ((or erp erp-prime) (pprogn (cond ((and (consp (car ev-lst)) (eq (car (car ev-lst)) 'record-expansion)) (let ((chan (proofs-co state))) (io? error nil state (chan ev-lst) (fmt-abbrev "~%Note: The error reported above ~ occurred when processing the ~ make-event expansion of the form ~ ~x0." (list (cons #\0 (cadr (car ev-lst)))) 0 chan state "~|~%")))) (t state)) (f-put-global 'last-make-event-expansion nil state) (mv (if erp t (list erp-prime)) index nil kpa state))) (t (pprogn (cond (quietp state) (t (io? summary nil state (val-prime channel) (cond ((member-eq 'value (f-get-global 'inhibited-summary-types state)) state) (t (mv-let (col state) (fmt1 "~y0" (list (cons #\0 val-prime)) 0 channel state (ld-evisc-tuple state)) (declare (ignore col)) state)))))) (mv-let (erp expansion0 state) (get-and-chk-last-make-event-expansion (car ev-lst) (w state) ctx state (event-macros caller)) (cond (erp (pprogn (f-put-global 'last-make-event-expansion nil state) (mv 'make-event-problem index nil nil state))) (t (mv-let (erp ignored-val state) (cond ((and (eq caller 'certify-book) (eq (global-val 'cert-replay (w state)) t)) (pprogn (set-w 'extension (global-set 'cert-replay (cons index old-wrld) (w state)) state) (maybe-add-event-landmark state))) (t (value nil))) (declare (ignore ignored-val)) (cond (erp (mv 'make-event-problem index nil nil state)) (t (eval-event-lst (1+ index) (cond (expansion0 (acons index (make-record-expansion? (car ev-lst) (mv-let (wrappers base-form) (destructure-expansion form) (declare (ignore base-form)) (rebuild-expansion wrappers expansion0)) (member-eq caller '(encapsulate-pass-1 encapsulate-pass-2))) expansion-alist)) (t expansion-alist)) (cdr ev-lst) quietp environment in-local-flg val-prime other-control (cond ((or (null kpa) (integerp kpa) (equal kpa (known-package-alist state))) kpa) (t index)) caller ctx channel state)))))))))))))))))))))
equal-insigfunction
(defun equal-insig (insig1 insig2) (and (equal (car insig1) (car insig2)) (equal (caddr insig1) (caddr insig2)) (equal (cadddr insig1) (cadddr insig2))))
bad-signature-alistfunction
(defun bad-signature-alist (insigs kwd-value-list-lst udf-fns wrld) (declare (ignorable kwd-value-list-lst)) (cond ((null insigs) nil) ((member-eq (caar insigs) udf-fns) (bad-signature-alist (cdr insigs) (cdr kwd-value-list-lst) udf-fns wrld)) (t (let* ((declared-insig (car insigs)) (fn (car declared-insig)) (actual-insig (list fn (formals fn wrld) (stobjs-in fn wrld) (stobjs-out fn wrld)))) (cond ((and (equal-insig declared-insig actual-insig)) (bad-signature-alist (cdr insigs) (cdr kwd-value-list-lst) udf-fns wrld)) (t (cons (list fn declared-insig actual-insig) (bad-signature-alist (cdr insigs) (cdr kwd-value-list-lst) udf-fns wrld))))))))
if-nsmacro
(defmacro if-ns (test tbr fbr ctx) (declare (ignore tbr)) (list 'if test `(er hard ,CTX "Unexpected intrusion of non-standard analysis into standard ~ ACL2! Please contact the implementors.") fbr))
tilde-*-bad-insigs-phrase1function
(defun tilde-*-bad-insigs-phrase1 (alist) (cond ((null alist) nil) (t (let* ((fn (caar alist)) (dcl-insig (cadar alist)) (act-insig (caddar alist))) (cons (if-ns (equal-insig dcl-insig act-insig) (msg "The signature you declared for ~x0 and the local ~ witness for that function do not agree on whether the ~ function is classical. If you are seeing this error ~ in the context of an attempt to admit a call of ~ DEFUN-SK without a :CLASSICALP keyword supplied, then ~ a solution is likely to be the addition of :CLASSICALP ~ ~x1 to the DEFUN-SK form." fn nil) (msg "The signature you declared for ~x0 is ~x1, but ~ the signature of your local witness for it is ~ ~x2." fn (unparse-signature dcl-insig) (unparse-signature act-insig)) 'tilde-*-bad-insigs-phrase1) (tilde-*-bad-insigs-phrase1 (cdr alist)))))))
tilde-*-bad-insigs-phrasefunction
(defun tilde-*-bad-insigs-phrase (alist) (list "" "~@*" "~@*" "~@*" (tilde-*-bad-insigs-phrase1 alist)))
chk-acceptable-encapsulate2function
(defun chk-acceptable-encapsulate2 (insigs kwd-value-list-lst wrld ctx state) (let ((udf-fns (collect-non-logic-mode insigs wrld))) (mv-let (erp1 val state) (cond (udf-fns (er soft ctx "You provided signatures for ~&0, but ~#0~[that function ~ was~/those functions were~] not defined in :logic mode by the ~ encapsulated event list. See :DOC encapsulate." (merge-sort-symbol< udf-fns))) (t (value nil))) (declare (ignore val)) (mv-let (erp2 val state) (let ((bad-sig-alist (bad-signature-alist insigs kwd-value-list-lst udf-fns wrld))) (cond (bad-sig-alist (er soft ctx "The signature~#0~[~/s~] provided for the function~#0~[~/s~] ~ ~&0 ~#0~[is~/are~] incorrect. See :DOC encapsulate. ~*1" (strip-cars bad-sig-alist) (tilde-*-bad-insigs-phrase bad-sig-alist))) (t (value nil)))) (declare (ignore val)) (mv (or erp1 erp2) nil state)))))
conjoin-into-alistfunction
(defun conjoin-into-alist (fn thm alist) (cond ((null alist) (list (cons fn thm))) ((eq fn (caar alist)) (cons (cons fn (conjoin2 thm (cdar alist))) (cdr alist))) (t (cons (car alist) (conjoin-into-alist fn thm (cdr alist))))))
classes-theoremsfunction
(defun classes-theorems (classes) (cond ((null classes) nil) (t (let ((term (cadr (assoc-keyword :corollary (cdr (car classes)))))) (if term (cons term (classes-theorems (cdr classes))) (classes-theorems (cdr classes)))))))
constraint-lst-etc-introduced2function
(defun constraint-lst-etc-introduced2 (thms origins fns ans-constraint-lst-etc) (cond ((endp thms) ans-constraint-lst-etc) ((ffnnamesp fns (car thms)) (constraint-lst-etc-introduced2 (cdr thms) (cdr origins) fns (let ((conjuncts (flatten-ands-in-lit (car thms)))) (constraint-lst-etc-union (cons conjuncts (make-list (length conjuncts) :initial-element (car origins))) ans-constraint-lst-etc)))) (t (constraint-lst-etc-introduced2 (cdr thms) (cdr origins) fns ans-constraint-lst-etc))))
constraint-lst-etc-introduced1function
(defun constraint-lst-etc-introduced1 (constraint-lst-etc fns ans-constraint-lst-etc) (constraint-lst-etc-introduced2 (car constraint-lst-etc) (cdr constraint-lst-etc) fns ans-constraint-lst-etc))
new-trips-recfunction
(defun new-trips-rec (wrld3 proto-wrld3 seen acc) (cond ((equal wrld3 proto-wrld3) (prog2$ (fast-alist-free seen) (reverse acc))) ((let ((key-alist (hons-get (caar wrld3) seen))) (and key-alist (assoc-eq (cadar wrld3) (cdr key-alist)))) (new-trips-rec (cdr wrld3) proto-wrld3 seen acc)) ((eq (cddr (car wrld3)) *acl2-property-unbound*) (new-trips-rec (cdr wrld3) proto-wrld3 (hons-acons (caar wrld3) (cons (cdar wrld3) (cdr (hons-get (caar wrld3) seen))) seen) acc)) (t (new-trips-rec (cdr wrld3) proto-wrld3 (hons-acons (caar wrld3) (cons (cdar wrld3) (cdr (hons-get (caar wrld3) seen))) seen) (cons (car wrld3) acc)))))
new-tripsfunction
(defun new-trips (wrld3 proto-wrld3) (new-trips-rec wrld3 proto-wrld3 nil nil))
constraint-lst-etc-introducedfunction
(defun constraint-lst-etc-introduced (new-trips fns ans-constraint-lst-etc) (cond ((endp new-trips) ans-constraint-lst-etc) (t (constraint-lst-etc-introduced (cdr new-trips) fns (let ((trip (car new-trips))) (case (cadr trip) (constraint-lst-etc (let ((constraint-lst-etc (cddr trip))) (cond ((unknown-constraints-p (car constraint-lst-etc)) (er hard 'constraint-lst-etc-introduced "Implementation error in constraint-lst-etc-introduced: ~ Please contact the ACL2 developers.")) ((symbolp (car constraint-lst-etc)) ans-constraint-lst-etc) (t (constraint-lst-etc-introduced1 constraint-lst-etc fns ans-constraint-lst-etc))))) (theorem (cond ((ffnnamesp fns (cddr trip)) (let ((conjuncts (flatten-ands-in-lit (cddr trip)))) (constraint-lst-etc-union (cons conjuncts (make-list (length conjuncts) :initial-element (make-origin 'theorem (car trip)))) ans-constraint-lst-etc))) (t ans-constraint-lst-etc))) (classes (constraint-lst-etc-introduced1 (let ((thms (classes-theorems (cddr trip)))) (cons thms (make-list (length thms) :initial-element (make-origin 'corollary (car trip))))) fns ans-constraint-lst-etc)) (otherwise ans-constraint-lst-etc)))))))
putprop-constraintsfunction
(defun putprop-constraints (fn constrained-fns constraint-lst-etc unknown-constraints-p wrld3) (putprop-x-lst1 constrained-fns 'constraint-lst-etc (cons fn nil) (putprop fn 'constraint-lst-etc constraint-lst-etc (cond (unknown-constraints-p (putprop-x-lst1 constrained-fns 'constrainedp *unknown-constraints* (putprop fn 'constrainedp *unknown-constraints* wrld3))) (t wrld3)))))
maybe-install-acl2-defaults-tablefunction
(defun maybe-install-acl2-defaults-table (acl2-defaults-table state) (cond ((equal acl2-defaults-table (table-alist 'acl2-defaults-table (w state))) (value nil)) (t (state-global-let* ((inhibit-output-lst (cons 'summary (@ inhibit-output-lst))) (modifying-include-book-dir-alist t)) (table-fn 'acl2-defaults-table `(nil ',ACL2-DEFAULTS-TABLE :clear) state `(table acl2-defaults-table nil ',ACL2-DEFAULTS-TABLE :clear))))))
update-for-redo-flatfunction
(defun update-for-redo-flat (n ev-lst state) (assert$ (and (natp n) (< n (length ev-lst))) (pprogn (f-put-global 'redo-flat-succ (append? (take n ev-lst) (f-get-global 'redo-flat-succ state)) state) (if (null (f-get-global 'redo-flat-fail state)) (f-put-global 'redo-flat-fail (nth n ev-lst) state) state))))
redo-flatmacro
(defmacro redo-flat (&key (succ-ld-skip-proofsp 't) (label 'r) (succ 't) (fail 't) (pbt 't) (show 'nil)) `(if (null (f-get-global 'redo-flat-fail state)) (pprogn (fms "There is no failure saved from an encapsulate, progn, or ~ certify-book.~|" nil (standard-co state) state nil) (value :invisible)) ,(IF SHOW `(PPROGN (FMS "List of events preceding the failure:~|~%~x0~|" (LIST (CONS #\0 (F-GET-GLOBAL 'REDO-FLAT-SUCC STATE))) (STANDARD-CO STATE) STATE (LD-EVISC-TUPLE STATE)) (FMS "Failed event:~|~%~x0~|" (LIST (CONS #\0 (F-GET-GLOBAL 'REDO-FLAT-FAIL STATE))) (STANDARD-CO STATE) STATE (LD-EVISC-TUPLE STATE)) (VALUE :INVISIBLE)) `(LET ((REDO-FLAT-SUCC (F-GET-GLOBAL 'REDO-FLAT-SUCC STATE)) (REDO-FLAT-FAIL (F-GET-GLOBAL 'REDO-FLAT-FAIL STATE))) (STATE-GLOBAL-LET* ((REDO-FLAT-SUCC REDO-FLAT-SUCC) (REDO-FLAT-FAIL REDO-FLAT-FAIL)) (LD (LIST ,@(AND SUCC LABEL `('(DEFLABEL ,LABEL))) ,@(AND SUCC (LIST (LIST 'LIST ''LD (LIST 'CONS ''LIST (LIST 'KWOTE-LST 'REDO-FLAT-SUCC)) :LD-SKIP-PROOFSP SUCC-LD-SKIP-PROOFSP))) ,@(AND FAIL (LIST (LIST 'LIST ''LD (LIST 'LIST ''LIST (LIST 'LIST ''QUOTE 'REDO-FLAT-FAIL)) :LD-ERROR-ACTION :CONTINUE :LD-PRE-EVAL-PRINT T))) ,@(AND PBT SUCC LABEL `('(PPROGN (NEWLINE (PROOFS-CO STATE) STATE) (PBT ',LABEL))))) :LD-USER-STOBJS-MODIFIED-WARNING :SAME))))))
cert-opfunction
(defun cert-op (state) (let ((certify-book-info (f-get-global 'certify-book-info state))) (and certify-book-info (or (access certify-book-info certify-book-info :cert-op) t))))
eval-event-lst-environmentfunction
(defun eval-event-lst-environment (in-encapsulatep state) (let* ((x (if in-encapsulatep '(encapsulate) nil))) (case (cert-op state) ((nil :write-acl2x :write-acl2xu) x) ((t :create+convert-pcert) (cons 'certify-book x)) (otherwise (cons 'pcert x)))))
process-embedded-eventsfunction
(defun process-embedded-events (caller acl2-defaults-table skip-proofsp pkg ee-entry ev-lst index make-event-chk cert-data ctx state) (let* ((wrld1 (w state)) (kpa (known-package-alist state)) (old-embedded-event-lst (global-val 'embedded-event-lst wrld1)) (new-embedded-event-lst (cons ee-entry old-embedded-event-lst)) (in-local-flg (f-get-global 'in-local-flg state)) (proto-wrld3 (global-set 'embedded-event-lst new-embedded-event-lst (cond ((eq caller 'encapsulate-pass-2) (intro-udf-lst (cadr ee-entry) (cddr ee-entry) in-local-flg wrld1 state)) (t wrld1)))) (state (set-w 'extension proto-wrld3 state))) (er-progn (cond ((not (find-non-hidden-package-entry pkg kpa)) (er soft 'in-package "The argument to IN-PACKAGE must be a known package name, but ~ ~x0 is not. The known packages are~*1" pkg (tilde-*-&v-strings '& (strip-non-hidden-package-names kpa) #\.))) (t (value nil))) (mv-let (erp val/expansion-alist/final-kpa state) (state-global-let* ((current-package pkg) (cert-data cert-data) (skip-proofs-by-system (let ((user-skip-proofsp (and (ld-skip-proofsp state) (not (f-get-global 'skip-proofs-by-system state))))) (and (not user-skip-proofsp) skip-proofsp))) (ld-skip-proofsp skip-proofsp) (ld-always-skip-top-level-locals nil)) (er-progn (cond ((eq acl2-defaults-table :do-not-install!) (value nil)) ((eq caller 'include-book) (state-global-let* ((inhibit-output-lst (cons 'summary (@ inhibit-output-lst)))) (table-fn 'acl2-defaults-table '(:defun-mode :logic) state '(table acl2-defaults-table :defun-mode :logic)))) ((member-eq caller '(defstobj defabsstobj)) (state-global-let* ((inhibit-output-lst (cons 'summary (@ inhibit-output-lst)))) (er-progn (table-fn 'acl2-defaults-table '(:defun-mode :logic) state '(table acl2-defaults-table :defun-mode :logic)) (table-fn 'acl2-defaults-table '(:ignore-ok t) state '(table acl2-defaults-table :ignore-ok t)) (table-fn 'acl2-defaults-table '(:irrelevant-formals-ok t) state '(table acl2-defaults-table :irrelevant-formals-ok t))))) (t (value nil))) (mv-let (erp val expansion-alist final-kpa state) (pprogn (cond ((or (eq caller 'encapsulate-pass-1) (eq caller 'certify-book)) (pprogn (f-put-global 'redo-flat-succ nil state) (f-put-global 'redo-flat-fail nil state))) (t state)) (eval-event-lst index nil ev-lst (and (ld-skip-proofsp state) (not (eq caller 'certify-book))) (eval-event-lst-environment (in-encapsulatep new-embedded-event-lst nil) state) in-local-flg nil make-event-chk (cond ((eq caller 'certify-book) kpa) (t nil)) caller ctx (proofs-co state) state)) (cond (erp (pprogn (cond ((or (eq caller 'encapsulate-pass-1) (eq caller 'certify-book)) (update-for-redo-flat (- val index) ev-lst state)) (t state)) (mv erp val state))) (t (er-progn (if (member-eq acl2-defaults-table '(:do-not-install :do-not-install!)) (value nil) (maybe-install-acl2-defaults-table acl2-defaults-table state)) (value (list* val expansion-alist final-kpa)))))))) (cond (erp (cond ((member-eq caller '(defstobj defabsstobj)) (value (er hard ctx "An error has occurred while ~x0 was defining the ~ supporting functions. This is supposed to be ~ impossible! Please report this error to the ACL2 ~ implementors." caller))) (t (pprogn (warning$ ctx nil (cond ((or (eq skip-proofsp nil) (eq skip-proofsp t)) "The attempted ~x0 has failed while trying to ~ establish the admissibility of one of the (local or ~ non-local) forms in ~#1~[the body of the ~ ENCAPSULATE~/the book to be certified~].") ((eq caller 'encapsulate-pass-2) "The error reported above is the manifestation of a ~ local incompatibility. See :DOC ~ local-incompatibility. The attempted ~x0 has failed.") (t "The error reported above indicates that this book ~ is incompatible with the current logical world. ~ The attempted ~x0 has failed.")) (if (or (eq caller 'encapsulate-pass-1) (eq caller 'encapsulate-pass-2)) 'encapsulate caller) (if (eq caller 'encapsulate-pass-1) 0 1)) (mv t nil state))))) (t (let ((state (set-w 'extension (global-set 'embedded-event-lst old-embedded-event-lst (w state)) state))) (cond ((eq caller 'encapsulate-pass-2) (value (list* (car val/expansion-alist/final-kpa) (cadr val/expansion-alist/final-kpa) proto-wrld3))) ((eq caller 'certify-book) (value (cdr val/expansion-alist/final-kpa))) (t (value (cadr val/expansion-alist/final-kpa)))))))))))
constrained-functionsfunction
(defun constrained-functions (exported-fns sig-fns new-trips) (cond ((endp exported-fns) sig-fns) (t (let ((ancestors (instantiable-ancestors (list (car exported-fns)) new-trips nil))) (cond ((intersectp-eq sig-fns ancestors) (cons (car exported-fns) (constrained-functions (cdr exported-fns) sig-fns new-trips))) (t (constrained-functions (cdr exported-fns) sig-fns new-trips)))))))
collect-logicalsfunction
(defun collect-logicals (names wrld) (cond ((null names) nil) ((logicp (car names) wrld) (cons (car names) (collect-logicals (cdr names) wrld))) (t (collect-logicals (cdr names) wrld))))
exported-function-namesfunction
(defun exported-function-names (new-trips) (cond ((endp new-trips) nil) (t (let ((new-name (name-introduced (car new-trips) t))) (cond (new-name (cons new-name (exported-function-names (cdr new-trips)))) (t (exported-function-names (cdr new-trips))))))))
get-subversivesfunction
(defun get-subversives (fns wrld) (cond ((endp fns) nil) (t (let ((j (getpropc (car fns) 'justification nil wrld))) (cond ((and j (access justification j :subversive-p)) (cons (car fns) (get-subversives (cdr fns) wrld))) (t (get-subversives (cdr fns) wrld)))))))
ancestral-ffn-symbs-lstfunction
(defun ancestral-ffn-symbs-lst (lst trips ans) (let ((fns (instantiable-ffn-symbs-lst lst trips ans nil))) (instantiable-ancestors fns trips ans)))
remove-guard-holders-weak-constraint-lst-etcfunction
(defun remove-guard-holders-weak-constraint-lst-etc (constraint-lst-etc lamp) (declare (xargs :guard (and (consp constraint-lst-etc) (pseudo-term-listp (car constraint-lst-etc))))) (cons (mv-let (changedp result) (remove-guard-holders1-lst (car constraint-lst-etc) lamp) (declare (ignore changedp)) result) (cdr constraint-lst-etc)))
encapsulate-constraintfunction
(defun encapsulate-constraint (sig-fns exported-names new-trips wrld) (assert$ sig-fns (let* ((fns (constrained-functions (collect-logicals exported-names wrld) sig-fns new-trips)) (subversive-fns (get-subversives exported-names wrld)) (formula-constraint-lst-etc1 (constraint-lst-etc-introduced new-trips fns (constraints-list subversive-fns wrld (cons nil nil) nil))) (constrained-fns (intersection-eq fns (ancestral-ffn-symbs-lst (car formula-constraint-lst-etc1) new-trips (append subversive-fns sig-fns)))) (infectious-fns (set-difference-eq (set-difference-eq constrained-fns subversive-fns) sig-fns)) (constraint-lst-etc (remove-guard-holders-weak-constraint-lst-etc (constraints-list infectious-fns wrld formula-constraint-lst-etc1 nil) (remove-guard-holders-lamp)))) (mv constraint-lst-etc constrained-fns subversive-fns infectious-fns fns))))
bogus-exported-compliantsfunction
(defun bogus-exported-compliants (names exports-with-sig-ancestors sig-fns wrld) (cond ((endp names) nil) ((and (eq (symbol-class (car names) wrld) :common-lisp-compliant) (not (getpropc (car names) 'constrainedp nil wrld)) (or (member-eq (car names) exports-with-sig-ancestors) (intersectp-eq sig-fns (instantiable-ancestors (all-fnnames (guard (car names) nil wrld)) wrld nil)))) (cons (car names) (bogus-exported-compliants (cdr names) exports-with-sig-ancestors sig-fns wrld))) (t (bogus-exported-compliants (cdr names) exports-with-sig-ancestors sig-fns wrld))))
remove-type-prescription-cert-datafunction
(defun remove-type-prescription-cert-data (cert-data) (remove1-assoc-eq :type-prescription cert-data))
encapsulate-return-value-pfunction
(defun encapsulate-return-value-p (val) (case-match val ((:return-value &) t) (& nil)))
transparent-mismatchfunction
(defun transparent-mismatch (transparent infectious-fns wrld) (cond ((endp infectious-fns) nil) ((or (not (getpropc (car infectious-fns) 'constrainedp nil wrld)) (iff transparent (transparent-fn-p (canonical-sibling (car infectious-fns) wrld) wrld))) (transparent-mismatch transparent (cdr infectious-fns) wrld)) (t (cons (car infectious-fns) (transparent-mismatch transparent (cdr infectious-fns) wrld)))))
encapsulate-pass-2function
(defun encapsulate-pass-2 (insigs kwd-value-list-lst ev-lst saved-acl2-defaults-table only-pass-p ctx state) (let* ((wrld1 (w state)) (saved-unknown-constraints-table (table-alist 'unknown-constraints-table wrld1))) (er-let* ((val/expansion-alist/proto-wrld3 (state-global-let* ((in-local-flg (and (f-get-global 'in-local-flg state) 'local-encapsulate))) (process-embedded-events 'encapsulate-pass-2 saved-acl2-defaults-table 'include-book (current-package state) (list* 'encapsulate insigs (or kwd-value-list-lst t)) ev-lst 0 (not only-pass-p) (if (null insigs) (f-get-global 'cert-data state) (remove-type-prescription-cert-data (f-get-global 'cert-data state))) ctx state)))) (let* ((expansion-alist (cadr val/expansion-alist/proto-wrld3)) (proto-wrld3 (cddr val/expansion-alist/proto-wrld3)) (wrld (w state)) (new-trips (new-trips wrld proto-wrld3)) (empty-p (and (null insigs) (not (assoc-eq 'event-landmark new-trips)))) (fast-cert-extension (and empty-p (eq (fast-cert-mode state) t) (f-get-global 'certify-book-info state) (assoc-eq 'top-level-cltl-command-stack new-trips))) (retval (if fast-cert-extension :trivial-extension-for-fast-cert (car val/expansion-alist/proto-wrld3)))) (cond ((and empty-p (not fast-cert-extension)) (let ((state (set-w 'retraction wrld1 state))) (value (cons :empty-encapsulate expansion-alist)))) (t (pprogn (cond (fast-cert-extension (observation ctx "This encapsulate event does not introduce any new ~ events, but it has encountered at least one ~ non-local definition that was redundant with an ~ existing local definition.")) (t state)) (let* ((exported-names (exported-function-names new-trips)) (unknown-constraints-table (table-alist 'unknown-constraints-table (w state))) (unknown-constraints-p (and insigs (not (equal unknown-constraints-table saved-unknown-constraints-table)))) (transparent (cadr (assoc-keyword :transparent (car kwd-value-list-lst))))) (cond ((and unknown-constraints-p exported-names) (er soft ctx "A partial-encapsulate must introduce only the functions ~ listed in its signature. However, the signature's list ~ of names, ~x0, is missing the function name~#1~[~/s~] ~ ~&1, also introduced by that encapsulate. See :DOC ~ partial-encapsulate." (strip-cars insigs) exported-names)) ((and unknown-constraints-p transparent) (er soft ctx "A partial-encapsulate must not specify :transparent t in ~ its signature. However, the signature with list of names ~ ~x0 does just that. See :DOC transparent-functions." (strip-cars insigs))) ((null insigs) (value (if only-pass-p (cons expansion-alist retval) (list nil retval nil exported-names)))) (t (let* ((new-trips (new-trips wrld wrld1)) (sig-fns (strip-cars insigs))) (mv-let (constraint-lst-etc constrained-fns subversive-fns infectious-fns exports-with-sig-ancestors) (encapsulate-constraint sig-fns exported-names new-trips wrld) (let ((transparent-mismatch (transparent-mismatch transparent infectious-fns wrld))) (cond (transparent-mismatch (if transparent (er soft ctx "The signature~#0~[~/s~] of the proposed ~ encapsulate event ~#0~[specifies~/specify~] ~ :transparent t (for ~&0). But function ~ symbol~#1~[~/s~] ~&1 ~#1~[is~/are~] not ~ marked as transparent in ~#1~[its subsidiary ~ encapsulate signature~/their subsidiary ~ encapsulate signatures~]. This is illegal; ~ see :DOC transparent-functions." sig-fns transparent-mismatch) (er soft ctx "The signature~#0~[~/s~] of the proposed ~ encapsulate event ~#0~[does~/do~] not specify ~ :transparent t (for ~&0). But function ~ symbol~#1~[~/s~] ~&1 ~#1~[is~/are~] marked with ~ :transparent t in ~#1~[its subsidiary ~ encapsulate signature~/their subsidiary ~ encapsulate signatures~]. This is illegal; see ~ :DOC transparent-functions." sig-fns transparent-mismatch))) (t (let* ((wrld2 (putprop-constraints (car sig-fns) (remove1-eq (car sig-fns) constrained-fns) (if unknown-constraints-p (cons (cons *unknown-constraints* (all-fnnames1 t (car constraint-lst-etc) (cdr (assoc-eq :supporters unknown-constraints-table)))) nil) constraint-lst-etc) unknown-constraints-p (if constrained-fns (assert$ (subsetp-eq subversive-fns constrained-fns) (assert$ (subsetp-eq infectious-fns constrained-fns) (putprop-x-lst1 constrained-fns 'siblings (if (and transparent (not (member-eq (car constrained-fns) sig-fns))) (cons (car sig-fns) (remove1 (car sig-fns) constrained-fns)) constrained-fns) (if transparent (putprop (car sig-fns) 'constrainedp (make transparent-rec :names nil) wrld) wrld)))) wrld))) (state (set-w 'extension wrld2 state)) (bogus-exported-compliants (bogus-exported-compliants exported-names exports-with-sig-ancestors sig-fns wrld2))) (cond (bogus-exported-compliants (er soft ctx "For the following function~#0~[~/s~] ~ introduced by this encapsulate event, guard ~ verification may depend on local properties ~ that are not exported from the encapsulate ~ event: ~&0. Consider delaying guard ~ verification until after the encapsulate ~ event, for example by using :verify-guards ~ nil." bogus-exported-compliants)) (t (value (if only-pass-p (cons expansion-alist retval) (list constrained-fns retval (if unknown-constraints-p *unknown-constraints* (car constraint-lst-etc)) exported-names subversive-fns infectious-fns)))))))))))))))))))))
tilde-@-abbreviate-object-phrasefunction
(defun tilde-@-abbreviate-object-phrase (x) (cond ((atom x) (msg "~x0" x)) ((symbol-listp x) (cond ((< (length x) 3) (msg "~x0" x)) (t (msg "(~x0 ... ~x1)" (car x) (car (last x)))))) ((atom (car x)) (cond ((and (consp (cdr x)) (atom (cadr x))) (msg "(~x0 ~x1 ...)" (car x) (cadr x))) (t (msg "(~x0 ...)" (car x))))) ((atom (caar x)) (cond ((and (consp (cdar x)) (atom (cadar x))) (msg "((~x0 ~x1 ...) ...)" (caar x) (cadar x))) (t (msg "((~x0 ...) ...)" (caar x))))) (t "(((...) ...) ...)")))
encapsulate-ctxfunction
(defun encapsulate-ctx (signatures form-lst) (cond (signatures (cond ((and (consp signatures) (consp (car signatures)) (consp (caar signatures))) (msg "( ENCAPSULATE (~@0 ...) ...)" (tilde-@-abbreviate-object-phrase (car signatures)))) (t (msg "( ENCAPSULATE ~@0 ...)" (tilde-@-abbreviate-object-phrase signatures))))) (form-lst (msg "( ENCAPSULATE NIL ~@0 ...)" (tilde-@-abbreviate-object-phrase (car form-lst)))) (t "( ENCAPSULATE NIL)")))
print-encapsulate-msg1function
(defun print-encapsulate-msg1 (insigs form-lst state) (declare (ignore insigs)) (cond ((ld-skip-proofsp state) state) (t (io? event nil state (form-lst) (fms "To verify that the ~#0~[~/~n1 ~]encapsulated event~#0~[~/s~] ~ correctly extend~#0~[s~/~] the current theory we will evaluate ~ ~#0~[it~/them~]. The theory thus constructed is only ~ ephemeral.~|~#2~[~%Encapsulated Event~#0~[~/s~]:~%~/~]" (list (cons #\0 form-lst) (cons #\1 (length form-lst)) (cons #\2 (if (eq (ld-pre-eval-print state) :never) 1 0))) (proofs-co state) state nil)))))
print-encapsulate-msg2function
(defun print-encapsulate-msg2 (insigs form-lst state) (declare (ignore insigs)) (cond ((ld-skip-proofsp state) state) (t (io? event nil state (form-lst) (fms "End of Encapsulated Event~#0~[~/s~].~%" (list (cons #\0 form-lst)) (proofs-co state) state nil)))))
print-encapsulate-msg3/exported-namesfunction
(defun print-encapsulate-msg3/exported-names (insigs lst) (cond ((null lst) nil) (insigs (list (msg "In addition to ~&0, we export ~&1.~|~%" (strip-cars insigs) lst))) (t (list (msg "We export ~&0.~|~%" lst)))))
print-encapsulate-msg3/constraintsfunction
(defun print-encapsulate-msg3/constraints (constrained-fns constraints wrld) (cond ((null constraints) nil) ((null constrained-fns) (er hard 'print-encapsulate-msg3/constraints "We had thought that the only way that there can be constraints is if ~ there are constrained functions. See ~ print-encapsulate-msg3/constraints.")) ((eq constraints *unknown-constraints*) (list (msg "Unknown-constraints are associated with ~#0~[the function~/both of ~ the functions~/every one of the functions~] ~&1. See :DOC ~ partial-encapsulate.~|~%" (let ((n (length constrained-fns))) (case n (1 0) (2 1) (otherwise 2))) constrained-fns))) (t (list (msg "The following constraint is associated with ~#0~[the ~ function~/both of the functions~/every one of the functions~] ~ ~&1:~|~%~p2~|" (let ((n (length constrained-fns))) (case n (1 0) (2 1) (otherwise 2))) constrained-fns (untranslate (conjoin constraints) t wrld))))))
print-encapsulate-msg3function
(defun print-encapsulate-msg3 (ctx insigs form-lst exported-names constrained-fns constraints-introduced subversive-fns infectious-fns wrld state) (cond ((ld-skip-proofsp state) state) (t (io? event nil state (infectious-fns ctx subversive-fns wrld constraints-introduced constrained-fns exported-names insigs form-lst) (pprogn (fms "Having verified that the encapsulated event~#0~[ ~ validates~/s validate~] the signatures of the ~ ENCAPSULATE event, we discard the ephemeral theory ~ and extend the original theory as directed by the ~ signatures and the non-LOCAL events.~|~%~*1" (list (cons #\0 form-lst) (cons #\1 (list "" "~@*" "~@*" "~@*" (append (print-encapsulate-msg3/exported-names insigs exported-names) (print-encapsulate-msg3/constraints constrained-fns constraints-introduced wrld))))) (proofs-co state) state (term-evisc-tuple nil state)) (print-defun-msg/signatures (strip-cars insigs) wrld state) (if subversive-fns (warning$ ctx "Infected" "Note that ~&0 ~#0~[is~/are~] ``subversive.'' See ~ :DOC subversive-recursions. Thus, ~#0~[its ~ definitional equation infects~/their definitional ~ equations infect~] the constraint of this ~ en~-cap~-su~-la~-tion. Furthermore, ~#0~[this ~ function~/these functions~] will not suggest any ~ induction schemes or type-prescription rules to the ~ theorem prover. If possible, you should remove ~ ~#0~[this definition~/these definitions~] from the ~ encapsulate and introduce ~#0~[it~/them~] ~ afterwards. A constraint containing a definitional ~ equation is often hard to use in subsequent ~ functional instantiations." subversive-fns) state) (if infectious-fns (warning$ ctx "Infected" "Note that the defining event~#0~[~/s~] for ~&0 ~ infect~#0~[s~/~] the constraint of this ~ en~-cap~-su~-la~-tion. That can be caused because a ~ function ancestrally involves the constrained ~ functions of an encapsulate and is ancestrally ~ involved in the constraining theorems of those ~ functions. In any case, if at all possible, you ~ should move ~#0~[this defining event~/these defining ~ events~] out of the encapsulation. A constraint ~ containing the formula of such an event is often ~ hard to use in subsequent functional instantiations. ~ ~ See :DOC infected-constraints and perhaps :DOC ~ subversive-recursions for discussion of related ~ issues." infectious-fns) state))))))
find-first-non-local-namemutual-recursion
(mutual-recursion (defun find-first-non-local-name (x wrld primitives state-vars) (let ((val (case-match x (('local . &) nil) (('defun name . &) name) (('defaxiom name . &) name) (('defchoose name . &) name) (('defconst name . &) name) (('deflabel name . &) name) (('defmacro name . &) name) (('deftheory name . &) name) (('defuns (name . &) . &) name) (('defstobj name . &) name) (('defabsstobj name . &) name) (('defthm name . &) name) (('encapsulate (((name . &) arrow . &) . &) . &) (and (symbolp arrow) (equal (symbol-name arrow) "=>") name)) (('encapsulate ((name . &) . &) . &) name) (('encapsulate nil . ev-lst) (find-first-non-local-name-lst ev-lst wrld primitives state-vars nil)) (('mutual-recursion ('defun name . &) . &) name) (('make-event ('verify-termination-fn ('quote names) 'state)) (and names (car names))) (('make-event . &) :make-event) (('progn . ev-lst) (find-first-non-local-name-lst ev-lst wrld primitives state-vars nil)) (('verify-guards name . &) name) ((sym . lst) (cond ((not (symbolp sym)) nil) ((member-eq sym '(skip-proofs with-cbd with-current-package with-guard-checking-event with-output with-prover-step-limit with-prover-time-limit)) (find-first-non-local-name (car (last lst)) wrld primitives state-vars)) ((member-eq sym primitives) nil) ((getpropc (car x) 'macro-body nil wrld) (mv-let (erp expansion) (macroexpand1-cmp x 'find-first-non-local-name wrld state-vars) (and (not erp) (find-first-non-local-name expansion wrld primitives state-vars)))) (t nil))) (& nil)))) (and (symbolp val) val))) (defun find-first-non-local-name-lst (lst wrld primitives state-vars ans) (cond ((atom lst) ans) (t (let ((ans2 (find-first-non-local-name (car lst) wrld primitives state-vars))) (cond ((eq ans2 :make-event) (find-first-non-local-name-lst (cdr lst) wrld primitives state-vars :make-event)) (ans2) (t (find-first-non-local-name-lst (cdr lst) wrld primitives state-vars ans))))))))
equal-mod-elide-locals1function
(defun equal-mod-elide-locals1 (form) (cond ((atom form) form) ((eq (car form) 'local) *local-value-triple-elided*) ((member-eq (car form) '(skip-proofs with-cbd with-current-package with-guard-checking-event with-output with-prover-time-limit with-prover-step-limit record-expansion time$)) (equal-mod-elide-locals1 (car (last form)))) (t form)))
equal-mod-elide-localsmutual-recursion
(mutual-recursion (defun equal-mod-elide-locals (ev1 ev2) (let ((ev1 (equal-mod-elide-locals1 ev1)) (ev2 (equal-mod-elide-locals1 ev2))) (cond ((equal ev1 ev2) t) ((not (eq (car ev1) (car ev2))) nil) ((eq (car ev1) 'progn) (equal-mod-elide-locals-lst (cdr ev1) (cdr ev2))) ((eq (car ev1) 'progn!) (let ((bindings-p1 (and (consp (cdr ev1)) (eq (cadr ev1) :state-global-bindings))) (bindings-p2 (and (consp (cdr ev2)) (eq (cadr ev2) :state-global-bindings)))) (and (eq bindings-p1 bindings-p2) (cond (bindings-p1 (equal-mod-elide-locals-lst (cdddr ev1) (cdddr ev2))) (t (equal-mod-elide-locals-lst (cdr ev1) (cdr ev2))))))) ((eq (car ev1) 'encapsulate) (and (equal (cadr ev1) (cadr ev2)) (equal-mod-elide-locals-lst (cddr ev1) (cddr ev2)))) (t nil)))) (defun equal-mod-elide-locals-lst (lst1 lst2) (cond ((endp lst1) (null lst2)) (t (and (equal-mod-elide-locals (car lst1) (car lst2)) (equal-mod-elide-locals-lst (cdr lst1) (cdr lst2)))))))
corresponding-encap-eventsfunction
(defun corresponding-encap-events (old-evs new-evs r-e-p ans) (cond ((endp old-evs) (and (null new-evs) ans)) ((endp new-evs) nil) (t (let ((old-ev (car old-evs)) (new-ev (car new-evs))) (cond ((equal old-ev new-ev) (corresponding-encap-events (cdr old-evs) (cdr new-evs) r-e-p ans)) ((and r-e-p (eq (car old-ev) 'record-expansion) (equal (cadr old-ev) new-ev)) (corresponding-encap-events (cdr old-evs) (cdr new-evs) r-e-p :expanded)) ((equal-mod-elide-locals old-ev new-ev) (corresponding-encap-events (cdr old-evs) (cdr new-evs) r-e-p :expanded)) (t nil))))))
corresponding-encapsfunction
(defun corresponding-encaps (old new r-e-p) (assert$ (eq (car new) 'encapsulate) (and (eq (car old) 'encapsulate) (true-listp new) (equal (cadr old) (cadr new)) (corresponding-encap-events (cddr old) (cddr new) r-e-p t))))
redundant-encapsulatep-resultfunction
(defun redundant-encapsulatep-result (x old-ev-wrld wrld state) (cond ((store-cltl-command-for-redundant-def state) (let ((event-tuple (cddr (car old-ev-wrld)))) (cond ((access-event-tuple-local-p event-tuple) (list* :update-top-level-cltl-command-stack x (new-top-level-cltl-command-stack (access-event-tuple-depth event-tuple) (global-val 'top-level-cltl-command-stack wrld) (cdr old-ev-wrld)))) (t x)))) (t x)))
redundant-encapsulate-tuplepfunction
(defun redundant-encapsulate-tuplep (event-form mode ruler-extenders vge event-number wrld wrld0 state r-e-p) (cond ((or (null wrld) (and (eq (caar wrld) 'command-landmark) (eq (cadar wrld) 'global-value) (equal (access-command-tuple-form (cddar wrld)) '(exit-boot-strap-mode))) (and (integerp event-number) (eq (cadar wrld) 'absolute-event-number) (integerp (cddar wrld)) (<= (cddar wrld) event-number))) nil) ((and (eq (caar wrld) 'event-landmark) (eq (cadar wrld) 'global-value) (let* ((old-event-form (access-event-tuple-form (cddar wrld))) (equal? (and (eq (car old-event-form) 'encapsulate) (corresponding-encaps old-event-form event-form r-e-p)))) (and equal? (let ((adt (table-alist 'acl2-defaults-table wrld))) (and (eq (default-defun-mode-from-table adt) mode) (equal (default-ruler-extenders-from-table adt) ruler-extenders) (eql (default-verify-guards-eagerness-from-table adt) vge) (redundant-encapsulatep-result (if (eq equal? :expanded) old-event-form t) wrld wrld0 state))))))) (t (redundant-encapsulate-tuplep event-form mode ruler-extenders vge event-number (cdr wrld) wrld0 state r-e-p))))
redundant-encapsulatepfunction
(defun redundant-encapsulatep (signatures ev-lst event-form wrld state) (cond (signatures (let ((name (case-match signatures ((((name . &) arrow . &) . &) (and (symbolp arrow) (equal (symbol-name arrow) "=>") name)) (((name . &) . &) name)))) (and name (symbolp name) (not (new-namep name wrld)) (let* ((wrld-tail (lookup-world-index 'event (getpropc name 'absolute-event-number 0 wrld) wrld)) (event-tuple (cddr (car wrld-tail))) (old-event-form (access-event-tuple-form event-tuple)) (equal? (corresponding-encaps old-event-form event-form (null (global-val 'include-book-path wrld))))) (and equal? (let ((old-adt (table-alist 'acl2-defaults-table wrld-tail)) (new-adt (table-alist 'acl2-defaults-table wrld))) (and (eq (default-defun-mode-from-table old-adt) (default-defun-mode-from-table new-adt)) (equal (default-ruler-extenders-from-table old-adt) (default-ruler-extenders-from-table new-adt)) (eql (default-verify-guards-eagerness-from-table old-adt) (default-verify-guards-eagerness-from-table new-adt)) (redundant-encapsulatep-result (if (eq equal? :expanded) old-event-form t) wrld-tail wrld state)))))))) (t (let* ((name0 (find-first-non-local-name-lst ev-lst wrld (primitive-event-macros) (default-state-vars nil) nil)) (name (and (not (eq name0 :make-event)) name0))) (and name0 (or (not name) (not (new-namep name wrld))) (let ((new-adt (table-alist 'acl2-defaults-table wrld))) (redundant-encapsulate-tuplep event-form (default-defun-mode-from-table new-adt) (default-ruler-extenders-from-table new-adt) (default-verify-guards-eagerness-from-table new-adt) (and name (getpropc name 'absolute-event-number nil wrld)) wrld wrld state (null (global-val 'include-book-path wrld)))))))))
known-package-alist-included-pfunction
(defun known-package-alist-included-p (a1 a2) (cond ((endp a1) t) (t (and (let ((a2-entry (find-package-entry (package-entry-name (car a1)) a2))) (and a2-entry (or (package-entry-hidden-p (car a1)) (not (package-entry-hidden-p a2-entry))))) (known-package-alist-included-p (cdr a1) a2)))))
encapsulate-fix-known-package-alistfunction
(defun encapsulate-fix-known-package-alist (pass1-k-p-alist pass2-k-p-alist wrld) (assert$ (known-package-alist-included-p pass2-k-p-alist pass1-k-p-alist) (global-set 'known-package-alist (mark-missing-as-hidden-p pass1-k-p-alist pass2-k-p-alist) wrld)))
subst-by-position1function
(defun subst-by-position1 (alist lst index acc) (cond ((endp alist) (revappend acc lst)) ((endp lst) (er hard 'subst-by-position1 "Implementation error: lst is an atom, so unable to complete ~ call ~x0." `(subst-by-position1 ,ALIST ,LST ,INDEX ,ACC))) ((eql index (caar alist)) (subst-by-position1 (cdr alist) (cdr lst) (1+ index) (cons (cdar alist) acc))) (t (subst-by-position1 alist (cdr lst) (1+ index) (cons (car lst) acc)))))
subst-by-positionfunction
(defun subst-by-position (alist lst index) (cond (alist (cond ((< (caar alist) index) (er hard 'subst-by-position "Implementation error: The alist in subst-by-position ~ must not start with an index less than its index ~ argument, so unable to compute ~x0." `(subst-by-position ,ALIST ,LST ,INDEX))) (t (subst-by-position1 alist lst index nil)))) (t lst)))
dfp-termsfunction
(defun dfp-terms (stobjs-in formals) (declare (xargs :guard (and (symbol-listp formals) (symbol-listp stobjs-in) (eql (length formals) (length stobjs-in))))) (map-predicate 'dfp (collect-by-position '(:df) stobjs-in formals)))
intro-udf-guardsfunction
(defun intro-udf-guards (insigs kwd-value-list-lst wrld-acc wrld ctx state) (cond ((endp insigs) (value wrld-acc)) (t (er-let* ((tguard (let ((tail (assoc-keyword :guard (car kwd-value-list-lst)))) (cond (tail (translate (cadr tail) t t nil ctx wrld state)) (t (value nil)))))) (let* ((insig (car insigs)) (fn (car insig)) (formals (cadr insig)) (stobjs-in (caddr insig)) (stobjs (collect-non-nil-df stobjs-in)) (stobj-terms (stobj-recognizer-terms stobjs wrld)) (dfp-terms (dfp-terms stobjs-in formals))) (er-progn (cond (tguard (chk-free-vars fn formals tguard "guard for" ctx state)) (t (value nil))) (intro-udf-guards (cdr insigs) (cdr kwd-value-list-lst) (putprop-unless fn 'guard (cond (tguard (conjoin (append stobj-terms dfp-terms (list tguard)))) (t (conjoin (append stobj-terms dfp-terms)))) *t* wrld-acc) wrld ctx state)))))))
intro-udf-global-stobjsfunction
(defun intro-udf-global-stobjs (insigs kwd-value-list-lst wrld-acc) (cond ((endp insigs) wrld-acc) (t (intro-udf-global-stobjs (cdr insigs) (cdr kwd-value-list-lst) (putprop-unless (caar insigs) 'global-stobjs (cadr (assoc-keyword :global-stobjs (car kwd-value-list-lst))) nil wrld-acc)))))
intro-udf-non-classicalpfunction
(defun intro-udf-non-classicalp (insigs kwd-value-list-lst wrld) (cond ((endp insigs) wrld) (t (let* ((insig (car insigs)) (fn (car insig)) (kwd-value-list (car kwd-value-list-lst)) (tail (assoc-keyword :classicalp kwd-value-list)) (val (if tail (cadr tail) t))) (intro-udf-non-classicalp (cdr insigs) (cdr kwd-value-list-lst) (putprop-unless fn 'classicalp val t wrld))))))
assoc-proof-supporters-alistfunction
(defun assoc-proof-supporters-alist (sym alist) (cond ((endp alist) nil) ((if (consp (caar alist)) (member-eq sym (caar alist)) (eq sym (caar alist))) (car alist)) (t (assoc-proof-supporters-alist sym (cdr alist)))))
update-proof-supporters-alist-3function
(defun update-proof-supporters-alist-3 (names local-alist old new wrld) (cond ((endp names) (mv (reverse old) new)) ((getpropc (car names) 'absolute-event-number nil wrld) (update-proof-supporters-alist-3 (cdr names) local-alist (cons (car names) old) new wrld)) (t (let ((car-names-supporters (cdr (assoc-proof-supporters-alist (car names) local-alist)))) (update-proof-supporters-alist-3 (cdr names) local-alist old (strict-merge-symbol< car-names-supporters new nil) wrld)))))
posn-first-non-eventfunction
(defun posn-first-non-event (names wrld idx) (cond ((endp names) nil) ((getpropc (car names) 'absolute-event-number nil wrld) (posn-first-non-event (cdr names) wrld (1+ idx))) (t idx)))
update-proof-supporters-alist-2function
(defun update-proof-supporters-alist-2 (names local-alist wrld) (let ((n (posn-first-non-event names wrld 0))) (cond ((null n) names) (t (mv-let (rest-old-event-names rest-new-names) (update-proof-supporters-alist-3 (nthcdr n names) local-alist nil nil wrld) (strict-merge-symbol< (append (take n names) rest-old-event-names) rest-new-names nil))))))
update-proof-supporters-alist-1function
(defun update-proof-supporters-alist-1 (namex names local-alist proof-supporters-alist wrld) (assert$ names (let ((non-local-names (update-proof-supporters-alist-2 names local-alist wrld))) (cond ((getpropc (if (symbolp namex) namex (car namex)) 'absolute-event-number nil wrld) (mv local-alist (if non-local-names (acons namex non-local-names proof-supporters-alist) proof-supporters-alist))) (t (mv (acons namex non-local-names local-alist) proof-supporters-alist))))))
update-proof-supporters-alistfunction
(defun update-proof-supporters-alist (new-proof-supporters-alist proof-supporters-alist wrld) (cond ((endp new-proof-supporters-alist) (mv nil proof-supporters-alist)) (t (mv-let (local-alist proof-supporters-alist) (update-proof-supporters-alist (cdr new-proof-supporters-alist) proof-supporters-alist wrld) (update-proof-supporters-alist-1 (caar new-proof-supporters-alist) (cdar new-proof-supporters-alist) local-alist proof-supporters-alist wrld)))))
install-proof-supporters-alistfunction
(defun install-proof-supporters-alist (new-proof-supporters-alist installed-wrld wrld) (let ((saved-proof-supporters-alist (global-val 'proof-supporters-alist installed-wrld))) (mv-let (local-alist proof-supporters-alist) (update-proof-supporters-alist new-proof-supporters-alist saved-proof-supporters-alist installed-wrld) (declare (ignore local-alist)) (global-set 'proof-supporters-alist proof-supporters-alist wrld))))
empty-encapsulatefunction
(defun empty-encapsulate (ctx state) (pprogn (observation ctx "The submitted encapsulate event has created no new ~ ACL2 events, and thus is leaving the ACL2 logical ~ world unchanged. See :DOC encapsulate.") (value :empty-encapsulate)))
cert-data-tp-from-runic-type-prescriptionfunction
(defun cert-data-tp-from-runic-type-prescription (fn wrld) (let ((lst (getpropc fn 'type-prescriptions nil wrld))) (and lst (let* ((tp (car (last lst))) (rune (access type-prescription tp :rune))) (and (eq (base-symbol rune) fn) (assert$ (null (cddr rune)) (assert$ (equal (access type-prescription tp :term) (fcons-term fn (formals fn wrld))) (assert$ (null (access type-prescription tp :hyps)) (assert$ (null (access type-prescription tp :backchain-limit-lst)) tp)))))))))
cert-data-tps-from-fnsfunction
(defun cert-data-tps-from-fns (fns wrld acc) (cond ((endp fns) acc) (t (cert-data-tps-from-fns (cdr fns) wrld (let ((fn (car fns))) (if (or (programp fn wrld) (hons-get fn acc)) acc (let ((tp (cert-data-tp-from-runic-type-prescription fn wrld))) (if tp (hons-acons fn tp acc) acc))))))))
cert-data-for-certificatefunction
(defun cert-data-for-certificate (fns translate-cert-data wrld) (acons :type-prescription (cert-data-tps-from-fns fns wrld nil) (acons :translate (and (not (global-val 'redef-seen wrld)) (make-fast-alist translate-cert-data)) nil)))
top-level-user-fns-recfunction
(defun top-level-user-fns-rec (cltl-command-lst acc) (cond ((endp cltl-command-lst) acc) (t (top-level-user-fns-rec (cdr cltl-command-lst) (if (eq (caar cltl-command-lst) 'defuns) (reverse-strip-cars (cdddr (car cltl-command-lst)) acc) acc)))))
top-level-user-fnsfunction
(defun top-level-user-fns (cltl-command-lst acc) (cond ((endp cltl-command-lst) (reverse acc)) (t (top-level-user-fns (cdr cltl-command-lst) (if (eq (caar cltl-command-lst) 'defuns) (reverse-strip-cars (cdddr (car cltl-command-lst)) acc) acc)))))
cert-data-tps-1function
(defun cert-data-tps-1 (defs wrld acc) (cond ((endp defs) acc) (t (let ((fn (caar defs))) (cert-data-tps-1 (cdr defs) wrld (cond ((or (programp fn wrld) (hons-get fn acc)) acc) (t (hons-acons fn (cert-data-tp-from-runic-type-prescription fn wrld) acc))))))))
cert-data-tpsfunction
(defun cert-data-tps (old-wrld new-wrld installed-wrld acc) (cond ((equal old-wrld new-wrld) acc) (t (cert-data-tps old-wrld (cdr new-wrld) installed-wrld (cond ((and (eq (caar new-wrld) 'cltl-command) (eq (cadar new-wrld) 'global-value) (eq (car (cddr (car new-wrld))) 'defuns) (not (eq (cadr (cddr (car new-wrld))) :program))) (cert-data-tps-1 (cdddr (cddr (car new-wrld))) installed-wrld acc)) (t acc))))))
cert-data-pass1-savedfunction
(defun cert-data-pass1-saved (old-wrld new-wrld) (acons :type-prescription (cert-data-tps old-wrld new-wrld new-wrld nil) (acons :pass1-saved t nil)))
functional-substitution-pfunction
(defun functional-substitution-p (alist wrld) (cond ((endp alist) t) (t (let ((fn1 (caar alist)) (fn2 (cdar alist))) (and (function-symbolp fn1 wrld) (if (symbolp fn2) (and (function-symbolp fn2 wrld) (logicp fn2 wrld)) (case-match fn2 (('lambda & x) (logic-termp x wrld)) (& (er hard 'functional-substitution-p "Unexpected entry in alleged functional ~ substitution:~x0" (car alist))))) (functional-substitution-p (cdr alist) wrld))))))
new-proved-functional-instances-alistfunction
(defun new-proved-functional-instances-alist (old new wrld acc) (cond ((equal old new) (revappend acc old)) (t (new-proved-functional-instances-alist old (cdr new) wrld (let* ((rec (car new)) (name (access proved-functional-instances-alist-entry rec :constraint-event-name)) (restricted-alist (access proved-functional-instances-alist-entry rec :restricted-alist)) (behalf-of-event-name (access proved-functional-instances-alist-entry rec :behalf-of-event-name))) (cond ((and (logicp name wrld) (functional-substitution-p restricted-alist wrld)) (cond ((and (symbolp behalf-of-event-name) (formula behalf-of-event-name nil wrld)) (cons rec acc)) (t (cons (change proved-functional-instances-alist-entry rec :behalf-of-event-name 0) acc)))) (t acc)))))))
fast-alist-free-cert-data-on-exitmacro
(defmacro fast-alist-free-cert-data-on-exit (cert-data form) `(let* ((cert-data-to-free ,CERT-DATA) (cert-data-entry-tp-to-free (cdr (assoc-eq :type-prescription cert-data-to-free)))) (fast-alist-free-on-exit cert-data-entry-tp-to-free (let ((cert-data-entry-tr-to-free (cdr (assoc-eq :translate cert-data-to-free)))) (fast-alist-free-on-exit cert-data-entry-tr-to-free (check-vars-not-free (cert-data-to-free cert-data-entry-tp-to-free cert-data-entry-tr-to-free) ,FORM))))))
with-hcomp-bindings-encapsulatemacro
(defmacro with-hcomp-bindings-encapsulate (bindp form) (declare (ignorable bindp) (xargs :guard (symbolp bindp))) form)
switch-hcomp-status-encapsulatemacro
(defmacro switch-hcomp-status-encapsulate (condition form) (declare (ignorable condition)) form)
encapsulate-fnfunction
(defun encapsulate-fn (signatures ev-lst state event-form) (let ((ctx (encapsulate-ctx signatures ev-lst))) (with-ctx-summarized ctx (let* ((wrld1 (w state)) (saved-proved-functional-instances-alist (global-val 'proved-functional-instances-alist wrld1)) (saved-acl2-defaults-table (table-alist 'acl2-defaults-table wrld1)) (event-form (or event-form (list* 'encapsulate signatures ev-lst))) (in-local-flg (f-get-global 'in-local-flg state))) (revert-world-on-error (let ((r (redundant-encapsulatep signatures ev-lst event-form wrld1 state))) (cond (r (mv-let (r new-top-level-cltl-command-stack) (if (and (consp r) (eq (car r) :update-top-level-cltl-command-stack)) (mv (cadr r) (cddr r)) (mv r nil)) (pprogn (if (eq r t) state (f-put-global 'last-make-event-expansion r state)) (er-progn (if new-top-level-cltl-command-stack (let ((state (set-w 'extension (global-set? 'top-level-cltl-command-stack new-top-level-cltl-command-stack wrld1 (global-val 'top-level-cltl-command-stack wrld1)) state))) (maybe-add-event-landmark state)) (value nil)) (stop-redundant-event ctx state :extra-msg (and (not (eq r t)) "(This event is redundant with a previous encapsulate ~ event even though the two might not be equal; see :DOC ~ redundant-encapsulate.)")))))) ((and (not (eq (ld-skip-proofsp state) 'include-book)) (not (eq (ld-skip-proofsp state) 'include-book-with-locals)) (not (eq (ld-skip-proofsp state) 'initialize-acl2))) (er-let* ((trip (chk-acceptable-encapsulate1 signatures ev-lst ctx wrld1 state))) (let* ((insigs (car trip)) (names (strip-cars insigs)) (kwd-value-list-lst (cadr trip)) (wrld1 (cddr trip)) (do-hcomp-build-p (and (null signatures) (not (in-encapsulatep (global-val 'embedded-event-lst (w state)) t)) (null (ld-redefinition-action state))))) (declare (ignorable do-hcomp-build-p)) (with-hcomp-bindings-encapsulate do-hcomp-build-p (pprogn (set-w 'extension (global-set 'proof-supporters-alist nil wrld1) state) (print-encapsulate-msg1 insigs ev-lst state) (er-let* ((expansion-alist (state-global-let* ((in-local-flg (and in-local-flg 'local-encapsulate))) (process-embedded-events 'encapsulate-pass-1 saved-acl2-defaults-table (ld-skip-proofsp state) (current-package state) (list 'encapsulate insigs) ev-lst 0 nil nil ctx state)))) (let* ((wrld2 (w state)) (post-pass-1-skip-proofs-seen (global-val 'skip-proofs-seen wrld2)) (post-pass-1-include-book-alist-all (global-val 'include-book-alist-all wrld2)) (post-pass-1-pcert-books (global-val 'pcert-books wrld2)) (post-pass-1-ttags-seen (global-val 'ttags-seen wrld2)) (post-pass-1-proof-supporters-alist (global-val 'proof-supporters-alist wrld2)) (post-pass-1-cert-replay (global-val 'cert-replay wrld2)) (post-pass-1-proved-functional-instances-alist (global-val 'proved-functional-instances-alist wrld2)) (cert-data (and (null insigs) (cert-data-pass1-saved wrld1 wrld2)))) (fast-alist-free-cert-data-on-exit cert-data (state-global-let* ((cert-data cert-data)) (pprogn (print-encapsulate-msg2 insigs ev-lst state) (er-progn (chk-acceptable-encapsulate2 insigs kwd-value-list-lst wrld2 ctx state) (let* ((pass1-kpa (global-val 'known-package-alist wrld2)) (new-ev-lst (subst-by-position expansion-alist ev-lst 0)) (state (set-w 'retraction wrld1 state)) (new-event-form (and expansion-alist (list* 'encapsulate signatures new-ev-lst)))) (er-let* ((temp (switch-hcomp-status-encapsulate do-hcomp-build-p (encapsulate-pass-2 insigs kwd-value-list-lst new-ev-lst saved-acl2-defaults-table nil ctx state)))) (pprogn (f-put-global 'last-make-event-expansion new-event-form state) (cond ((eq (car temp) :empty-encapsulate) (empty-encapsulate ctx state)) (t (let* ((wrld3 (w state)) (constrained-fns (nth 0 temp)) (retval (nth 1 temp)) (constraints-introduced (nth 2 temp)) (exports (nth 3 temp)) (subversive-fns (nth 4 temp)) (infectious-fns (nth 5 temp)) (final-proved-fnl-inst-alist (and (null constrained-fns) (new-proved-functional-instances-alist saved-proved-functional-instances-alist post-pass-1-proved-functional-instances-alist wrld3 nil))) (pass2-kpa (global-val 'known-package-alist wrld3)) (eq-pass12-kpa (equal pass1-kpa pass2-kpa))) (pprogn (if (eq retval :trivial-extension-for-fast-cert) (assert$ (and (null insigs) (null exports) (null constrained-fns) (null constraints-introduced) (null subversive-fns) (null infectious-fns)) state) (print-encapsulate-msg3 ctx insigs new-ev-lst exports constrained-fns constraints-introduced subversive-fns infectious-fns wrld3 state)) (er-let* ((wrld3a (intro-udf-guards insigs kwd-value-list-lst (intro-udf-global-stobjs insigs kwd-value-list-lst wrld3) wrld3 ctx state))) (install-event (cond ((encapsulate-return-value-p retval) (cadr retval)) ((null names) t) ((null (cdr names)) (car names)) (t names)) (or new-event-form event-form) 'encapsulate (or names 0) nil nil t ctx (let* ((wrld4 (if eq-pass12-kpa wrld3a (encapsulate-fix-known-package-alist pass1-kpa pass2-kpa wrld3a))) (wrld5 (global-set? 'ttags-seen post-pass-1-ttags-seen wrld4 (global-val 'ttags-seen wrld3))) (wrld6 (install-proof-supporters-alist post-pass-1-proof-supporters-alist wrld3 wrld5)) (wrld7 (cond ((or (global-val 'skip-proofs-seen wrld3) (null post-pass-1-skip-proofs-seen)) wrld6) (t (global-set 'skip-proofs-seen post-pass-1-skip-proofs-seen wrld6)))) (wrld8 (global-set? 'include-book-alist-all post-pass-1-include-book-alist-all wrld7 (global-val 'include-book-alist-all wrld3))) (wrld9 (global-set? 'pcert-books post-pass-1-pcert-books wrld8 (global-val 'pcert-books wrld3))) (wrld10 (if (and post-pass-1-cert-replay (not eq-pass12-kpa) (not (global-val 'cert-replay wrld3))) (global-set 'cert-replay (if (f-get-global 'certify-book-info state) t (cons (cons (- (max-absolute-command-number wrld3)) nil) (scan-to-command wrld1))) wrld9) wrld9)) (wrld11 (if (null constrained-fns) (global-set 'proved-functional-instances-alist final-proved-fnl-inst-alist wrld10) wrld10))) wrld11) state)))))))))))))))))))) (t (er-let* ((trip (chk-signatures signatures ctx wrld1 state))) (let* ((insigs (car trip)) (names (strip-cars insigs)) (kwd-value-list-lst (cadr trip)) (wrld1 (cddr trip))) (pprogn (set-w 'extension wrld1 state) (er-let* ((expansion-alist0/retval (encapsulate-pass-2 insigs kwd-value-list-lst ev-lst saved-acl2-defaults-table t ctx state))) (let* ((empty-encapsulate-p (eq (car expansion-alist0/retval) :empty-encapsulate)) (expansion-alist (if empty-encapsulate-p (cdr expansion-alist0/retval) (car expansion-alist0/retval))) (retval (and (not empty-encapsulate-p) (cdr expansion-alist0/retval))) (wrld3 (w state)) (new-event-form (and expansion-alist (list* 'encapsulate signatures (subst-by-position expansion-alist ev-lst 0))))) (pprogn (f-put-global 'last-make-event-expansion new-event-form state) (cond (empty-encapsulate-p (empty-encapsulate ctx state)) (t (er-let* ((wrld3a (intro-udf-guards insigs kwd-value-list-lst (intro-udf-global-stobjs insigs kwd-value-list-lst wrld3) wrld3 ctx state))) (install-event (cond ((encapsulate-return-value-p retval) (cadr retval)) ((null names) t) ((null (cdr names)) (car names)) (t names)) (if expansion-alist new-event-form event-form) 'encapsulate (or names 0) nil nil nil ctx wrld3a state))))))))))))))) :event-type 'encapsulate)))
progn-fn1function
(defun progn-fn1 (ev-lst progn!p bindings state) (let ((ctx (cond (ev-lst (msg "( PROGN~s0 ~@1 ...)" (if progn!p "!" "") (tilde-@-abbreviate-object-phrase (car ev-lst)))) (t (if progn!p "( PROGN!)" "( PROGN)")))) (in-encapsulatep (in-encapsulatep (global-val 'embedded-event-lst (w state)) nil))) (with-ctx-summarized ctx (revert-world-on-error (state-global-let* ((inside-progn-fn1 t)) (mv-let (erp val expansion-alist ignore-kpa state) (pprogn (f-put-global 'redo-flat-succ nil state) (f-put-global 'redo-flat-fail nil state) (eval-event-lst 0 nil ev-lst (or (ld-skip-proofsp state) progn!p) (eval-event-lst-environment in-encapsulatep state) (f-get-global 'in-local-flg state) nil (if progn!p :non-event-ok nil) nil 'progn-fn1 ctx (proofs-co state) state)) (declare (ignore ignore-kpa)) (pprogn (if erp (update-for-redo-flat val ev-lst state) state) (cond ((eq erp 'non-event) (er soft ctx "PROGN may only be used on legal event forms (see :DOC ~ embedded-event-form). Consider using ER-PROGN instead.")) (erp (silent-error state)) (t (pprogn (f-put-global 'last-make-event-expansion (and expansion-alist (cons (if progn!p 'progn! 'progn) (if bindings (assert$ progn!p `(:state-global-bindings ,BINDINGS ,@(SUBST-BY-POSITION EXPANSION-ALIST EV-LST 0))) (subst-by-position expansion-alist ev-lst 0)))) state) (value (and (not (f-get-global 'acl2-raw-mode-p state)) val))))))))) :event-type 'progn)))
progn!-fnfunction
(defun progn!-fn (ev-lst bindings state) (state-global-let* ((acl2-raw-mode-p (f-get-global 'acl2-raw-mode-p state)) (ld-okp (let ((old (f-get-global 'ld-okp state))) (if (eq old :default) nil old)))) (progn-fn1 ev-lst t bindings state)))
include-book-alist-subsetpfunction
(defun include-book-alist-subsetp (alist1 alist2) (subsetp-equal (strip-cddrs alist1) (strip-cddrs alist2)))
cbd-fnfunction
(defun cbd-fn (state) (or (f-get-global 'connected-book-directory state) (er hard? 'cbd "The connected book directory has apparently not yet been set. ~ This could be a sign that the top-level ACL2 loop, generally ~ entered using (LP), has not yet been entered.")))
get-portcullis-cmdsfunction
(defun get-portcullis-cmds (wrld cmds cbds names ctx state) (cond ((null wrld) (mv nil cmds cbds state)) ((and (eq (caar wrld) 'command-landmark) (eq (cadar wrld) 'global-value)) (let ((form0 (access-command-tuple-form (cddar wrld))) (cbd (access-command-tuple-cbd (cddar wrld)))) (cond ((equal form0 '(exit-boot-strap-mode)) (mv nil cmds cbds state)) (t (mv-let (erp val state) (chk-embedded-event-form form0 nil wrld ctx state names nil nil nil) (cond (erp (mv erp nil nil state)) (t (let* ((exp (access-command-tuple-last-make-event-expansion (cddar wrld))) (form (if exp (mv-let (wrappers base-form) (destructure-expansion val) (declare (ignore base-form)) (rebuild-expansion wrappers exp)) form0))) (get-portcullis-cmds (cdr wrld) (cons form cmds) (cons cbd cbds) names ctx state))))))))) (t (get-portcullis-cmds (cdr wrld) cmds cbds names ctx state))))
canonical-dirname!function
(defun canonical-dirname! (pathname ctx state) (declare (xargs :guard t)) (or (canonical-pathname pathname t state) (let ((x (canonical-pathname pathname nil state))) (cond (x (er hard? ctx "The file ~x0 is not known to be a directory." x)) (t (er hard? ctx "The directory ~x0 does not exist." pathname))))))
directory-of-absolute-pathnamefunction
(defun directory-of-absolute-pathname (pathname) (let* ((lst (coerce pathname 'list)) (rlst (reverse lst)) (temp (member *directory-separator* rlst))) (coerce (reverse temp) 'string)))
extend-pathname+function
(defun extend-pathname+ (dir0 file-name canon-p state) (let* ((wrld (w state)) (os (os wrld)) (ctx 'extend-pathname) (dir (if (keywordp dir0) (project-dir-lookup dir0 (project-dir-alist wrld) ctx) dir0)) (file-name1 (expand-tilde-to-user-home-dir file-name os ctx state)) (abs-filename (cond ((absolute-pathname-string-p file-name1 nil os) file-name1) (t (our-merge-pathnames dir file-name1)))) (canonical-filename (if (keywordp dir0) abs-filename (canonical-pathname abs-filename nil state)))) (or canonical-filename (and (not canon-p) (let ((len (length abs-filename))) (assert$ (not (eql len 0)) (cond ((eql (char abs-filename (1- (length abs-filename))) #\/) abs-filename) (t (let* ((dir0 (directory-of-absolute-pathname abs-filename)) (len0 (length dir0)) (dir1 (assert$ (and (not (eql len0 0)) (eql (char dir0 (1- len0)) #\/)) (canonical-pathname dir0 t state)))) (cond (dir1 (concatenate 'string dir1 (subseq abs-filename len0 len))) (t abs-filename)))))))))))
extend-pathnamefunction
(defun extend-pathname (dir0 file-name state) (extend-pathname+ dir0 file-name nil state))
maybe-add-separatorfunction
(defun maybe-add-separator (str) (if (and (not (equal str "")) (eql (char str (1- (length str))) *directory-separator*)) str (string-append str *directory-separator-string*)))
set-cbd-fn1function
(defun set-cbd-fn1 (dir state) (pprogn (increment-file-clock state) (assign connected-book-directory dir)))
set-cbd-fn-dirfunction
(defun set-cbd-fn-dir (str os ctx state) (cond ((not (stringp str)) (cond ((and (null str) (f-get-global 'boot-strap-flg state)) nil) (t (msg "The argument cbd must be a string, unlike ~x0. See :DOC cbd." str)))) (t (let ((str (expand-tilde-to-user-home-dir str os ctx state))) (cond ((absolute-pathname-string-p str nil os) (maybe-add-separator (canonical-dirname! str ctx state))) ((not (absolute-pathname-string-p (f-get-global 'connected-book-directory state) t os)) (msg "An attempt was made to set the connected book directory (cbd) ~ using relative pathname ~p0, but surprisingly, the existing ~ cbd is ~p1, which is not an absolute pathname. This appears ~ to be an implementation error; please contact the ACL2 ~ implementors." str (f-get-global 'connected-book-directory state))) (t (maybe-add-separator (canonical-dirname! (our-merge-pathnames (f-get-global 'connected-book-directory state) str) ctx state))))))))
set-cbd-fnfunction
(defun set-cbd-fn (str state) (cond ((and str (equal (cbd) str)) (value nil)) (t (let* ((os (os (w state))) (ctx (cons 'set-cbd str)) (val (set-cbd-fn-dir str os ctx state))) (cond ((consp val) (er soft ctx "~@0" val)) (t (set-cbd-fn1 val state)))))))
set-cbdmacro
(defmacro set-cbd (str) `(set-cbd-fn ,STR state))
set-cbd-statefunction
(defun set-cbd-state (str state) (mv-let (erp val state) (set-cbd-fn str state) (declare (ignore val)) (prog2$ (and erp (er hard 'set-cbd-state "Implementation error: Only use ~x0 when it is known that ~ this will not cause an error." 'set-cbd-state)) state)))
with-cbdmacro
(defmacro with-cbd (dir form) (let ((form form)) `(state-global-let* ((connected-book-directory (cbd) set-cbd-state)) ,(IF (EQ DIR :SAME) FORM `(PPROGN (SET-CBD-STATE ,DIR STATE) ,FORM)))))
with-current-packagemacro
(defmacro with-current-package (pkg form) (let ((form form)) `(state-global-let* ((current-package ,PKG set-current-package-state)) ,FORM)))
parse-book-namefunction
(defun parse-book-name (dir x extension ctx state) (cond ((and extension (not (equal extension ".lisp"))) (mv (er hard ctx "Calls of parse-book-name with non-nil extension other than ~ ".lisp" are not supported. The call ~x0 is thus illegal." `(parse-book-name ,DIR ,X ,EXTENSION ,CTX state)) nil nil x)) ((stringp x) (cond ((search "//" x) (mv (er hard ctx "The filename~|~x0~|is illegal because it has consecutive ~ directory separators, //." x) nil nil x)) (t (let* ((x+ (concatenate 'string x ".lisp")) (full-book-string0 (extend-pathname dir x+ state)) (pos0 (search *directory-separator-string* full-book-string0 :from-end t)) (dir0 (assert$ pos0 (subseq full-book-string0 0 (1+ pos0)))) (len0 (length full-book-string0)) (len0-5 (- len0 5)) (full-book-string (cond (extension full-book-string0) ((string-suffixp ".lisp" full-book-string0) (subseq full-book-string0 0 len0-5)) (t (er hard ctx "A file with pathname ~x0 appears to have canonical ~ pathname ~x1, which unfortunately does not also end ~ in ".lisp"! Note that ACL2 requires that a book's ~ filename ends in ".lisp" even after resolving soft ~ links." x+ full-book-string0)))) (familiar (subseq full-book-string0 (1+ pos0) len0-5))) (mv full-book-string (filename-to-book-name full-book-string (w state)) dir0 familiar))))) (t (mv (er hard ctx "The object ~x0 was found as a book name where a string was ~ expected." x) nil nil x))))
make-include-books-absolute-1mutual-recursion
(mutual-recursion (defun make-include-books-absolute-1 (form cbd dir names localp ctx state) (cond ((atom form) (mv nil form)) ((member-eq (car form) '(local skip-proofs)) (cond ((and (eq (car form) 'local) (not localp)) (mv nil form)) (t (mv-let (changedp x) (make-include-books-absolute-1 (cadr form) cbd dir names localp ctx state) (cond (changedp (mv t (list (car form) x))) (t (mv nil form))))))) ((eq (car form) 'progn) (mv-let (changedp rest) (make-include-books-absolute-lst (cdr form) cbd dir names localp ctx state) (cond (changedp (mv t (cons (car form) rest))) (t (mv nil form))))) ((eq (car form) 'value) (mv nil form)) ((eq (car form) 'include-book) (assert$ (keyword-value-listp (cddr form)) (cond ((assoc-keyword :dir form) (mv nil form)) ((not (equal cbd dir)) (assert$ (stringp cbd) (mv-let (full-book-string full-book-name directory-name familiar-name) (parse-book-name cbd (cadr form) nil ctx state) (declare (ignore directory-name familiar-name)) (cond ((consp full-book-name) (mv t (list* 'include-book (sysfile-filename full-book-name) :dir (sysfile-key full-book-name) (cddr form)))) ((assert$ (equal full-book-name full-book-string) (and dir (not (equal full-book-string (cadr form))))) (mv t (list* 'include-book full-book-string (cddr form)))) (t (mv nil form)))))) (t (assert$ (stringp (cadr form)) (let ((book-name (filename-to-book-name (cadr form) (w state)))) (cond ((consp book-name) (mv t (list* 'include-book (sysfile-filename book-name) :dir (sysfile-key book-name) (cddr form)))) (t (mv nil form))))))))) ((member-eq (car form) '(add-include-book-dir add-include-book-dir!)) (cond ((consp (caddr form)) (mv nil form)) ((not (equal cbd dir)) (assert$ (stringp cbd) (mv t (list (car form) (cadr form) (filename-to-book-name (extend-pathname cbd (caddr form) state) (w state)))))) (t (let ((book-name (filename-to-book-name (caddr form) (w state)))) (cond ((consp book-name) (mv t (list (car form) (cadr form) book-name))) (t (mv nil form))))))) ((member-eq (car form) names) (mv nil form)) ((eq (car form) 'make-event) (mv nil form)) ((eq (car form) 'with-cbd) (assert$ (stringp (cadr form)) (let ((new-cbd (set-cbd-fn-dir (cadr form) (os (w state)) ctx state))) (cond ((consp new-cbd) (mv (er hard ctx "A call of with-cbd has unexpectedly referenced a ~ directory, ~x0, that does not exist in the current ~ context. The error message produced is as ~ follows.~|~%~@1" (cadr form) new-cbd) form)) (t (assert$ (stringp new-cbd) (mv-let (changedp x) (make-include-books-absolute-1 (car (last form)) new-cbd new-cbd names localp ctx state) (cond (changedp (mv t (append (butlast form 1) (list x)))) (t (mv nil form)))))))))) ((and (member-eq (car form) '(with-current-package with-guard-checking-event with-output with-prover-step-limit with-prover-time-limit)) (consp (cdr form))) (mv-let (changedp x) (make-include-books-absolute-1 (car (last form)) cbd dir names localp ctx state) (cond (changedp (mv t (append (butlast form 1) (list x)))) (t (mv nil form))))) ((getpropc (car form) 'macro-body) (mv-let (erp x) (macroexpand1-cmp form ctx (w state) (default-state-vars t)) (cond (erp (mv (er hard erp "~@0" x) nil)) (t (make-include-books-absolute-1 x cbd dir names localp ctx state))))) (t (mv nil (er hard ctx "Implementation error in make-include-books-absolute-1: ~ unrecognized event type, ~x0. Make-include-books-absolute ~ needs to be kept in sync with chk-embedded-event-form. Please ~ send this error message to the implementors." (car form)))))) (defun make-include-books-absolute-lst (forms cbd dir names localp ctx state) (if (endp forms) (mv nil nil) (mv-let (changedp-1 first) (make-include-books-absolute-1 (car forms) cbd dir names localp ctx state) (mv-let (changedp-2 rest) (make-include-books-absolute-lst (cdr forms) cbd dir names localp ctx state) (cond (changedp-1 (mv t (cons first rest))) (changedp-2 (mv t (cons (car forms) rest))) (t (mv nil forms))))))))
make-include-books-absolutefunction
(defun make-include-books-absolute (form cbd dir names localp ctx state) (mv-let (changedp new-form) (make-include-books-absolute-1 form cbd dir names localp ctx state) (if changedp new-form form)))
first-known-package-alistfunction
(defun first-known-package-alist (wrld-segment) (cond ((null wrld-segment) nil) ((and (eq (caar wrld-segment) 'known-package-alist) (eq (cadar wrld-segment) 'global-value)) (let* ((kpa (cddar wrld-segment))) (if (eq kpa *acl2-property-unbound*) (er hard 'first-known-package-alist "Implementation error! Unexpected find of unbound ~ known-package-alist value! Please contact the ACL2 ~ implementors and send this message.") kpa))) (t (first-known-package-alist (cdr wrld-segment)))))
defpkg-items-recfunction
(defun defpkg-items-rec (new-kpa old-kpa ctx w state acc) (cond ((endp new-kpa) (value acc)) (t (let* ((e (car new-kpa)) (n (package-entry-name e))) (cond ((find-package-entry n old-kpa) (defpkg-items-rec (cdr new-kpa) old-kpa ctx w state acc)) (t (let* ((imports (package-entry-imports e)) (event (package-entry-defpkg-event-form e)) (name (cadr event)) (body (caddr event)) (doc (cadddr event)) (tterm (package-entry-tterm e)) (book-path (package-entry-book-path e))) (mv-let (erp pair state) (simple-translate-and-eval body nil nil "The second argument to defpkg" ctx w state nil) (defpkg-items-rec (cdr new-kpa) old-kpa ctx w state (cons (list name imports (assert$ event (assert$ (equal n name) (cond ((and (not erp) (or (equal (cdr pair) imports) (equal (sort-symbol-listp (cdr pair)) imports)) (equal tterm (car pair))) body) ((termp tterm w) tterm) (t (kwote imports))))) doc book-path) acc))))))))))
new-defpkg-pfunction
(defun new-defpkg-p (new-kpa old-kpa) (cond ((endp new-kpa) nil) (t (or (not (find-package-entry (package-entry-name (car new-kpa)) old-kpa)) (new-defpkg-p (cdr new-kpa) old-kpa)))))
defpkg-itemsfunction
(defun defpkg-items (new-kpa old-kpa ctx w state) (cond ((new-defpkg-p new-kpa old-kpa) (state-global-let* ((inhibit-output-lst (cons 'error (f-get-global 'inhibit-output-lst state))) (inhibit-er-hard t)) (mv-let (erp val state) (defpkg-items-rec new-kpa old-kpa ctx w state nil) (assert$ (null erp) (value val))))) (t (value nil))))
new-defpkg-list2function
(defun new-defpkg-list2 (imports all-defpkg-items acc seen) (cond ((endp imports) acc) (t (let ((p (symbol-package-name (car imports)))) (cond ((or (assoc-equal p acc) (assoc-equal p seen)) (new-defpkg-list2 (cdr imports) all-defpkg-items acc seen)) (t (let ((item (assoc-equal p all-defpkg-items))) (cond (item (new-defpkg-list2 (cdr imports) all-defpkg-items (cons item acc) seen)) (t (new-defpkg-list2 (cdr imports) all-defpkg-items acc seen))))))))))
new-defpkg-list1function
(defun new-defpkg-list1 (defpkg-items all-defpkg-items base-kpa earlier-kpa added-defpkgs) (cond ((endp defpkg-items) added-defpkgs) (t (let* ((added-defpkgs (new-defpkg-list1 (cdr defpkg-items) all-defpkg-items base-kpa earlier-kpa added-defpkgs)) (item (car defpkg-items)) (name (car item))) (cond ((find-package-entry name base-kpa) added-defpkgs) (t (cons (make-hidden-defpkg name (cddr item)) (new-defpkg-list1 (new-defpkg-list2 (cadr item) all-defpkg-items nil added-defpkgs) all-defpkg-items earlier-kpa earlier-kpa added-defpkgs))))))))
new-defpkg-listfunction
(defun new-defpkg-list (defpkg-items base-kpa earlier-kpa) (cond ((null defpkg-items) nil) (t (reverse (remove-duplicates-equal (new-defpkg-list1 defpkg-items defpkg-items base-kpa earlier-kpa nil))))))
term-ignore-okpmutual-recursion
(mutual-recursion (defun term-ignore-okp (x) (cond ((or (atom x) (fquotep x)) t) ((symbolp (ffn-symb x)) (term-list-ignore-okp (fargs x))) (t (and (null (set-difference-eq (lambda-formals (ffn-symb x)) (all-vars (lambda-body (ffn-symb x))))) (term-list-ignore-okp (fargs x)))))) (defun term-list-ignore-okp (x) (cond ((endp x) t) ((term-ignore-okp (car x)) (term-list-ignore-okp (cdr x))) (t nil))))
fix-portcullis-cmds1function
(defun fix-portcullis-cmds1 (dir cmds cbds ans names ctx state) (cond ((null cmds) ans) (t (let ((cmd (make-include-books-absolute (car cmds) (car cbds) dir names nil ctx state))) (fix-portcullis-cmds1 dir (cdr cmds) (cdr cbds) (cons cmd ans) names ctx state)))))
fix-portcullis-cmdsfunction
(defun fix-portcullis-cmds (dir cmds cbds names wrld ctx state) (let ((new-cmds (fix-portcullis-cmds1 dir cmds cbds nil names ctx state))) (er-let* ((new-defpkgs (hidden-defpkg-events (global-val 'known-package-alist wrld) wrld ctx state))) (value (revappend new-cmds new-defpkgs)))))
collect-uncertified-booksfunction
(defun collect-uncertified-books (alist) (cond ((null alist) nil) ((null (cddddr (car alist))) (cons (caar alist) (collect-uncertified-books (cdr alist)))) (t (collect-uncertified-books (cdr alist)))))
chk-in-packagefunction
(defun chk-in-package (channel file empty-okp ctx state) (state-global-let* ((current-package "ACL2")) (mv-let (eofp val state) (read-object channel state) (cond (eofp (cond (empty-okp (value nil)) (t (er soft ctx "The file ~x0 is empty. An IN-PACKAGE form, ~ at the very least, was expected." file)))) ((and (true-listp val) (= (length val) 2) (eq (car val) 'in-package) (stringp (cadr val))) (cond ((find-non-hidden-package-entry (cadr val) (known-package-alist state)) (value (cadr val))) (t (er soft ctx "The argument to IN-PACKAGE must be a known ~ package name, but ~x0, used in the first form ~ in ~x1, is not. The known packages are ~*2~@3" (cadr val) file (tilde-*-&v-strings '& (strip-non-hidden-package-names (known-package-alist state)) #\.) (if (global-val 'include-book-path (w state)) (msg "~%NOTE: This error might be eliminated by ~ certifying the book mentioned above. See :DOC ~ certify-book.") ""))))) (t (er soft ctx "The first form in ~x0 was expected to be ~ (IN-PACKAGE "pkg") where "pkg" is a known ~ ACL2 package name. See :DOC book-contents. The first ~ form was, in fact, ~x1." file val))))))
ill-formed-certificate-ermacro
(defmacro ill-formed-certificate-er (ctx mark file1 file2 &optional (bad-object 'nil bad-objectp)) `(er soft ,CTX "The certificate for the book ~x0 is ill-formed. Delete or rename the ~ file ~x1 and recertify ~x0. Remember that the certification world for ~ ~x0 is described in the portcullis of ~x1 (see :DOC portcullis) so you ~ might want to look at ~x1 to remind yourself of ~x0's certification~ ~ world.~|Debug note for developers:~|~@2~@3" ,FILE1 ,FILE2 ,(IF (AND (CONSP MARK) (EQ (CAR MARK) 'QUOTE) (SYMBOLP (CADR MARK))) (SYMBOL-NAME (CADR MARK)) MARK) ,(IF BAD-OBJECTP `(MSG "~|Bad object: ~x0" ,BAD-OBJECT) "")))
include-book-er-warning-summaryfunction
(defun include-book-er-warning-summary (keyword suspect-book-action-alist state) (let ((keyword-string (case keyword (:uncertified-okp "Uncertified") (:skip-proofs-okp "Skip-proofs") (:defaxioms-okp "Defaxioms") (t (if (eq keyword t) nil (er hard 'include-book-er "Include-book-er does not know the include-book keyword ~ argument ~x0." keyword)))))) (cond ((eq keyword t) nil) ((assoc-eq keyword suspect-book-action-alist) (cond ((cdr (assoc-eq keyword suspect-book-action-alist)) (cond ((if (eq keyword :skip-proofs-okp) (not (f-get-global 'skip-proofs-okp-cert state)) (and (eq keyword :defaxioms-okp) (not (f-get-global 'defaxioms-okp-cert state)))) keyword) (t keyword-string))) (t keyword))) (t (er hard 'include-book-er "There is a discrepancy between the keywords in the ~ suspect-book-action-alist, ~x0, and the keyword, ~x1, supplied ~ to include-book-er." suspect-book-action-alist keyword)))))
include-book-er1function
(defun include-book-er1 (file1 file2 msg warning-summary ctx state) (cond ((null warning-summary) (er soft ctx "~@2" file1 file2 msg)) ((symbolp warning-summary) (cond ((member-eq (cert-op state) '(nil :write-acl2xu)) (er soft ctx "~@0 This is illegal because we are currently attempting ~ include-book with ~x1 set to NIL. You can avoid this error by ~ using a value of T for ~x1; see :DOC include-book." (msg "~@2" file1 file2 msg) warning-summary)) (t (er soft ctx "~@0 This is illegal because we are currently attempting ~ certify-book; see :DOC certify-book." (msg "~@2" file1 file2 msg))))) (t (pprogn (warning$ ctx warning-summary "~@2" file1 file2 msg) (value nil)))))
include-book-erfunction
(defun include-book-er (file1 file2 msg keyword suspect-book-action-alist ctx state) (let ((warning-summary (include-book-er-warning-summary keyword suspect-book-action-alist state))) (include-book-er1 file1 file2 msg warning-summary ctx state)))
post-alist-from-channelfunction
(defun post-alist-from-channel (x y ch state) (mv-let (eofp obj state) (cond ((member-eq y '(:expansion-alist :cert-data)) (mv-let (eofp state) (read-object-suppress ch state) (mv eofp nil state))) (t (read-object ch state))) (cond ((or eofp (eq obj :pcert-info)) (mv x state)) (t (post-alist-from-channel y obj ch state)))))
certificate-file-and-input-channel1function
(defun certificate-file-and-input-channel1 (full-book-string cert-op state) (let ((cert-name (convert-book-string-to-cert full-book-string cert-op))) (mv-let (ch state) (open-input-channel cert-name :object state) (mv ch cert-name state))))
pcert-op-pmacro
(defmacro pcert-op-p (cert-op) `(member-eq ,CERT-OP '(:create-pcert :create+convert-pcert :convert-pcert)))
other
(defrec cert-obj ((cmds . pre-alist) post-alist (expansion-alist . cert-data) . pcert-info) t)
get-cert-obj-and-cert-filenamefunction
(defun get-cert-obj-and-cert-filename (full-book-name state) (declare (ignore full-book-name)) (mv-let (erp val state) (read-acl2-oracle state) (let ((val (and (not erp) (consp val) (weak-cert-obj-p (car val)) (stringp (cdr val))))) (mv (car val) (cdr val) state))))
certificate-file-and-input-channelfunction
(defun certificate-file-and-input-channel (full-book-string full-book-name old-cert-op state) (mv-let (cert-obj cert-filename state) (if full-book-name (get-cert-obj-and-cert-filename full-book-name state) (mv nil nil state)) (cond (cert-obj (mv cert-obj cert-filename state)) (old-cert-op (mv-let (ch cert-name state) (certificate-file-and-input-channel1 full-book-string old-cert-op state) (mv ch cert-name state))) (t (mv-let (ch cert-name state) (certificate-file-and-input-channel1 full-book-string t state) (cond (ch (mv ch cert-name state)) (t (mv-let (ch cert-name state) (certificate-file-and-input-channel1 full-book-string :create-pcert state) (cond (ch (mv ch cert-name state)) (t (mv-let (ch cert-name state) (certificate-file-and-input-channel1 full-book-string :convert-pcert state) (mv ch cert-name state))))))))))))
cert-annotations-and-checksum-from-cert-filefunction
(defun cert-annotations-and-checksum-from-cert-file (full-book-string state) (mv-let (ch cert-name state) (certificate-file-and-input-channel full-book-string nil (if (eq (cert-op state) :convert-pcert) :create-pcert nil) state) (declare (ignore cert-name)) (cond (ch (mv-let (x state) (post-alist-from-channel nil nil ch state) (pprogn (close-input-channel ch state) (value (cdddr (car x)))))) (t (silent-error state)))))
tilde-@-cert-post-alist-phrasefunction
(defun tilde-@-cert-post-alist-phrase (full-book-string familiar-name cdr-reqd-entry cdr-actual-entry state) (declare (ignore cdr-reqd-entry)) (mv-let (erp pair state) (cert-annotations-and-checksum-from-cert-file full-book-string state) (mv (let ((cert-maybe-unchanged-p (cond (erp nil) ((null (cdr cdr-actual-entry)) t) (t (equal cdr-actual-entry pair))))) (cond (erp (msg "~|AND NOTE that file ~x0 does not currently ~ exist, so you will need to recertify ~x1 and the ~ books that depend on it (and, if you are using ~ an image created by save-exec, then consider ~ rebuilding that image)" (concatenate 'string familiar-name ".cert") familiar-name)) (cert-maybe-unchanged-p " so book recertification is probably required") (t (msg "~|AND NOTE that file ~x0 changed after ~x1 was ~ included, so you should probably undo back ~ through the command that included ~x1 (or, if ~ you are using an image created by save-exec, ~ consider rebuilding that image)" (concatenate 'string familiar-name ".cert") familiar-name)))) state)))
assoc-familiar-namefunction
(defun assoc-familiar-name (familiar-name alist) (cond ((endp alist) nil) ((equal familiar-name (caddr (car alist))) (car alist)) (t (assoc-familiar-name familiar-name (cdr alist)))))
tilde-*-book-hash-phrase1function
(defun tilde-*-book-hash-phrase1 (reqd-alist actual-alist state) (cond ((null reqd-alist) (mv nil state)) (t (let* ((reqd-entry (cdddr (car reqd-alist))) (familiar-name (caddr (car reqd-alist))) (full-book-name (car (car reqd-alist))) (actual-element (assoc-equal full-book-name actual-alist)) (actual-entry (cdddr actual-element))) (cond ((null actual-entry) (let* ((pair (assoc-familiar-name familiar-name actual-alist)) (wrld (w state)) (full-book-string (book-name-to-filename full-book-name wrld 'tilde-*-book-hash-phrase1)) (msg (cond (pair (msg "-- its certificate requires the book ~ "~s0", but that book has not been ~ included although the book "~s1" -- ~ which has the same familiar name as that ~ required book (but with a different ~ full-book-name; see :DOC full-book-name) ~ -- has been included" full-book-string (book-name-to-filename (car pair) wrld 'tilde-*-book-hash-phrase1))) (t (msg "-- its certificate requires the book ~ "~s0", but that book has not been ~ included, nor has any book with the same ~ familiar name as that required book (see ~ :DOC full-book-name) -- perhaps the ~ certificate file changed during inclusion ~ of some superior book" full-book-string))))) (mv-let (msgs state) (tilde-*-book-hash-phrase1 (cdr reqd-alist) actual-alist state) (mv (cons msg msgs) state)))) ((equal reqd-entry actual-entry) (tilde-*-book-hash-phrase1 (cdr reqd-alist) actual-alist state)) (t (mv-let (msgs state) (tilde-*-book-hash-phrase1 (cdr reqd-alist) actual-alist state) (let ((full-book-string (book-name-to-filename full-book-name (w state) 'tilde-*-book-hash-phrase1))) (mv-let (phrase state) (tilde-@-cert-post-alist-phrase full-book-string familiar-name reqd-entry actual-entry state) (mv (cons (cond ((null (cdr actual-entry)) (msg "-- its certificate requires the uncertified book ~ ~x0~@1" full-book-string phrase)) (t (msg "-- its certificate requires the book "~s0" with ~ certificate annotations~| ~x1~|and book hash ~x2, ~ but we have included ~@3~@4" full-book-string (car reqd-entry) (cdr reqd-entry) (msg "a version of ~x0 with certificate ~ annotations~| ~x1~|and book-hash ~x2," familiar-name (car actual-entry) (cdr actual-entry)) phrase))) msgs) state))))))))))
tilde-*-book-hash-phrasefunction
(defun tilde-*-book-hash-phrase (reqd-alist actual-alist state) (mv-let (phrase1 state) (tilde-*-book-hash-phrase1 reqd-alist actual-alist state) (mv (list "~|" "~|~@*" "~|~@*;~|" "~|~@*;~|" phrase1) state)))
get-cmds-from-portcullis1function
(defun get-cmds-from-portcullis1 (eval-hidden-defpkgs ch ctx state ans) (mv-let (eofp form state) (read-object ch state) (cond (eofp (mv t nil state)) ((eq form :end-portcullis-cmds) (value (reverse ans))) ((and eval-hidden-defpkgs (case-match form (('defpkg & & & & 't) t) (& nil))) (er-progn (trans-eval-default-warning form ctx state nil) (get-cmds-from-portcullis1 eval-hidden-defpkgs ch ctx state (cons form ans)))) (t (get-cmds-from-portcullis1 eval-hidden-defpkgs ch ctx state (cons form ans))))))
get-cmds-from-portcullisfunction
(defun get-cmds-from-portcullis (file1 file2 eval-hidden-defpkgs ch ctx state) (revert-world-on-error (let* ((wrld (w state)) (events (hidden-defpkg-events-simple (global-val 'known-package-alist wrld) nil))) (er-progn (if events (state-global-let* ((inhibit-output-lst (remove1-eq 'error *valid-output-names*))) (trans-eval-default-warning (cons 'er-progn events) ctx state t)) (value nil)) (mv-let (erp val state) (get-cmds-from-portcullis1 eval-hidden-defpkgs ch ctx state nil) (cond (erp (ill-formed-certificate-er ctx 'get-cmds-from-portcullis file1 file2)) (t (pprogn (if events (set-w! wrld state) state) (value val)))))))))
convert-book-string-to-portfunction
(defun convert-book-string-to-port (x) (concatenate 'string (remove-lisp-suffix x nil) "port"))
chk-raise-portcullis2function
(defun chk-raise-portcullis2 (file1 file2 ch-or-cmds port-file-p ctx state ans) (mv-let (eofp form ch-or-cmds state) (cond ((null ch-or-cmds) (mv t nil nil state)) ((symbolp ch-or-cmds) (mv-let (eofp form state) (read-object ch-or-cmds state) (mv eofp form ch-or-cmds state))) (t (mv nil (car ch-or-cmds) (cdr ch-or-cmds) state))) (cond (eofp (cond ((or (null ch-or-cmds) port-file-p) (value (reverse ans))) (t (ill-formed-certificate-er ctx '|CHK-RAISE-PORTCULLIS2{PORT}| file1 file2)))) ((and (eq form :end-portcullis-cmds) (not port-file-p)) (assert$ (not (listp ch-or-cmds)) (value (reverse ans)))) (t (mv-let (error-flg trans-ans state) (trans-eval-default-warning form (msg (if port-file-p "the .port file for ~x0" "the portcullis for ~x0") file1) state t) (let ((erp-prime (car (cdr trans-ans)))) (cond ((or error-flg erp-prime) (pprogn (cond (port-file-p (warning$ ctx "Portcullis" "The error reported above was caused while ~ trying to execute commands from file ~x0 ~ while including uncertified book ~x1. In ~ particular, we were trying to execute ~x2 ~ when the error occurred. Because of this ~ error, we cannot complete the include-book ~ operation for the above book, in the current ~ world. You can perhaps eliminate this error ~ by removing file ~x0." (convert-book-string-to-port file1) file1 form)) (t (warning$ ctx "Portcullis" "The error reported above was caused while ~ trying to raise the portcullis for the book ~ ~x0. In particular, we were trying to ~ execute ~x1 when the error occurred. ~ Because we cannot raise the portcullis, we ~ cannot include this book in this world. ~ There are two standard responses to this ~ situation. Either change the current ~ logical world so that this error does not ~ occur, e.g., redefine one of your functions, ~ or recertify the book in a different ~ environment." file1 form))) (mv t nil state))) (t (chk-raise-portcullis2 file1 file2 ch-or-cmds port-file-p ctx state (cons form ans))))))))))
chk-raise-portcullis1function
(defun chk-raise-portcullis1 (file1 file2 ch-or-cert-obj port-file-p ctx state) (state-global-let* ((ld-skip-proofsp 'include-book) (skip-proofs-by-system t) (in-local-flg (and (f-get-global 'in-local-flg state) 'local-include-book))) (er-progn (maybe-install-acl2-defaults-table *initial-acl2-defaults-table* state) (chk-raise-portcullis2 file1 file2 (if (symbolp ch-or-cert-obj) ch-or-cert-obj (access cert-obj ch-or-cert-obj :cmds)) port-file-p ctx state nil))))
mark-local-included-booksfunction
(defun mark-local-included-books (post-alist1 post-alist2) (cond ((null post-alist1) nil) ((eq (caar post-alist1) 'local) (cons (car post-alist1) (mark-local-included-books (cdr post-alist1) post-alist2))) ((assoc-equal (caar post-alist1) post-alist2) (cons (car post-alist1) (mark-local-included-books (cdr post-alist1) post-alist2))) (t (cons (list 'local (car post-alist1)) (mark-local-included-books (cdr post-alist1) post-alist2)))))
unmark-and-delete-local-included-booksfunction
(defun unmark-and-delete-local-included-books (post-alist3) (cond ((null post-alist3) nil) ((eq (caar post-alist3) 'local) (unmark-and-delete-local-included-books (cdr post-alist3))) (t (cons (car post-alist3) (unmark-and-delete-local-included-books (cdr post-alist3))))))
earlier-acl2-versionpfunction
(defun earlier-acl2-versionp (version1 version2) (mv-let (major1 minor1 incrl1 rest1) (parse-version version1) (declare (ignore rest1)) (mv-let (major2 minor2 incrl2 rest2) (parse-version version2) (declare (ignore rest2)) (cond ((or (null major1) (null major2)) (er hard 'earlier-acl2-versionp "We are surprised to find an ACL2 version string, ~x0, that ~ cannot be parsed." (if (null major1) version1 version2))) (t (or (< major1 major2) (and (int= major1 major2) (assert$ (and (natp minor1) (natp minor2)) (or (< minor1 minor2) (and (int= minor1 minor2) (< incrl1 incrl2)))))))))))
acl2-version-r-pfunction
(defun acl2-version-r-p (version) (let ((p (position #\( version))) (and p (< (+ p 2) (length version)) (equal (subseq version p (+ p 3)) "(r)"))))
ttag-alistpfunction
(defun ttag-alistp (x) (cond ((atom x) (null x)) (t (and (consp (car x)) (symbolp (caar x)) (true-listp (cdar x)) (book-name-listp (remove1 nil (cdar x))) (ttag-alistp (cdr x))))))
cert-annotationspfunction
(defun cert-annotationsp (x) (case-match x (((':skipped-proofsp . sp) (':axiomsp . ap) . ttags-singleton) (and (member-eq sp '(t nil ?)) (member-eq ap '(t nil ?)) (or (null ttags-singleton) (case-match ttags-singleton (((':ttags . ttags)) (ttag-alistp ttags)) (& nil))))) (& nil)))
*trivial-book-hash*constant
(defconst *trivial-book-hash* :trivial-book-hash)
cert-hashfunction
(defun cert-hash (old-cert-hash cmds pre-alist post-alist expansion-alist cert-data state) (cond ((if old-cert-hash (integerp old-cert-hash) (not (f-get-global 'book-hash-alistp state))) (check-sum-obj (cons (cons cmds pre-alist) (list* post-alist expansion-alist cert-data)))) (t *trivial-book-hash*)))
include-book-alist-entry-pfunction
(defun include-book-alist-entry-p (entry) (and (consp entry) (book-name-p (car entry)) (consp (cdr entry)) (stringp (cadr entry)) (consp (cddr entry)) (stringp (caddr entry)) (consp (cdddr entry)) (cert-annotationsp (cadddr entry)) (let ((book-hash (cddddr entry))) (case-match book-hash (((':book-length . book-length) (':book-write-date . book-write-date)) (and (natp book-length) (natp book-write-date))) (& (integerp book-hash))))))
sysfile-to-filenamefunction
(defun sysfile-to-filename (x state) (cond ((sysfile-p x) (extend-pathname (sysfile-key x) (sysfile-filename x) state)) (t x)))
keyword-listpfunction
(defun keyword-listp (x) (declare (xargs :guard t)) (if (consp x) (and (keywordp (car x)) (keyword-listp (cdr x))) (null x)))
read-file-into-templatefunction
(defun read-file-into-template (template ch state acc) (cond ((null template) (mv-let (eofp val state) (read-object ch state) (cond (eofp (value (reverse acc))) (t (mv 'stray-value1 (list val template) state))))) (t (mv-let (eofp val state) (read-object ch state) (cond (eofp (cond ((keyword-listp template) (value (revappend acc (make-list (length template))))) (t (mv 'eof template state)))) ((null (car template)) (read-file-into-template (cdr template) ch state (cons val acc))) ((eq val (car template)) (mv-let (eofp val state) (read-object ch state) (cond (eofp (mv 'eof template state)) (t (read-file-into-template (cdr template) ch state (cons val acc)))))) (t (let ((posn-kwd-val (and (keywordp val) (position-eq val template))) (posn-nil (position-eq nil template))) (cond (posn-kwd-val (cond ((and posn-nil (< posn-nil posn-kwd-val)) (mv :kwd-late (list posn-kwd-val posn-nil template) state)) (t (mv-let (eofp val2 state) (read-object ch state) (cond (eofp (mv 'eof val state)) (t (read-file-into-template (cdr (nthcdr posn-kwd-val template)) ch state (cons val2 (make-list-ac posn-kwd-val nil acc))))))))) (posn-nil (read-file-into-template (cdr (nthcdr posn-nil template)) ch state (cons val (make-list-ac posn-nil nil acc)))) (t (assert$ (keyword-listp template) (mv 'stray-value2 (list val template) state)))))))))))
cert-data-falfunction
(defun cert-data-fal (cert-data) (let* ((pair1 (assoc-eq :translate cert-data)) (a1 (if pair1 (acons :translate (make-fast-alist (cdr pair1)) nil) nil)) (pair2 (assoc-eq :type-prescription cert-data)) (a2 (if pair2 (acons :type-prescription (make-fast-alist (cdr pair2)) a1) a1))) a2))
include-book-alistp-1function
(defun include-book-alistp-1 (x local-markers-allowedp) (cond ((atom x) (null x)) (t (and (consp (car x)) (let ((entry (car x))) (cond ((and (consp entry) (eq (car entry) 'local)) (and local-markers-allowedp (consp (cdr entry)) (null (cddr entry)) (include-book-alist-entry-p (cadr entry)))) (t (include-book-alist-entry-p entry)))) (include-book-alistp-1 (cdr x) local-markers-allowedp)))))
include-book-alistpfunction
(defun include-book-alistp (x local-markers-allowedp) (include-book-alistp-1 x local-markers-allowedp))
include-book-raw-errorfunction
(defun include-book-raw-error (str state) (declare (ignore str)) (value nil))
chk-raise-portcullisfunction
(defun chk-raise-portcullis (file1 file2 ch-or-cert-obj light-chkp caller ctx state suspect-book-action-alist evalp) (with-reckless-readtable (er-let* ((portcullis-cmds (if evalp (chk-raise-portcullis1 file1 file2 ch-or-cert-obj nil ctx state) (assert$ (symbolp ch-or-cert-obj) (get-cmds-from-portcullis file1 file2 (eq caller 'convert-pcert) ch-or-cert-obj ctx state))))) (cond ((consp ch-or-cert-obj) (cond ((include-book-alist-subsetp (access cert-obj ch-or-cert-obj :pre-alist) (global-val 'include-book-alist (w state))) (value ch-or-cert-obj)) (t (include-book-raw-error "There is a problem with the certificate, which may be ~ described below in detail." state)))) (t (mv-let (erp tuple state) (read-file-into-template '(:expansion-alist :cert-data nil nil nil :pcert-info) ch-or-cert-obj state nil) (cond (erp (if (eq caller 'include-book-raw) (include-book-raw-error "Ill-formed certificate" state) (ill-formed-certificate-er ctx '|CHK-RAISE-PORTCULLIS{READ-FILE-INTO-TEMPLATE}| file1 file2))) (t (let* ((expansion-alist (nth 0 tuple)) (cert-data (cert-data-fal (nth 1 tuple))) (pre-alist (nth 2 tuple)) (post-alist3 (nth 3 tuple)) (cert-hash1 (nth 4 tuple)) (pcert-info (if (eq caller 'convert-pcert) (nth 5 tuple) nil)) (unexpected-from-book-name (and (consp post-alist3) (consp (car post-alist3)) (sysfile-p (caar post-alist3)) (let ((filename (book-name-to-filename (caar post-alist3) (w state) ctx))) (and (not (equal filename file1)) filename))))) (er-let* ((pre-alist (cond ((include-book-alistp pre-alist nil) (value pre-alist)) ((eq caller 'include-book-raw) (include-book-raw-error "Ill-formed certificate" state)) (t (ill-formed-certificate-er ctx '|CHK-RAISE-PORTCULLIS{PRE-ALIST-2}| file1 file2 pre-alist)))) (post-alist3 (cond ((include-book-alistp post-alist3 t) (value post-alist3)) ((eq caller 'include-book-raw) (include-book-raw-error "Ill-formed certificate" state)) (t (ill-formed-certificate-er ctx '|CHK-RAISE-PORTCULLIS{POST-ALIST-2}| file1 file2 post-alist3)))) (cert-hash2 (value (and (not light-chkp) (cert-hash cert-hash1 portcullis-cmds pre-alist post-alist3 expansion-alist cert-data state)))) (actual-alist (value (global-val 'include-book-alist (w state))))) (cond ((and (not light-chkp) (not (equal cert-hash1 cert-hash2))) (if (eq caller 'include-book-raw) (include-book-raw-error "Ill-formed certificate" state) (ill-formed-certificate-er ctx '|CHK-RAISE-PORTCULLIS{CERT-HASH}| file1 file2 (list :cert-hash1 cert-hash1 :cert-hash2 cert-hash2)))) ((and (not light-chkp) (or unexpected-from-book-name (and (not (eq caller 'include-book-raw)) (not (include-book-alist-subsetp pre-alist actual-alist))))) (if (eq caller 'include-book-raw) (include-book-raw-error "Unexpected error" state) (let ((warning-summary (include-book-er-warning-summary :uncertified-okp suspect-book-action-alist state))) (cond ((or (and (equal warning-summary "Uncertified") (warning-disabled-p "Uncertified")) (eq caller 'include-book-raw)) (value nil)) (unexpected-from-book-name (include-book-er1 file1 file2 (msg "The book being ~ included,~|~s0,~%is not in the ~ location expected for the ACL2 ~ executable being used:~|~s1." file1 unexpected-from-book-name) warning-summary ctx state)) (t (mv-let (msgs state) (tilde-*-book-hash-phrase pre-alist actual-alist state) (include-book-er1 file1 file2 (cons "After evaluating the ~ portcullis commands for the ~ book ~x0:~|~*3." (list (cons #\3 msgs))) warning-summary ctx state))))))) (t (value (make cert-obj :cmds portcullis-cmds :cert-data cert-data :pre-alist pre-alist :post-alist post-alist3 :expansion-alist expansion-alist :pcert-info pcert-info))))))))))))))
chk-certificate-file1function
(defun chk-certificate-file1 (file1 file2 ch-or-cert-obj light-chkp caller ctx state suspect-book-action-alist evalp) (cond ((consp ch-or-cert-obj) (chk-raise-portcullis file1 file2 ch-or-cert-obj light-chkp caller ctx state suspect-book-action-alist evalp)) (t (mv-let (eofp version0 state) (read-object ch-or-cert-obj state) (cond ((and eofp (symbolp ch-or-cert-obj)) (if (eq caller 'include-book-raw) (include-book-raw-error "Reached end-of-file while reading version." state) (ill-formed-certificate-er ctx '|CHK-CERTIFICATE-FILE1{EMPTY}| file1 file2))) (t (let* ((acl2-version (f-get-global 'acl2-version state)) (hackp (consp version0)) (version (if hackp (car version0) version0)) (fast-cert-status (f-get-global 'fast-cert-status state)) (version-okp (or (equal version0 acl2-version) (and fast-cert-status (equal version acl2-version))))) (pprogn (cond ((and hackp fast-cert-status (not (fast-cert-included-book fast-cert-status))) (let ((s (sysfile-to-filename file1 state))) (f-put-global 'fast-cert-status (if (consp fast-cert-status) (list s) s) state))) (t state)) (cond (version-okp (mv-let (eofp key state) (read-object ch-or-cert-obj state) (cond (eofp (if (eq caller 'include-book-raw) (include-book-raw-error "Reached end-of-file after reading version." state) (ill-formed-certificate-er ctx '|CHK-CERTIFICATE-FILE1{BEGIN-PORTCULLIS-CMDS-1}| file1 file2))) ((not (eq key :begin-portcullis-cmds)) (if (eq caller 'include-book-raw) (include-book-raw-error "Expected :BEGIN-PORTCULLIS-CMDS." state) (ill-formed-certificate-er ctx '|CHK-CERTIFICATE-FILE1{BEGIN-PORTCULLIS-CMDS-2}| file1 file2 key))) (t (chk-raise-portcullis file1 file2 ch-or-cert-obj light-chkp caller ctx state suspect-book-action-alist evalp))))) ((eq caller 'include-book-raw) (include-book-raw-error (concatenate 'string "Illegal version string read: " (if (stringp version) version "expected a string or list of a string")) state)) (t (let ((msg (cond ((equal version acl2-version) (cons "~x0 was certified using fast-cert mode enabled, but ~ fast-cert mode is currently disabled. See :DOC ~ fast-cert. No compiled file will be loaded with this ~ book." nil)) ((not (equal (acl2-version-r-p acl2-version) (acl2-version-r-p version))) (cons "We do not permit ACL2 books to be processed by ~ ACL2(r) or vice versa. ~x0 was certified with ~sa ~ but this is ~sb. No compiled file will be loaded ~ with this book." (list (cons #\a version) (cons #\b acl2-version)))) (t (cons "~x0 was apparently certified with ~sa. The ~ inclusion of this book in the current ACL2 may ~ render this ACL2 session unsound! We recommend ~ you recertify the book with the current version, ~ ~sb. See :DOC version. No compiled file will ~ be loaded with this book." (list (cons #\a version) (cons #\b acl2-version))))))) (mv-let (erp val state) (include-book-er file1 file2 msg :uncertified-okp suspect-book-action-alist ctx state) (cond (erp (mv erp val state)) ((and (stringp version) (<= 13 (length version)) (equal (subseq version 0 13) "ACL2 Version ")) (mv-let (eofp key state) (read-object ch-or-cert-obj state) (cond (eofp (ill-formed-certificate-er ctx '|CHK-CERTIFICATE-FILE1{BEGIN-PORTCULLIS-CMDS-3}| file1 file2)) ((not (eq key :begin-portcullis-cmds)) (ill-formed-certificate-er ctx '|CHK-CERTIFICATE-FILE1{BEGIN-PORTCULLIS-CMDS-4}| file1 file2 key)) (t (er-progn (chk-raise-portcullis file1 file2 ch-or-cert-obj light-chkp caller ctx state suspect-book-action-alist t) (value nil)))))) (t (ill-formed-certificate-er ctx '|CHK-CERTIFICATE-FILE1{ACL2-VERSION}| file1 file2 version)))))))))))))))
certificate-filefunction
(defun certificate-file (full-book-string state) (mv-let (ch cert-name state) (certificate-file-and-input-channel full-book-string nil nil state) (pprogn (cond (ch (close-input-channel ch state)) (t state)) (mv (and ch cert-name) state))))
defconst-form-to-elidefunction
(defun defconst-form-to-elide (ev) (case-match ev (('defconst & ('quote &)) t) (& nil)))
hcomp-elided-defconst-alist2mutual-recursion
(mutual-recursion (defun hcomp-elided-defconst-alist2 (index ev alist) (case-match ev (('defconst name ('quote &)) (acons index (cons name (caddr ev)) alist)) (('progn . lst) (hcomp-elided-defconst-alist2-lst index lst alist)) (('encapsulate & . lst) (hcomp-elided-defconst-alist2-lst index lst alist)) (('record-expansion & x) (hcomp-elided-defconst-alist2 index x alist)) (('with-guard-checking-event & x) (hcomp-elided-defconst-alist2 index x alist)) (('skip-proofs x) (hcomp-elided-defconst-alist2 index x alist)) (('with-output . lst) (hcomp-elided-defconst-alist2-lst index (car (last lst)) alist)) (('with-prover-step-limit & & x) (hcomp-elided-defconst-alist2-lst index x alist)) (('with-prover-step-limit & x) (hcomp-elided-defconst-alist2-lst index x alist)) (& alist))) (defun hcomp-elided-defconst-alist2-lst (index lst alist) (cond ((endp lst) alist) (t (hcomp-elided-defconst-alist2 index (car lst) (hcomp-elided-defconst-alist2-lst index (cdr lst) alist))))))
hcomp-elided-defconst-alist1function
(defun hcomp-elided-defconst-alist1 (alist) (declare (xargs :guard (alistp alist))) (cond ((endp alist) nil) (t (let ((index (caar alist)) (ev (cdar alist))) (hcomp-elided-defconst-alist2 index ev (hcomp-elided-defconst-alist1 (cdr alist)))))))
hcomp-elided-defconst-alistfunction
(defun hcomp-elided-defconst-alist (cert-obj) (declare (xargs :guard (and (weak-cert-obj-p cert-obj) (alistp (access cert-obj cert-obj :expansion-alist))))) (cond ((null cert-obj) nil) (t (hcomp-elided-defconst-alist1 (access cert-obj cert-obj :expansion-alist)))))
convert-cert-file-to-pcert-opfunction
(defun convert-cert-file-to-pcert-op (file) (cond ((string-suffixp "pcert0" file) :create-pcert) ((string-suffixp "pcert1" file) :convert-pcert) (t nil)))
chk-certificate-filefunction
(defun chk-certificate-file (file1 dir full-book-name caller ctx state suspect-book-action-alist evalp) (let ((dir (or dir (directory-of-absolute-pathname file1)))) (mv-let (ch-or-cert-obj file2 state) (certificate-file-and-input-channel file1 full-book-name (if (eq caller 'convert-pcert) :create-pcert nil) state) (cond ((null ch-or-cert-obj) (if (eq caller 'include-book-raw) (include-book-raw-error "Certificate is unavailable." state) (include-book-er file1 file2 "There is no certificate on file for ~x0. See ~ :DOC uncertified-books." :uncertified-okp suspect-book-action-alist ctx state))) (t (er-let* ((pkg (if (symbolp ch-or-cert-obj) (chk-in-package ch-or-cert-obj file2 nil ctx state) (value "ACL2")))) (cond ((not (equal pkg "ACL2")) (if (eq caller 'include-book-raw) (include-book-raw-error (concatenate 'string "Unexpected package name read from certificate: " (if (stringp pkg) pkg "Not a string")) state) (ill-formed-certificate-er ctx '|CHK-CERTIFICATE-FILE{PKG}| file1 file2 pkg))) (t (with-cbd dir (state-global-let* ((current-package "ACL2")) (let ((saved-wrld (w state))) (mv-let (error-flg val state) (chk-certificate-file1 file1 file2 ch-or-cert-obj (case caller ((convert-pcert include-book include-book-raw) nil) (puff t) (otherwise (er hard ctx "Implementation error in chk-certificate-file: ~ Unexpected case!"))) caller ctx state suspect-book-action-alist evalp) (let* ((pcert-op (convert-cert-file-to-pcert-op file2)) (val (cond ((and val pcert-op (not (access cert-obj val :pcert-info))) (change cert-obj val :pcert-info (if (eq pcert-op :create-pcert) :unproved (assert$ (eq pcert-op :convert-pcert) :proved)))) (t val)))) (pprogn (if (symbolp ch-or-cert-obj) (close-input-channel ch-or-cert-obj state) state) (cond (error-flg (pprogn (set-w! saved-wrld state) (if (eq caller 'include-book-raw) (include-book-raw-error "An error was encountered when checking the ~ certificate file." state) (include-book-er file1 file2 "An error was encountered when ~ checking the certificate file ~ for ~x0." :uncertified-okp suspect-book-action-alist ctx state)))) (t (value val)))))))))))))))))
cert-obj-for-convertfunction
(defun cert-obj-for-convert (full-book-string dir pre-alist fixed-cmds suspect-book-action-alist ctx state) (er-let* ((cert-obj (chk-certificate-file full-book-string dir nil 'convert-pcert ctx state suspect-book-action-alist nil))) (cond ((not (equal-modulo-hidden-defpkgs fixed-cmds (access cert-obj cert-obj :cmds))) (er soft ctx "The Convert procedure of provisional certification requires ~ that the current ACL2 world at the start of that procedure ~ agrees with the current ACL2 world present at the start of ~ the Pcertify procedure. However, these worlds appear to ~ differ! To see the current commands, use :pbt! 1. To see ~ the portcullis commands from the .pcert0 file, evaluate the ~ following form:~|~Y01~|Now compare the result of that ~ evaluation, ignoring DEFPKG events whose fifth argument (of ~ five) is T, with (``fixed'') portcullis commands of the ~ current ACL2 world:~|~y2" `(er-let* ((cert-obj (chk-certificate-file ,FULL-BOOK-STRING ,DIR 'convert-pcert ',CTX state ',SUSPECT-BOOK-ACTION-ALIST nil))) (value (access cert-obj cert-obj :cmds))) nil fixed-cmds)) ((not (equal pre-alist (access cert-obj cert-obj :pre-alist))) (er soft ctx "The Convert procedure of provisional certification requires ~ that the include-book-alist at the start of that procedure ~ (the ``pre-alist'') agrees with the one present at the start ~ of the Pcertify procedure. However, these appear to differ! ~ The current world's pre-alist is:~|~% ~y0~|~%The pre-alist ~ from the Pcertify procedure (from the .pcert0 file) is:~|~% ~ ~y1~|~%" pre-alist (access cert-obj cert-obj :pre-alist))) (t (value cert-obj)))))
chk-acceptable-certify-book1function
(defun chk-acceptable-certify-book1 (user-book-name full-book-string full-book-name dir k cmds cbds names cert-op suspect-book-action-alist wrld ctx state) (let ((pre-alist-cert-wrld (global-val 'include-book-alist wrld)) (uncert-books (and (not (eq cert-op :write-acl2xu)) (collect-uncertified-books (global-val 'include-book-alist-all wrld))))) (cond ((not (eq (default-defun-mode wrld) :logic)) (er soft ctx "Books must be certified in :LOGIC mode. The current mode is ~x0." (default-defun-mode wrld))) ((and (not (integerp k)) (not (symbol-name-equal k "?"))) (er soft ctx "The second argument to certify-book must be a natural number or ~ the symbol ? (in any package). You supplied ~x0. See :DOC ~ certify-book." k)) ((and (not (symbol-name-equal k "?")) (not (eql k (length cmds)))) (er soft ctx "Your certify-book command specifies a certification world of ~ length ~x0 but it is actually of length ~x1. Perhaps you intended ~ to issue a command of the form: (certify-book ~x2 ~x1 ...). See ~ :DOC certify-book." k (length cmds) user-book-name)) ((assoc-equal full-book-name pre-alist-cert-wrld) (er soft ctx "We cannot certify ~x0 in a world in which it has already been ~ included." full-book-string)) (uncert-books (let ((uncert-book-filenames (book-name-lst-to-filename-lst uncert-books (project-dir-alist wrld) ctx))) (er soft ctx "It is impossible to certify any book in the current world ~ because it is built upon ~*0 which ~#1~[is~/are~] uncertified." (tilde-*-&v-strings '& uncert-book-filenames #\,) uncert-book-filenames))) (t (er-let* ((fixed-cmds (cond ((null cbds) (value cmds)) (t (fix-portcullis-cmds dir cmds cbds names wrld ctx state))))) (cond ((eq cert-op :convert-pcert) (cert-obj-for-convert full-book-string dir pre-alist-cert-wrld fixed-cmds suspect-book-action-alist ctx state)) (t (value (make cert-obj :cmds fixed-cmds :pre-alist nil :post-alist nil :expansion-alist nil :cert-data nil)))))))))
translate-book-namesfunction
(defun translate-book-names (book-names cbd ctx msg project-dir-alist state acc) (declare (xargs :guard (true-listp book-names))) (cond ((endp book-names) (value (reverse acc))) ((null (car book-names)) (translate-book-names (cdr book-names) cbd ctx msg project-dir-alist state (cons nil acc))) ((not (book-name-p (car book-names))) (er soft ctx "The name ~x0~@1 is not a valid book-name. See :DOC book-name." (car book-names) msg)) (t (translate-book-names (cdr book-names) cbd ctx msg project-dir-alist state (cons (filename-to-book-name-1 (extend-pathname cbd (possibly-add-lisp-extension (book-name-to-filename-1 (car book-names) project-dir-alist ctx)) state) project-dir-alist) acc)))))
fix-ttagsfunction
(defun fix-ttags (ttags cbd ctx project-dir-alist state seen acc) (declare (xargs :guard (true-listp ttags))) (cond ((endp ttags) (value (reverse acc))) (t (let* ((ttag (car ttags)) (sym0 (if (consp ttag) (car ttag) ttag)) (sym (and (symbolp sym0) sym0 (intern (symbol-name sym0) "KEYWORD")))) (cond ((not (and sym (or (atom ttag) (book-name-listp (remove1-eq nil (cdr ttag)))))) (er soft ctx "A :ttags value for certify-book or include-book must ~ either be the keyword :ALL or else a list, each of whose ~ members is one of the following: a non-nil symbol, or the ~ CONS of a non-nil symbol onto a true list consisting of ~ strings and at most one nil. The value ~x0 is thus an ~ illegal member of such a list." ttag)) ((member-eq sym seen) (er soft ctx "A :ttags list may not reference the same ttag more than ~ once, but the proposed list references ~x0 more than once." sym)) ((symbolp ttag) (fix-ttags (cdr ttags) cbd ctx project-dir-alist state (cons sym seen) (cons sym acc))) (t (er-let* ((full-book-names (translate-book-names (cdr ttag) cbd ctx (msg ", which has been ~ associated with ttag ~ ~x0, " (car ttag)) project-dir-alist state nil))) (fix-ttags (cdr ttags) cbd ctx project-dir-alist state (cons sym seen) (cons (cons sym full-book-names) acc)))))))))
chk-well-formed-ttagsfunction
(defun chk-well-formed-ttags (ttags cbd ctx state) (cond ((null ttags) (value nil)) ((and (symbolp ttags) (equal (symbol-name ttags) "ALL")) (value :all)) ((not (true-listp ttags)) (er soft ctx "A valid :ttags value must either be :all or a true list, The ~ following value is thus illegal: ~x0." ttags)) (t (let ((wrld (w state))) (fix-ttags ttags cbd ctx (project-dir-alist wrld) state nil nil)))))
check-certificate-file-existsfunction
(defun check-certificate-file-exists (full-book-string cert-op ctx state) (mv-let (ch cert-name state) (certificate-file-and-input-channel1 full-book-string (cond ((eq cert-op :convert-pcert) :create-pcert) (t t)) state) (cond (ch (pprogn (close-input-channel ch state) (value nil))) ((eq cert-op :convert-pcert) (er soft ctx "The file ~x0 cannot be opened for input; perhaps it is ~ missing. But that file is required for the Convert ~ procedure of provisional certification of the book ~x1." cert-name full-book-string)) (t (er soft ctx "There is no certificate (.cert) file for ~x0. But you told ~ certify-book to recover the certi~-fication world from the ~ old certificate. You will have to construct the ~ certi~-fication world by hand (by executing the desired ~ commands in the current logical world) and then call ~ certify-book again." full-book-string)))))
illegal-to-certify-checkfunction
(defun illegal-to-certify-check (before-p ctx state) (cond ((f-get-global 'illegal-to-certify-message state) (er soft ctx "It is illegal to certify a book in this session, as explained ~ by the message on a possible invariance violation, printed ~ earlier ~@0. To see the message again, evaluate ~ the following form:~|~x1" (if before-p "in this session" "during the certification attempt") '(fmx "~@0~%~%" (@ illegal-to-certify-message)))) (t (value nil))))
chk-acceptable-certify-bookfunction
(defun chk-acceptable-certify-book (book-name full-book-string full-book-name dir suspect-book-action-alist cert-op k ctx state) (let ((names (cons 'defpkg (primitive-event-macros))) (wrld (w state)) (dir (or dir (directory-of-absolute-pathname full-book-string)))) (er-progn (cond ((and (ld-skip-proofsp state) (not (eq cert-op ':write-acl2xu))) (er soft ctx "Certify-book must be called with ld-skip-proofsp set to nil ~ (except when writing .acl2x files in the case that ~ set-write-acl2x has specified skipping proofs).")) ((f-get-global 'in-local-flg state) (er soft ctx "Certify-book may not be called inside a LOCAL command.")) ((and (global-val 'skip-proofs-seen wrld) (not (cdr (assoc-eq :skip-proofs-okp suspect-book-action-alist)))) (er soft ctx "At least one event in the current ACL2 world was executed ~ with proofs skipped, either with a call of skip-proofs or by ~ setting ``LD special'' variable '~x0 to a non-nil value. ~ ~@1(If you did not explicitly use ~ skip-proofs or set-ld-skip-proofsp, or call ld with ~ :ld-skip-proofsp not nil, then some other function did so, ~ for example, rebuild or :puff.) Certification is therefore ~ not allowed in this world unless you supply certify-book ~ with :skip-proofs-okp t. See :DOC certify-book." 'ld-skip-proofsp (let ((x (global-val 'skip-proofs-seen wrld))) (if (and (consp x) (eq (car x) :include-book)) (msg "Such an event was introduced via the ~ included book, ~x0. " (book-name-to-filename (cadr x) wrld ctx)) (msg "Such an event was:~|~% ~y0~%" x))))) ((global-val 'redef-seen wrld) (er soft ctx "At least one command in the current ACL2 world was executed ~ while the value of state global variable '~x0 was not ~ nil:~|~% ~y1~%Certification is therefore not allowed in ~ this world. You can use :ubt to undo back through this ~ command; see :DOC ubt." 'ld-redefinition-action (global-val 'redef-seen wrld))) ((and (not (pcert-op-p cert-op)) (global-val 'pcert-books wrld)) (let ((books (global-val 'pcert-books wrld))) (er soft ctx "Certify-book has been invoked in an ACL2 world that ~ includes the book~#0~[ below, which is~/s below, each of ~ which is~] only provisionally certified: there is a ~ certificate file with extension .pcert0 or .pcert1, but ~ not with extension .cert.~|~%~@1~|~%A certify-book command ~ is thus illegal in this world unless a :pcert keyword ~ argument is specified to be :create or :convert." books (print-indented-list-msg books 2 "")))) ((ttag wrld) (er soft ctx "It is illegal to certify a book while there is an active ~ ttag, in this case, ~x0. Consider undoing the corresponding ~ defttag event (see :DOC ubt) or else executing ~x1. See ~ :DOC defttag." (ttag wrld) '(defttag nil))) (t (value nil))) (illegal-to-certify-check t ctx state) (cond ((eq cert-op :convert-pcert) (check-certificate-file-exists full-book-string cert-op ctx state)) (t (value nil))) (mv-let (erp cmds cbds state) (get-portcullis-cmds wrld nil nil names ctx state) (cond (erp (silent-error state)) (t (chk-acceptable-certify-book1 book-name full-book-string full-book-name dir k cmds cbds names cert-op suspect-book-action-alist wrld ctx state)))))))
print-objectsfunction
(defun print-objects (lst ch state) (cond ((null lst) state) (t (pprogn (print-object$ (car lst) ch state) (print-objects (cdr lst) ch state)))))
replace-initial-substringfunction
(defun replace-initial-substring (s old old-length new) (cond ((and (stringp s) (> (length s) old-length) (equal old (subseq s 0 old-length))) (concatenate 'string new (subseq s old-length (length s)))) (t s)))
replace-string-prefix-in-treefunction
(defun replace-string-prefix-in-tree (tree old old-length new) (cond ((atom tree) (replace-initial-substring tree old old-length new)) (t (cons (replace-string-prefix-in-tree (car tree) old old-length new) (replace-string-prefix-in-tree (cdr tree) old old-length new)))))
with-output-object-channel-sharingmacro
(defmacro with-output-object-channel-sharing (chan filename body &optional chan0) (declare (xargs :guard (and (symbolp chan) (symbolp chan0)))) `(mv-let (,CHAN state) (if ,CHAN0 (mv ,CHAN0 state) (open-output-channel ,FILENAME :object state)) ,BODY))
elide-locals-and-split-expansion-alistfunction
(defun elide-locals-and-split-expansion-alist (alist acl2x-alist x y) (cond ((endp alist) (mv (reverse x) (reverse y))) (t (assert$ (or (null acl2x-alist) (<= (caar alist) (caar acl2x-alist))) (let ((acl2x-alist-new (cond ((and acl2x-alist (eql (caar alist) (caar acl2x-alist))) (cdr acl2x-alist)) (t acl2x-alist)))) (mv-let (changedp form) (elide-locals-rec (cdar alist)) (cond (changedp (elide-locals-and-split-expansion-alist (cdr alist) acl2x-alist-new (acons (caar alist) form x) (cond ((and acl2x-alist (equal (car alist) (car acl2x-alist))) y) (t (cons (car alist) y))))) (t (elide-locals-and-split-expansion-alist (cdr alist) acl2x-alist-new (cons (car alist) x) y)))))))))
make-certificate-file1function
(defun make-certificate-file1 (file portcullis certification-file post-alist3 expansion-alist cert-data pcert-info cert-op ctx state) (assert$ (not (member-eq cert-op '(:write-acl2x :write-acl2xu))) (assert$ (implies (eq cert-op :convert-pcert) (eq (cert-op state) :create+convert-pcert)) (with-output-object-channel-sharing ch certification-file (cond ((null ch) (er soft ctx "We cannot open a certificate file for ~x0. The file we tried to ~ open for output was ~x1." file certification-file)) (t (with-print-defaults ((current-package "ACL2") (print-circle (f-get-global 'print-circle-files state)) (print-readably t)) (pprogn (print-object$ '(in-package "ACL2") ch state) (print-object$ (if (let ((status (f-get-global 'fast-cert-status state))) (and status (or (atom status) (fast-cert-included-book status)))) (list (f-get-global 'acl2-version state)) (f-get-global 'acl2-version state)) ch state) (print-object$ :begin-portcullis-cmds ch state) (print-objects (car portcullis) ch state) (print-object$ :end-portcullis-cmds ch state) (cond (expansion-alist (pprogn (print-object$ :expansion-alist ch state) (print-object$ expansion-alist ch state))) (t state)) (cond (cert-data (pprogn (print-object$ :cert-data ch state) (print-object$ cert-data ch state))) (t state)) (print-object$ (cdr portcullis) ch state) (print-object$ post-alist3 ch state) (print-object$ (cert-hash nil (car portcullis) (cdr portcullis) post-alist3 expansion-alist cert-data state) ch state) (cond (pcert-info (pprogn (print-object$ :pcert-info ch state) (print-object$ pcert-info ch state))) (t state)) (close-output-channel ch state) (value certification-file)))))))))
make-certificate-filefunction
(defun make-certificate-file (file portcullis post-alist1 post-alist2 expansion-alist cert-data pcert-info cert-op ctx state) (let* ((certification-file (convert-book-string-to-cert file cert-op)) (post-alist3 (mark-local-included-books post-alist1 post-alist2))) (er-progn (cond ((include-book-alistp post-alist3 t) (value nil)) (t (er soft ctx "Ill-formed post-alist encountered in file ~x0:~|~x1" certification-file post-alist3))) (make-certificate-file1 file portcullis (concatenate 'string certification-file ".temp") post-alist3 expansion-alist cert-data pcert-info cert-op ctx state))))
make-certificate-filesfunction
(defun make-certificate-files (full-book-string portcullis post-alist1 post-alist2 expansion-alist cert-data pcert-info cert-op ctx state) (cond ((eq cert-op :create+convert-pcert) (er-let* ((pcert0-file (make-certificate-file full-book-string portcullis post-alist1 post-alist2 expansion-alist cert-data pcert-info :create-pcert ctx state)) (pcert1-file (make-certificate-file full-book-string portcullis post-alist1 post-alist2 expansion-alist cert-data nil :convert-pcert ctx state))) (value (list (cons pcert0-file (convert-book-string-to-cert full-book-string :create-pcert)) (cons pcert1-file (convert-book-string-to-cert full-book-string :convert-pcert)))))) (t (er-let* ((cert-file (make-certificate-file full-book-string portcullis post-alist1 post-alist2 expansion-alist cert-data pcert-info cert-op ctx state))) (value (list (cons cert-file (convert-book-string-to-cert full-book-string cert-op))))))))
open-input-object-filefunction
(defun open-input-object-file (file ctx state) (cond ((stringp file) (mv-let (ch state) (open-input-channel file :object state) (cond ((null ch) (er soft ctx "There is no file named ~x0 that can be ~ opened for input." file)) (t (value ch))))) (t (er soft ctx "File names in ACL2 must be strings, so ~x0 is not a ~ legal file name." file))))
read-object-file1function
(defun read-object-file1 (channel state ans) (mv-let (eofp val state) (read-object channel state) (cond (eofp (value (reverse ans))) (t (read-object-file1 channel state (cons val ans))))))
read-object-filefunction
(defun read-object-file (file ctx state) (er-let* ((ch (open-input-object-file file ctx state)) (new-current-package (chk-in-package ch file nil ctx state))) (state-global-let* ((current-package new-current-package)) (er-let* ((lst (read-object-file1 ch state nil))) (let ((state (close-input-channel ch state))) (value (cons (list 'in-package new-current-package) lst)))))))
chk-cert-annotationsfunction
(defun chk-cert-annotations (cert-annotations portcullis-skipped-proofsp portcullis-cmds full-book-string suspect-book-action-alist ctx state) (er-progn (cond (portcullis-skipped-proofsp (include-book-er full-book-string nil (cons "The certification world for book ~x0 contains one or more ~ SKIP-PROOFS events~@3." (list (cons #\3 (if (and (consp portcullis-skipped-proofsp) (eq (car portcullis-skipped-proofsp) :include-book)) (msg " under (subsidiary) book "~@0"" (cadr portcullis-skipped-proofsp)) "")))) :skip-proofs-okp suspect-book-action-alist ctx state)) ((eq (cdr (assoc-eq :skipped-proofsp cert-annotations)) nil) (value nil)) ((eq (cdr (assoc-eq :skipped-proofsp cert-annotations)) t) (include-book-er full-book-string nil (if portcullis-cmds "The book ~x0 (including events from its portcullis) ~ contains one or more SKIP-PROOFS events." "The book ~x0 contains one or more SKIP-PROOFS events.") :skip-proofs-okp suspect-book-action-alist ctx state)) (t (include-book-er full-book-string nil (if portcullis-cmds "The book ~x0 (including events from its ~ portcullis) may contain SKIP-PROOFS events." "The book ~x0 may contain SKIP-PROOFS events.") :skip-proofs-okp suspect-book-action-alist ctx state))) (cond ((eq (cdr (assoc :axiomsp cert-annotations)) nil) (value nil)) ((eq (cdr (assoc :axiomsp cert-annotations)) t) (include-book-er full-book-string nil (if portcullis-cmds "The book ~x0 (including events from its portcullis) ~ contains one or more DEFAXIOM events." "The book ~x0 contains one or more DEFAXIOM events.") :defaxioms-okp suspect-book-action-alist ctx state)) (t (include-book-er full-book-string nil (if portcullis-cmds "The book ~x0 (including events from its ~ portcullis) may contain DEFAXIOM events." "The book ~x0 may contain DEFAXIOM events.") :defaxioms-okp suspect-book-action-alist ctx state)))))
chk-cert-annotations-post-alistfunction
(defun chk-cert-annotations-post-alist (post-alist portcullis-cmds full-book-string suspect-book-action-alist ctx state) (cond ((endp post-alist) (value nil)) (t (let* ((localp (eq (car (car post-alist)) 'local)) (full-subbook (if localp (car (cadr (car post-alist))) (car (car post-alist)))) (cert-annotations (if localp (cadddr (cadr (car post-alist))) (cadddr (car post-alist))))) (er-progn (cond ((eq (cdr (assoc-eq :skipped-proofsp cert-annotations)) nil) (value nil)) ((eq (cdr (assoc-eq :skipped-proofsp cert-annotations)) t) (include-book-er full-book-string nil (cons "The book ~x0~sp~#a~[~/ locally~] includes ~xb, which ~ contains one or more SKIP-PROOFS events." (list (cons #\a (if localp 1 0)) (cons #\b full-subbook) (cons #\p (if portcullis-cmds " (including events from its portcullis)" "")))) :skip-proofs-okp suspect-book-action-alist ctx state)) (t (include-book-er full-book-string nil (cons "The book ~x0~sp~#a~[~/ locally~] includes ~xb, which ~ may contain SKIP-PROOFS events." (list (cons #\a (if localp 1 0)) (cons #\b full-subbook) (cons #\p (if portcullis-cmds " (including events from its portcullis)" "")))) :skip-proofs-okp suspect-book-action-alist ctx state))) (cond ((eq (cdr (assoc :axiomsp cert-annotations)) nil) (value nil)) ((eq (cdr (assoc :axiomsp cert-annotations)) t) (include-book-er full-book-string nil (cons "The book ~x0~sp~#a~[~/ locally~] includes ~xb, which ~ contains one or more DEFAXIOM events." (list (cons #\a (if localp 1 0)) (cons #\b full-subbook) (cons #\p (if portcullis-cmds " (including events from its portcullis)" "")))) :defaxioms-okp suspect-book-action-alist ctx state)) (t (include-book-er full-book-string nil (cons "The book ~x0~sp~#a~[~/ locally~] includes ~xb, which ~ may contain DEFAXIOM events." (list (cons #\a (if localp 1 0)) (cons #\b full-subbook) (cons #\p (if portcullis-cmds " (including events from its ~ portcullis)" "")))) :defaxioms-okp suspect-book-action-alist ctx state))) (chk-cert-annotations-post-alist (cdr post-alist) portcullis-cmds full-book-string suspect-book-action-alist ctx state))))))
chk-input-object-filefunction
(defun chk-input-object-file (file ctx state) (er-let* ((ch (cond ((null (canonical-pathname file nil state)) (er soft ctx "The file ~x0 does not exist." file)) (t (open-input-object-file file ctx state))))) (let ((state (close-input-channel ch state))) (value t))))
include-book-dirfunction
(defun include-book-dir (dir state) (declare (xargs :stobjs state :guard (and (symbolp dir) (or (not (raw-include-book-dir-p state)) (and (symbol-alistp (f-get-global 'raw-include-book-dir!-alist state)) (symbol-alistp (f-get-global 'raw-include-book-dir-alist state)))) (let ((wrld (w state))) (and (alistp (table-alist 'acl2-defaults-table wrld)) (alistp (cdr (assoc-eq :include-book-dir-alist (table-alist 'acl2-defaults-table wrld)))) (alistp (table-alist 'include-book-dir!-table wrld))))) :guard-hints (("Goal" :in-theory (enable state-p1))))) (cond ((and (keywordp dir) (project-dir-lookup dir (project-dir-alist (w state)) nil))) ((raw-include-book-dir-p state) (or (cdr (assoc-eq dir (f-get-global 'raw-include-book-dir!-alist state))) (cdr (assoc-eq dir (f-get-global 'raw-include-book-dir-alist state))))) (t (let ((wrld (w state))) (or (cdr (assoc-eq dir (cdr (assoc-eq :include-book-dir-alist (table-alist 'acl2-defaults-table wrld))))) (cdr (assoc-eq dir (table-alist 'include-book-dir!-table wrld))))))))
include-book-dir-with-chkmacro
(defmacro include-book-dir-with-chk (soft-or-hard ctx dir) `(let ((ctx ,CTX) (dir ,DIR)) (let ((dir-value (include-book-dir dir state))) (cond ((null dir-value) (er ,SOFT-OR-HARD ctx "The legal values for the :DIR argument are keywords that ~ include those in the global project-dir-alist (see :DOC ~ project-dir-alist) as well as those added by a call of ~ ~v0. However, that argument is ~x1, which is not ~@2." '(add-include-book-dir add-include-book-dir!) dir (cond ((keywordp dir) (msg "among the list of those legal values, ~x0" (strip-cars (union-eq (project-dir-alist (w state)) (append (cdr (assoc-eq :include-book-dir-alist (table-alist 'acl2-defaults-table (w state)))) (table-alist 'include-book-dir!-table (w state))))))) (t "a keyword")))) (t ,(IF (EQ SOFT-OR-HARD 'SOFT) '(VALUE DIR-VALUE) 'DIR-VALUE))))))
accumulate-post-alist1function
(defun accumulate-post-alist1 (post-alist include-book-alist) (cond ((endp post-alist) include-book-alist) (t (let* ((entry0 (car post-alist)) (entry (if (eq (car entry0) 'local) (cadr entry0) entry0)) (key (hons-copy (car entry)))) (cond ((hons-get key include-book-alist) (accumulate-post-alist1 (cdr post-alist) include-book-alist)) (t (accumulate-post-alist1 (cdr post-alist) (hons-acons key (cdr entry) include-book-alist))))))))
accumulate-post-alistfunction
(defun accumulate-post-alist (post-alist include-book-alist) (let ((include-book-alist (make-fast-alist include-book-alist))) (fast-alist-free-on-exit include-book-alist (accumulate-post-alist1 post-alist include-book-alist))))
skipped-proofsp-in-post-alistfunction
(defun skipped-proofsp-in-post-alist (post-alist) (cond ((endp post-alist) nil) (t (let* ((localp (eq (car (car post-alist)) 'local)) (cert-annotations (if localp (cadddr (cadr (car post-alist))) (cadddr (car post-alist))))) (cond ((cdr (assoc-eq :skipped-proofsp cert-annotations)) (if localp (car (cadr (car post-alist))) (car (car post-alist)))) (t (skipped-proofsp-in-post-alist (cdr post-alist))))))))
book-hash-alistfunction
(defun book-hash-alist (full-book-string state) (mv-let (book-write-date state) (file-write-date$ full-book-string state) (mv-let (book-length state) (file-length$ full-book-string state) (value `((:book-length . ,BOOK-LENGTH) (:book-write-date . ,BOOK-WRITE-DATE))))))
book-hashfunction
(defun book-hash (old-book-hash full-book-string portcullis-cmds expansion-alist cert-data book-ev-lst state) (cond ((if old-book-hash (integerp old-book-hash) (not (f-get-global 'book-hash-alistp state))) (value (check-sum-obj (list* portcullis-cmds expansion-alist book-ev-lst cert-data)))) (t (book-hash-alist full-book-string state))))
with-hcomp-bindingsmacro
(defmacro with-hcomp-bindings (form) form)
with-hcomp-ht-bindingsmacro
(defmacro with-hcomp-ht-bindings (form) form)
get-declaim-listfunction
(defun get-declaim-list (state) (read-acl2-oracle state))
tilde-@-book-stack-msgfunction
(defun tilde-@-book-stack-msg (reason load-compiled-stack ctx wrld) (let* ((project-dir-alist (project-dir-alist wrld)) (stack-rev (book-name-lst-to-filename-lst (reverse (strip-cars load-compiled-stack)) project-dir-alist ctx)) (reason (if (sysfile-p reason) (book-name-to-filename-1 reason project-dir-alist ctx) reason)) (arg (cond (stack-rev (msg " Here is the sequence of books with loads of compiled or ~ expansion files that have led down to the printing of this ~ message, where the load for each is halted during the load ~ for the next:~|~%~*0" `(" <empty>" " ~s*" " ~s*~|" " ~s*~|" ,STACK-REV))) (t " No load was in progress for any parent book.")))) (cond ((eq reason t) (msg " This is an error because an include-book for this book ~ specified :LOAD-COMPILE-FILE ~x0; see :DOC include-book.~@1" reason arg)) (reason (msg " This is an error because we are underneath an include-book ~ for~| ~y0that specified :LOAD-COMPILE-FILE ~x1; see :DOC ~ include-book.~@2" reason t arg)) (t arg))))
convert-book-string-to-acl2xfunction
(defun convert-book-string-to-acl2x (x) (concatenate 'string (remove-lisp-suffix x nil) "acl2x"))
acl2x-alistpfunction
(defun acl2x-alistp (x index len) (cond ((atom x) (and (null x) (< index len))) ((consp (car x)) (and (integerp (caar x)) (< index (caar x)) (acl2x-alistp (cdr x) (caar x) len))) (t nil)))
read-acl2x-filefunction
(defun read-acl2x-file (acl2x-file full-book-string len acl2x ctx state) (mv-let (acl2x-date state) (file-write-date$ acl2x-file state) (cond ((not acl2x) (pprogn (cond (acl2x-date (warning$ ctx "acl2x" "Although the file ~x0 exists, it is being ~ ignored because keyword option :ACL2X T was ~ not supplied to certify-book." acl2x-file full-book-string)) (t state)) (value nil))) (t (mv-let (book-date state) (file-write-date$ full-book-string state) (cond ((or (not (natp acl2x-date)) (not (natp book-date)) (< acl2x-date book-date)) (cond ((eq acl2x :optional) (value nil)) (t (er soft ctx "Certify-book has been instructed with option :ACL2X T to ~ read file ~x0. However, this file ~#1~[does not exist~/has ~ not been confirmed to be at least as recent as the book ~ ~x2~]. See :DOC set-write-acl2x." acl2x-file (if acl2x-date 1 0) full-book-string)))) (t (er-let* ((chan (open-input-object-file acl2x-file ctx state))) (state-global-let* ((current-package "ACL2")) (cond (chan (mv-let (eofp val state) (read-object chan state) (cond (eofp (er soft ctx "No form was read in acl2x file ~x0.~|See ~ :DOC certify-book." acl2x-file)) ((acl2x-alistp val 0 len) (pprogn (observation ctx "Using expansion-alist containing ~n0 ~ ~#1~[entries~/entry~/entries~] from ~ file ~x2." (length val) (zero-one-or-more val) acl2x-file) (value val))) (t (er soft ctx "Illegal value in acl2x file:~|~x0~|See :DOC ~ certify-book." val))))) (t (value nil))))))))))))
eval-port-filefunction
(defun eval-port-file (full-book-string ctx state) (let ((port-file (convert-book-string-to-port full-book-string)) (dir (directory-of-absolute-pathname full-book-string))) (pprogn (mv-let (ch state) (open-input-channel port-file :object state) (cond ((null ch) (value nil)) (t (er-let* ((pkg (chk-in-package ch port-file t ctx state))) (cond ((null pkg) (value nil)) ((not (equal pkg "ACL2")) (er soft ctx "File ~x0 is corrupted. It was expected either to contain no ~ forms or to start with the form (in-package "ACL2")." port-file)) (t (prog2$ (observation-cw ctx "Reading .port file, ~s0." port-file) (with-cbd dir (state-global-let* ((current-package "ACL2")) (mv-let (error-flg val state) (revert-world-on-error (with-reckless-readtable (chk-raise-portcullis1 full-book-string port-file ch t ctx state))) (pprogn (close-input-channel ch state) (cond (error-flg (silent-error state)) (t (pprogn (cond ((null val) state) (t (io? event nil state (port-file val) (fms "ACL2 has processed the ~n0 ~ command~#1~[~/s~] in file ~x2.~|" (list (cons #\0 (length val)) (cons #\1 val) (cons #\2 port-file)) (proofs-co state) state nil)))) (value val))))))))))))))))))
getenv!function
(defun getenv! (str state) (declare (xargs :stobjs state :guard (stringp str))) (er-let* ((temp (getenv$ str state))) (value (and (not (equal temp "")) temp))))
update-pcert-booksfunction
(defun update-pcert-books (full-book-name pcert-p wrld) (cond (pcert-p (global-set 'pcert-books (cons full-book-name (global-val 'pcert-books wrld)) wrld)) (t wrld)))
*projects/apply/base-sysfile*constant
(defconst *projects/apply/base-sysfile* (make-sysfile :system "projects/apply/base.lisp"))
include-book-cert-obj-prelimfunction
(defun include-book-cert-obj-prelim (behalf-of-certify-flg uncertified-okp full-book-string full-book-name suspect-book-action-alist directory-name ctx wrld state) (cond (behalf-of-certify-flg (value nil)) ((f-get-global 'ignore-cert-files state) (cond ((eq uncertified-okp nil) (include-book-er full-book-string nil (if (equal full-book-name (f-get-global 'ignore-cert-files state)) "Include-book is specifying :UNCERTIFIED-OKP :IGNORE-CERTS, ~ which requires that its certificate file (if any) must be ~ ignored." (msg "A superior include-book event for ~x0 has specified ~ :UNCERTIFIED-OKP :IGNORE-CERTS, which requires that the ~ certificate files (if any) for its sub-books must be ~ ignored." (book-name-to-filename (f-get-global 'ignore-cert-files state) wrld ctx))) :uncertified-okp suspect-book-action-alist ctx state)) (t (value nil)))) (t (with-hcomp-ht-bindings (chk-certificate-file full-book-string directory-name full-book-name 'include-book ctx state suspect-book-action-alist t)))))
include-book-ok-familiar-name-and-hashfunction
(defun include-book-ok-familiar-name-and-hash (cert-obj post-alist familiar-name full-book-string post-alist-book-hash ev-lst-book-hash suspect-book-action-alist ctx state) (er-let* ((no-errp-1 (cond ((and cert-obj (not (equal (caddr (car post-alist)) familiar-name))) (include-book-er full-book-string nil (cons "The cer~-ti~-fi~-cate on file for ~x0 lists the book under ~ the name ~x3 whereas we were expecting it to give the name ~ ~x4. While one can often move a certified book from one ~ directory to another after cer~-ti~-fi~-ca~-tion, we insist ~ that it keep the same familiar name. This allows the ~ cer~-ti~-fi~-cate file to contain the familiar name, making ~ it easier to identify which cer~-ti~-fi~-cates go with ~ which files and inspiring a little more confidence that the ~ cer~-ti~-fi~-cate really does describe the alleged file. ~ In the present case, it looks as though the familiar ~ book-name was changed after cer~-ti~-fi~-ca~-tion. For ~ what it is worth, the book-hash of the file at ~ cer~-ti~-fi~-ca~-tion was ~x5. Its book-hash now is ~x6." (list (cons #\3 (caddr (car post-alist))) (cons #\4 familiar-name) (cons #\5 post-alist-book-hash) (cons #\6 ev-lst-book-hash))) :uncertified-okp suspect-book-action-alist ctx state)) (t (value t)))) (no-errp-2 (cond ((and cert-obj (not (equal post-alist-book-hash ev-lst-book-hash))) (include-book-er full-book-string nil (cons "~|The certificate for ~x0 lists the book-hash of that book ~ as ~x3. But its book-hash is now computed to be ~x4.~|See ~ :DOC book-hash-mismatch." (list (cons #\3 post-alist-book-hash) (cons #\4 ev-lst-book-hash))) :uncertified-okp suspect-book-action-alist ctx state)) (t (value t))))) (value (and no-errp-1 no-errp-2))))
include-book-process-embedded-eventsfunction
(defun include-book-process-embedded-events (ev-lst directory-name ttags-info cert-obj cert-ttags cert-data behalf-of-certify-flg full-book-string full-book-name skip-proofsp expansion-alist ctx state) (with-cbd directory-name (state-global-let* ((axiomsp nil) (ttags-allowed (if cert-obj cert-ttags (f-get-global 'ttags-allowed state))) (skip-notify-on-defttag (and ttags-info full-book-string)) (match-free-error nil) (guard-checking-on t) (in-local-flg (and (f-get-global 'in-local-flg state) 'local-include-book)) (including-uncertified-p (not cert-obj))) (er-progn (with-hcomp-ht-bindings (process-embedded-events 'include-book (if behalf-of-certify-flg :do-not-install! :do-not-install) skip-proofsp (cadr (car ev-lst)) (list 'include-book full-book-name) (subst-by-position expansion-alist (cdr ev-lst) 1) 1 (and (eq skip-proofsp 'include-book) (or (and cert-obj t) behalf-of-certify-flg)) cert-data ctx state)) (value (if ttags-info (car ttags-info) (f-get-global 'ttags-allowed state)))))))
include-book-certified-pfunction
(defun include-book-certified-p (cert-obj post-alist actual-alist suspect-book-action-alist full-book-string ctx state) (cond ((null cert-obj) (value nil)) ((not (include-book-alist-subsetp (unmark-and-delete-local-included-books (cdr post-alist)) actual-alist)) (let ((warning-summary (include-book-er-warning-summary :uncertified-okp suspect-book-action-alist state))) (cond ((and (equal warning-summary "Uncertified") (warning-disabled-p "Uncertified")) (value nil)) (t (mv-let (msgs state) (tilde-*-book-hash-phrase (unmark-and-delete-local-included-books (cdr post-alist)) actual-alist state) (include-book-er1 full-book-string nil (cons "After processing the events in the book ~x0:~*3." (list (cons #\3 msgs))) warning-summary ctx state)))))) (t (value t))))
include-book-certification-tuplefunction
(defun include-book-certification-tuple (certified-p cert-full-book-name full-book-name user-book-name familiar-name cert-annotations ev-lst-book-hash) (cond (certified-p (list* cert-full-book-name user-book-name familiar-name cert-annotations ev-lst-book-hash)) (t (list* full-book-name user-book-name familiar-name nil nil))))
include-book-pcert-pfunction
(defun include-book-pcert-p (certified-p cert-obj full-book-string ctx state) (cond ((and certified-p (access cert-obj cert-obj :pcert-info)) (pprogn (cond ((or (pcert-op-p (cert-op state)) (warning-off-p "Provisionally certified" state)) state) (t (mv-let (erp pcert-envp state) (getenv! "ACL2_PCERT" state) (assert$ (not erp) (cond (pcert-envp state) (t (warning$ ctx ("Provisionally certified") "The book ~s0 was only provisionally certified ~ (proofs ~s1)." full-book-string (if (eq (access cert-obj cert-obj :pcert-info) :proved) "completed" "skipped")))))))) (value t))) (t (value nil))))
include-book-install-eventfunction
(defun include-book-install-event (certified-p behalf-of-certify-flg cert-obj cddr-event-form full-book-string cert-full-book-name full-book-name old-include-book-path certification-tuple post-alist ttags-info old-ttags-seen saved-acl2-defaults-table old-skip-proofs-seen cert-obj-skipped-proofsp ctx wrld3 state) (er-let* ((declaim-list (get-declaim-list state)) (pcert-p (include-book-pcert-p certified-p cert-obj full-book-string ctx state))) (install-event (if behalf-of-certify-flg declaim-list (let ((name (or cert-full-book-name full-book-name))) (if (f-get-global 'script-mode state) name (book-name-to-filename name wrld3 ctx)))) (list* 'include-book (remove-lisp-suffix (if cert-full-book-name (book-name-to-filename cert-full-book-name wrld3 ctx) full-book-string) t) cddr-event-form) 'include-book full-book-string nil nil t ctx (let* ((wrld4 (update-pcert-books full-book-name pcert-p (global-set 'include-book-path old-include-book-path (global-set 'certification-tuple certification-tuple (global-set 'include-book-alist (add-to-set-equal certification-tuple (global-val 'include-book-alist wrld3)) (global-set 'include-book-alist-all (add-to-set-equal certification-tuple (accumulate-post-alist (cdr post-alist) (global-val 'include-book-alist-all wrld3))) wrld3)))))) (wrld5 (if ttags-info (global-set? 'ttags-seen (cdr ttags-info) wrld4 old-ttags-seen) wrld4)) (wrld6 (if (equal (table-alist 'acl2-defaults-table wrld3) saved-acl2-defaults-table) wrld5 (putprop 'acl2-defaults-table 'table-alist saved-acl2-defaults-table wrld5))) (wrld7 (cond ((or old-skip-proofs-seen (not certified-p)) wrld6) (t (let ((full-book-name (if cert-obj-skipped-proofsp full-book-name (skipped-proofsp-in-post-alist post-alist)))) (if full-book-name (global-set 'skip-proofs-seen (list :include-book full-book-name) wrld6) (if (global-val 'skip-proofs-seen wrld3) (global-set 'skip-proofs-seen nil wrld6) wrld6)))))) (wrld8 (if (equal full-book-name *projects/apply/base-sysfile*) (global-set 'projects/apply/base-includedp t wrld7) wrld7))) wrld8) state)))
include-book-fn1function
(defun include-book-fn1 (user-book-name state load-compiled-file expansion-alist/cert-data uncertified-okp defaxioms-okp skip-proofs-okp ttags ctx full-book-string full-book-name directory-name familiar-name cddr-event-form) (declare (ignore load-compiled-file)) (let* ((wrld1 (w state)) (behalf-of-certify-flg (consp expansion-alist/cert-data)) (old-skip-proofs-seen (global-val 'skip-proofs-seen wrld1)) (active-book-name (active-book-name wrld1 state)) (old-ttags-seen (global-val 'ttags-seen wrld1)) (old-include-book-path (global-val 'include-book-path wrld1)) (saved-acl2-defaults-table (table-alist 'acl2-defaults-table wrld1)) (uncertified-okp-effective (if (member-eq (cert-op state) '(nil :write-acl2xu)) uncertified-okp nil)) (suspect-book-action-alist (list (cons :uncertified-okp uncertified-okp-effective) (cons :defaxioms-okp defaxioms-okp) (cons :skip-proofs-okp skip-proofs-okp))) (include-book-alist0 (global-val 'include-book-alist wrld1))) (revert-world-on-error (cond ((and (not (f-get-global 'boot-strap-flg state)) full-book-name (assoc-equal full-book-name include-book-alist0)) (stop-redundant-event ctx state)) (t (let ((wrld2 (global-set 'include-book-path (cons full-book-name old-include-book-path) wrld1))) (pprogn (set-w 'extension wrld2 state) (er-let* ((cert-obj-prelim (include-book-cert-obj-prelim behalf-of-certify-flg uncertified-okp-effective full-book-string full-book-name suspect-book-action-alist directory-name ctx wrld1 state)) (cert-data-prelim (value (if cert-obj-prelim (access cert-obj cert-obj-prelim :cert-data) (cdr expansion-alist/cert-data))))) (fast-alist-free-cert-data-on-exit cert-data-prelim (er-let* ((redef (chk-new-stringp-name 'include-book full-book-name ctx wrld2 state)) (post-alist-prelim (value (and cert-obj-prelim (access cert-obj cert-obj-prelim :post-alist)))) (cert-full-book-name-prelim (value (car (car post-alist-prelim))))) (cond ((and cert-full-book-name-prelim (not (equal full-book-name cert-full-book-name-prelim)) (not (f-get-global 'boot-strap-flg state)) (assoc-equal cert-full-book-name-prelim include-book-alist0)) (pprogn (set-w 'retraction wrld1 state) (stop-redundant-event ctx state))) (t (er-let* ((ignored-val (cond ((or cert-obj-prelim behalf-of-certify-flg (not (f-get-global 'port-file-enabled state))) (value nil)) (t (eval-port-file full-book-string ctx state)))) (ev-lst (read-object-file full-book-string ctx state)) (post-alist-book-hash-prelim (value (cddddr (car post-alist-prelim)))) (ev-lst-book-hash (if cert-obj-prelim (book-hash post-alist-book-hash-prelim full-book-string (access cert-obj cert-obj-prelim :cmds) (access cert-obj cert-obj-prelim :expansion-alist) cert-data-prelim ev-lst state) (value nil))) (ok-familiar-name-and-hash (include-book-ok-familiar-name-and-hash cert-obj-prelim post-alist-prelim familiar-name full-book-string post-alist-book-hash-prelim ev-lst-book-hash suspect-book-action-alist ctx state))) (let* ((cert-obj (and ok-familiar-name-and-hash cert-obj-prelim)) (cert-data (and (or cert-obj behalf-of-certify-flg) cert-data-prelim)) (post-alist (and cert-obj post-alist-prelim)) (expansion-alist (cond (behalf-of-certify-flg (car expansion-alist/cert-data)) (cert-obj (access cert-obj cert-obj :expansion-alist)) (t nil))) (cert-annotations (cadddr (car post-alist))) (cert-ttags (cdr (assoc-eq :ttags cert-annotations))) (cert-obj-skipped-proofsp (and cert-obj (cdr (assoc-eq :skipped-proofsp cert-annotations)))) (warn-for-ttags-default (and (eq ttags :default) (not (warning-off-p "Ttags" state)))) (ttags (if (eq ttags :default) :all ttags))) (er-let* ((ttags (chk-well-formed-ttags ttags directory-name ctx state)) (ignored-val (cond ((or cert-obj-skipped-proofsp (and cert-obj (cdr (assoc-eq :axiomsp cert-annotations)))) (chk-cert-annotations cert-annotations nil (access cert-obj cert-obj :cmds) full-book-string suspect-book-action-alist ctx state)) (t (value nil)))) (ttags-info (cond ((not cert-obj) (value nil)) (t (er-progn (chk-acceptable-ttags1 cert-ttags nil ttags nil :quiet ctx state) (chk-acceptable-ttags1 cert-ttags active-book-name (f-get-global 'ttags-allowed state) old-ttags-seen (if warn-for-ttags-default (cons ctx full-book-string) t) ctx state))))) (skip-proofsp (value 'include-book)) (ttags-allowed1 (include-book-process-embedded-events ev-lst directory-name ttags-info cert-obj cert-ttags cert-data behalf-of-certify-flg full-book-string full-book-name skip-proofsp expansion-alist ctx state))) (let* ((wrld3 (w state)) (actual-alist (global-val 'include-book-alist wrld3))) (er-let* ((certified-p (include-book-certified-p cert-obj post-alist actual-alist suspect-book-action-alist full-book-string ctx state)) (cert-obj-skipped-proofsp (value (and certified-p cert-obj-skipped-proofsp))) (post-alist (value (and certified-p post-alist))) (ttags-info (value (and certified-p ttags-info)))) (er-progn (chk-cert-annotations-post-alist (cdr post-alist) (and certified-p (access cert-obj cert-obj :cmds)) full-book-string suspect-book-action-alist ctx state) (let* ((cert-full-book-name (cond (certified-p cert-full-book-name-prelim) (t full-book-name))) (certification-tuple (include-book-certification-tuple certified-p cert-full-book-name full-book-name user-book-name familiar-name (and certified-p (cadddr (car post-alist))) ev-lst-book-hash))) (er-progn (pprogn (redefined-warning redef ctx state) (if certified-p (f-put-global 'ttags-allowed ttags-allowed1 state) state) (include-book-install-event certified-p behalf-of-certify-flg cert-obj cddr-event-form full-book-string cert-full-book-name full-book-name old-include-book-path certification-tuple post-alist ttags-info old-ttags-seen saved-acl2-defaults-table old-skip-proofs-seen cert-obj-skipped-proofsp ctx wrld3 state))))))))))))))))))))))
chk-include-book-inputsfunction
(defun chk-include-book-inputs (load-compiled-file uncertified-okp defaxioms-okp skip-proofs-okp ctx state) (let ((er-str "The ~x0 argument of include-book must be ~v1. The value ~x2 ~ is thus illegal. See :DOC include-book.")) (cond ((not (member-eq load-compiled-file *load-compiled-file-values*)) (er soft ctx er-str :load-compiled-file *load-compiled-file-values* load-compiled-file)) ((not (member-eq uncertified-okp '(t nil :ignore-certs))) (er soft ctx er-str :uncertified-okp '(t nil :ignore-certs) uncertified-okp)) ((not (member-eq defaxioms-okp '(t nil))) (er soft ctx er-str :defaxioms-okp '(t nil) defaxioms-okp)) ((not (member-eq skip-proofs-okp '(t nil))) (er soft ctx er-str :skip-proofs-okp '(t nil) skip-proofs-okp)) (t (value nil)))))
include-book-fnfunction
(defun include-book-fn (user-book-name state load-compiled-file expansion-alist/cert-data uncertified-okp defaxioms-okp skip-proofs-okp ttags dir event-form) (with-ctx-summarized (cons 'include-book user-book-name) (state-global-let* ((compiler-enabled (f-get-global 'compiler-enabled state)) (port-file-enabled (f-get-global 'port-file-enabled state)) (warnings-as-errors nil)) (pprogn (cond ((and (not (eq load-compiled-file :default)) (not (eq load-compiled-file nil)) (not (f-get-global 'compiler-enabled state))) (warning$ ctx "Compiled file" "Ignoring value ~x0 supplied for include-book keyword ~ parameter :LOAD-COMPILED-FILE, treating it as ~x1 ~ instead, because of an earlier evaluation of ~x2; see ~ :DOC compilation." load-compiled-file nil '(set-compiler-enabled nil state))) (t state)) (er-let* ((dir-value (cond (dir (include-book-dir-with-chk soft ctx dir)) (t (value (cbd)))))) (mv-let (full-book-string full-book-name directory-name familiar-name) (parse-book-name dir-value user-book-name ".lisp" ctx state) (er-progn (chk-input-object-file full-book-string ctx state) (chk-include-book-inputs load-compiled-file uncertified-okp defaxioms-okp skip-proofs-okp ctx state) (state-global-let* ((ignore-cert-files (or (f-get-global 'ignore-cert-files state) (and (eq uncertified-okp :ignore-certs) full-book-name)))) (let* ((behalf-of-certify-flg (not (null expansion-alist/cert-data))) (load-compiled-file0 load-compiled-file) (load-compiled-file (and (f-get-global 'compiler-enabled state) load-compiled-file)) (cddr-event-form (if (and event-form (eq load-compiled-file0 load-compiled-file)) (cddr event-form) (append (if (not (eq load-compiled-file :default)) (list :load-compiled-file load-compiled-file) nil) (if (not (eq uncertified-okp t)) (list :uncertified-okp uncertified-okp) nil) (if (not (eq defaxioms-okp t)) (list :defaxioms-okp defaxioms-okp) nil) (if (not (eq skip-proofs-okp t)) (list :skip-proofs-okp skip-proofs-okp) nil))))) (cond ((or behalf-of-certify-flg (null load-compiled-file)) (include-book-fn1 user-book-name state load-compiled-file expansion-alist/cert-data uncertified-okp defaxioms-okp skip-proofs-okp ttags ctx full-book-string full-book-name directory-name familiar-name cddr-event-form)) (t (let nil (include-book-fn1 user-book-name state load-compiled-file expansion-alist/cert-data uncertified-okp defaxioms-okp skip-proofs-okp ttags ctx full-book-string full-book-name directory-name familiar-name cddr-event-form)))))))))))))
spontaneous-decertificationp1function
(defun spontaneous-decertificationp1 (ibalist alist files) (cond ((endp ibalist) files) (t (let* ((familiar-name1 (caddr (car ibalist))) (cert-annotations1 (cadddr (car ibalist))) (book-hash1 (cddddr (car ibalist))) (temp (assoc-equal familiar-name1 alist)) (cert-annotations2 (cadr temp)) (book-hash2 (cddr temp))) (cond (temp (cond ((equal (cddr (car ibalist)) temp) (spontaneous-decertificationp1 (cdr ibalist) alist files)) ((and (or (null cert-annotations1) (equal cert-annotations1 cert-annotations2)) (equal book-hash1 nil) book-hash2) (spontaneous-decertificationp1 (cdr ibalist) alist (cons (car (car ibalist)) files))) (t nil))) (t nil))))))
spontaneous-decertificationpfunction
(defun spontaneous-decertificationp (alist1 alist2) (spontaneous-decertificationp1 alist1 (strip-cddrs alist2) nil))
remove-duplicates-equal-from-endfunction
(defun remove-duplicates-equal-from-end (lst acc) (cond ((endp lst) (reverse acc)) ((member-equal (car lst) acc) (remove-duplicates-equal-from-end (cdr lst) acc)) (t (remove-duplicates-equal-from-end (cdr lst) (cons (car lst) acc)))))
include-book-alist-subsetp-failure-witnessesfunction
(defun include-book-alist-subsetp-failure-witnesses (alist1 strip-cddrs-alist2 acc) (cond ((endp alist1) acc) (t (include-book-alist-subsetp-failure-witnesses (cdr alist1) strip-cddrs-alist2 (if (member-equal (cddr (car alist1)) strip-cddrs-alist2) acc (cons (car alist1) acc))))))
expansion-filenamefunction
(defun expansion-filename (file) (let ((len (length file))) (assert$ (equal (subseq file (- len 5) len) ".lisp") (concatenate 'string (subseq file 0 (- len 5)) "@expansion.lsp"))))
*elided-defconst*constant
(defconst *elided-defconst* 'elided-defconst)
elided-defconst-formfunction
(defun elided-defconst-form (ev index) `(defconst ,(CADR EV) (cadr ,(LIST *ELIDED-DEFCONST* (LIST 'QUOTE (CADR EV)) INDEX))))
subst-by-position-eliding-defconst2mutual-recursion
(mutual-recursion (defun subst-by-position-eliding-defconst2 (ev index) (case (car ev) (defconst (if (defconst-form-to-elide ev) (elided-defconst-form ev index) ev)) (progn (cons 'progn (subst-by-position-eliding-defconst2-lst (cdr ev) index))) (encapsulate (list* 'encapsulate (cadr ev) (subst-by-position-eliding-defconst2-lst (cddr ev) index))) ((record-expansion with-guard-checking) (subst-by-position-eliding-defconst2 (caddr ev) index)) (skip-proofs (subst-by-position-eliding-defconst2 (cadr ev) index)) ((with-output with-prover-step-limit) (subst-by-position-eliding-defconst2 (car (last ev)) index)) (otherwise ev))) (defun subst-by-position-eliding-defconst2-lst (lst index) (cond ((endp lst) nil) (t (cons (subst-by-position-eliding-defconst2 (car lst) index) (subst-by-position-eliding-defconst2-lst (cdr lst) index))))))
subst-by-position-eliding-defconst1function
(defun subst-by-position-eliding-defconst1 (alist lst index acc) (cond ((endp alist) (revappend acc lst)) ((endp lst) (er hard 'subst-by-position-eliding-defconst1 "Implementation error: lst is an atom, so unable to complete ~ call ~x0." `(subst-by-position-eliding-defconst1 ,ALIST ,LST ,INDEX ,ACC))) ((eql index (caar alist)) (let ((ev (cdar alist))) (subst-by-position-eliding-defconst1 (cdr alist) (cdr lst) (1+ index) (cons (subst-by-position-eliding-defconst2 ev index) acc)))) (t (subst-by-position-eliding-defconst1 alist (cdr lst) (1+ index) (cons (car lst) acc)))))
subst-by-position-eliding-defconstfunction
(defun subst-by-position-eliding-defconst (alist lst index) (cond (alist (cond ((< (caar alist) index) (er hard 'subst-by-position-eliding-defconst "Implementation error: The alist in ~ subst-by-position-eliding-defconst must not start with ~ an index less than its index argument, so unable to ~ compute ~x0." `(subst-by-position-eliding-defconst ,ALIST ,LST ,INDEX))) (t (subst-by-position-eliding-defconst1 alist lst index nil)))) (t lst)))
write-expansion-filefunction
(defun write-expansion-file (portcullis-cmds declaim-list new-fns-exec compressed-cltl-command-stack expansion-filename expansion-alist pkg-names ev-lst known-package-alist ctx state) (declare (ignore new-fns-exec compressed-cltl-command-stack pkg-names known-package-alist)) (with-output-object-channel-sharing ch expansion-filename (cond ((null ch) (er soft ctx "We cannot open expansion file ~s0 for output." expansion-filename)) (t (with-print-defaults ((current-package "ACL2") (print-circle (f-get-global 'print-circle-files state)) (print-readably t)) (pprogn (io? event nil state (expansion-filename) (fms! "Note: Writing book expansion file, ~s0." (list (cons #\0 expansion-filename)) (proofs-co state) state nil)) (print-object$ '(in-package "ACL2") ch state) (print-object$ '(hcomp-init) ch state) (newline ch state) (cond (declaim-list (pprogn (princ$ ";;; Declaim forms:" ch state) (newline ch state) (princ$ (concatenate 'string "#+" (symbol-name (f-get-global 'host-lisp state))) ch state) (print-object$ (cons 'progn (reverse declaim-list)) ch state))) (t (princ$ ";;; Note: There are no declaim forms to print." ch state))) (print-object$ (cons 'progn (append portcullis-cmds (subst-by-position-eliding-defconst expansion-alist (cdr ev-lst) 1))) ch state) (newline ch state) (close-output-channel ch state) (value expansion-filename)))))))
collect-ideal-user-defuns1function
(defun collect-ideal-user-defuns1 (tl wrld ans) (cond ((or (null tl) (and (eq (caar tl) 'command-landmark) (eq (cadar tl) 'global-value) (equal (access-command-tuple-form (cddar tl)) '(exit-boot-strap-mode)))) ans) ((and (eq (caar tl) 'cltl-command) (eq (cadar tl) 'global-value) (equal (caddar tl) 'defuns)) (collect-ideal-user-defuns1 (cdr tl) wrld (cond ((null (cadr (cddar tl))) ans) ((eq (symbol-class (caar (cdddr (cddar tl))) wrld) :ideal) (append (strip-cars (cdddr (cddar tl))) ans)) (t ans)))) (t (collect-ideal-user-defuns1 (cdr tl) wrld ans))))
collect-ideal-user-defunsfunction
(defun collect-ideal-user-defuns (wrld) (collect-ideal-user-defuns1 wrld wrld nil))
set-difference-eq-sortedfunction
(defun set-difference-eq-sorted (lst1 lst2 ans) (cond ((null lst1) (reverse ans)) ((null lst2) (revappend ans lst1)) ((eq (car lst1) (car lst2)) (set-difference-eq-sorted (cdr lst1) (cdr lst2) ans)) ((symbol< (car lst1) (car lst2)) (set-difference-eq-sorted (cdr lst1) lst2 (cons (car lst1) ans))) (t (set-difference-eq-sorted lst1 (cdr lst2) ans))))
pkg-names0function
(defun pkg-names0 (x base-kpa acc) (cond ((consp x) (pkg-names0 (cdr x) base-kpa (pkg-names0 (car x) base-kpa acc))) ((and x (symbolp x)) (let ((name (symbol-package-name x))) (cond ((or (member-equal name acc) (find-package-entry name base-kpa)) acc) (t (cons name acc))))) (t acc)))
hons-union-ordered-string-listsfunction
(defun hons-union-ordered-string-lists (x y) (cond ((null x) y) ((null y) x) ((hons-equal x y) x) ((hons-equal (car x) (car y)) (hons (car x) (hons-union-ordered-string-lists (cdr x) (cdr y)))) ((string< (car x) (car y)) (hons (car x) (hons-union-ordered-string-lists (cdr x) y))) (t (hons (car y) (hons-union-ordered-string-lists x (cdr y))))))
pkg-namesfunction
(defun pkg-names (x base-kpa) (cond ((null x) nil) (t (merge-sort-lexorder (pkg-names0 x base-kpa nil)))))
delete-names-from-kpa-recfunction
(defun delete-names-from-kpa-rec (names kpa) (cond ((endp kpa) nil) ((member-equal (package-entry-name (car kpa)) names) (delete-names-from-kpa-rec names (cdr kpa))) (t (cons (car kpa) (delete-names-from-kpa-rec names (cdr kpa))))))
delete-names-from-kpafunction
(defun delete-names-from-kpa (names kpa) (cond ((null names) kpa) (t (delete-names-from-kpa-rec names kpa))))
print-certify-book-step-2function
(defun print-certify-book-step-2 (ev-lst expansion-alist pcert0-file acl2x-file state) (io? event nil state (ev-lst expansion-alist pcert0-file acl2x-file) (fms "* Step 2: There ~#0~[were no forms in the file. Why are you ~ making such a silly book?~/was one form in the file.~/were ~n1 ~ forms in the file.~] We now attempt to establish that each ~ form, whether local or non-local, is indeed an admissible ~ embedded event form in the context of the previously admitted ~ ones.~@2~%" (list (cons #\0 (zero-one-or-more ev-lst)) (cons #\1 (length ev-lst)) (cons #\2 (cond (expansion-alist (msg " Note that we are substituting ~n0 ~ ~#1~[form~/forms~], as specified in ~ file~#2~[~x2~/s ~&2~], for ~#1~[a ~ corresponding top-level ~ form~/corresponding top-level forms~] in ~ the book." (length expansion-alist) expansion-alist (if pcert0-file (if acl2x-file (list pcert0-file acl2x-file) (list pcert0-file)) (list acl2x-file)))) (t "")))) (proofs-co state) state nil)))
print-certify-book-step-3function
(defun print-certify-book-step-3 (index port-index port-non-localp state) (io? event nil state (index port-index port-non-localp) (cond (index (assert$ (and (posp index) (null port-index)) (fms "* Step 3: That completes the admissibility check. Each form ~ read was an embedded event form and was admissible. We now ~ retract back to the ~#0~[initial world~/world created by ~ admitting the first event~/world created by the first ~n1 ~ events~]~#2~[~/ after the initial IN-PACKAGE form~] and try ~ to include~#2~[~/ the remainder of~] the book; see :DOC ~ local-incompatibility.~%" (list (cons #\0 (zero-one-or-more (1- index))) (cons #\1 (1- index)) (cons #\2 (if (int= 1 index) 0 1))) (proofs-co state) state nil))) (port-index (fms "* Step 3: That completes the admissibility check. Each form ~ read was an embedded event form and was admissible. We now ~ retract the world, back through the ~n0 command after the ~ initial (boot-strap) world.~@1 Next we will try to execute the ~ remainder of the events in the certification world, and ~ finally we will try to include the book; see :DOC ~ local-incompatibility.~%" (list (cons #\0 (list (1+ port-index))) (cons #\1 (if port-non-localp (msg " Note that the rollback is caused by ~ evaluation of an event after relaxing ~ guard-checking from its default of T.") ""))) (proofs-co state) state nil)) ((eq (fast-cert-mode state) t) (fms "* Step 3: That completes the admissibility check. Each form ~ read was an embedded event form and was admissible. Fast-cert ~ mode is active, so we skip the check for local ~ incompatibilities.~%" nil (proofs-co state) state nil)) (t (fms "* Step 3: That completes the admissibility check. Each form ~ read was an embedded event form and was admissible. No LOCAL ~ or SET-GUARD-CHECKING forms make it necessary to check for ~ local incompatibilities, so we skip that check.~%" nil (proofs-co state) state nil)))))
print-certify-book-guards-warningfunction
(defun print-certify-book-guards-warning (full-book-string new-bad-fns all-bad-fns k ctx state) (let* ((new-bad-fns (sort-symbol-listp new-bad-fns)) (all-bad-fns (sort-symbol-listp all-bad-fns)) (extra-bad-fns (set-difference-eq-sorted all-bad-fns new-bad-fns nil))) (warning$ ctx ("Guards") "~#1~[~/The book ~x0 defines the function~#2~[ ~&2, which has ~ not had its~/s ~&2, which have not had their~] guards ~ verified. ~]~#3~[~/~#1~[For the book ~x0, its~/Moreover, this ~ book's~] included sub-books ~#4~[~/and/or its certification ~ world ~]define function~#5~[ ~&5, which has not had its~/s ~ ~&5, which have not had their~] guards verified. ~]See :DOC ~ guards." full-book-string (if new-bad-fns 1 0) new-bad-fns (if extra-bad-fns 1 0) (if (eql k 0) 0 1) extra-bad-fns)))
chk-certify-book-step-3function
(defun chk-certify-book-step-3 (post-alist2 post-alist1 ctx state) (cond ((not (include-book-alist-subsetp post-alist2 post-alist1)) (let ((files (spontaneous-decertificationp post-alist2 post-alist1))) (cond (files (er soft ctx "During Step 3, we loaded the uncertified ~#0~[book ~&0. This ~ book was certified when we looked at it~/books ~&0. These books ~ were certified when we looked at them~] in Step 2! The most ~ likely explanation is that some concurrent job, possibly by ~ another user of your file system, is currently recertifying ~ ~#0~[this book~/these books~] (or subbooks of ~#0~[it~/them~]). ~ That hypothetical job might have deleted the certificate files ~ of the books in question, rendering ~#0~[this one~/these~] ~ uncertified. If this explanation seems likely, we recommend ~ that you identify the other job and wait until it has ~ successfully completed." files)) (t (er soft ctx "During Step 3, we loaded different books than were loaded by ~ Step 2! Sometimes this happens when the meaning of ``:dir ~ :system'' for include-book has changed, usually because some ~ included books were previously certified with an ACL2 image ~ whose filename differs from that of the current ACL2 image. ~ Here are the tuples produced by Step 3 of the form ~X04 whose ~ CDDRs are not in the list of tuples produced by Step ~ 2:~|~%~X14~|~%Perhaps some other user of your file system was ~ editing the books during our Step 3? You might think that some ~ other job is recertifying the books (or subbooks) and has ~ deleted the certificate files, rendering uncertified some of the ~ books needed here. But more has happened! Some file has ~ changed (as indicated above)!~%~%DETAILS. Here is the ~ include-book-alist as of the end of Step 2:~%~X24.~|~%And here ~ is the alist as of the end of Step 3:~%~X34.~|~%Frequently, the ~ former has more entries than the latter because the former ~ includes LOCAL books. So compare corresponding entries, focusing ~ on those in the latter. Each entry is of the form (name1 name2 ~ name3 alist . book-hash). Name1 is the full name, name2 is the ~ name as written in an include-book event, and name3 is the ~ ``familiar'' name of the file. The alist indicates the presence ~ or absence of problematic forms in the file, such as DEFAXIOM ~ events. For example, (:AXIOMSP . T) means there were defaxiom ~ events; (:AXIOMSP . NIL) -- which actually prints as (:AXIOMSP) ~ -- means there were no defaxiom events. Finally, book-hash is ~ either an integer checksum based on the contents of the file at ~ the time it was certified, an alist indicating the size and ~ write-date of the book, or nil to indicate that the file is not ~ certified. Note that if the book-hash is nil, the entry prints ~ as (name1 name2 name3 alist). Go figure." '(:full-book-name :user-book-name :familiar-name :cert-annotations . :book-hash) (include-book-alist-subsetp-failure-witnesses post-alist2 (strip-cddrs post-alist1) nil) post-alist1 post-alist2 nil))))) (t (value nil))))
print-certify-book-step-4function
(defun print-certify-book-step-4 (full-book-string cert-op state) (io? event nil state (full-book-string cert-op) (fms "* Step 4: Write the certificate for ~x0 in ~x1.~%" (list (cons #\0 full-book-string) (cons #\1 (convert-book-string-to-cert full-book-string cert-op))) (proofs-co state) state nil)))
print-certify-book-step-5function
(defun print-certify-book-step-5 (full-book-string state) (io? event nil state (full-book-string) (fms "* Step 5: Compile the functions defined in ~x0.~%" (list (cons #\0 full-book-string)) (proofs-co state) state nil)))
hcomp-build-from-statefunction
(defun hcomp-build-from-state (cltl-command-stack state) (declare (ignore cltl-command-stack)) (value nil))
hons-copy-with-statefunction
(defun hons-copy-with-state (x state) (declare (xargs :guard (state-p state))) (declare (ignore state)) (hons-copy x))
identity-with-statefunction
(defun identity-with-state (x state) (declare (xargs :guard (state-p state))) (declare (ignore state)) x)
other
(defattach (acl2x-expansion-alist identity-with-state) :skip-checks t)
write-acl2x-filefunction
(defun write-acl2x-file (expansion-alist acl2x-file ctx state) (with-output-object-channel-sharing ch acl2x-file (cond ((null ch) (er soft ctx "We cannot open file ~x0 for output." acl2x-file)) (t (with-print-defaults ((current-package "ACL2") (print-circle (f-get-global 'print-circle-files state)) (print-readably t)) (pprogn (io? event nil state (acl2x-file) (fms "* Step 3: Writing file ~x0 and exiting certify-book.~|" (list (cons #\0 acl2x-file)) (proofs-co state) state nil)) (print-object$ (acl2x-expansion-alist expansion-alist state) ch state) (close-output-channel ch state) (value acl2x-file)))))))
merge-into-expansion-alist1function
(defun merge-into-expansion-alist1 (acl2x-expansion-alist computed-expansion-alist acc) (declare (xargs :measure (+ (len acl2x-expansion-alist) (len computed-expansion-alist)))) (cond ((endp acl2x-expansion-alist) (revappend acc computed-expansion-alist)) ((endp computed-expansion-alist) (revappend acc acl2x-expansion-alist)) ((eql (caar acl2x-expansion-alist) (caar computed-expansion-alist)) (merge-into-expansion-alist1 (cdr acl2x-expansion-alist) (cdr computed-expansion-alist) (cons (car computed-expansion-alist) acc))) ((< (caar acl2x-expansion-alist) (caar computed-expansion-alist)) (merge-into-expansion-alist1 (cdr acl2x-expansion-alist) computed-expansion-alist (cons (car acl2x-expansion-alist) acc))) (t (merge-into-expansion-alist1 acl2x-expansion-alist (cdr computed-expansion-alist) (cons (car computed-expansion-alist) acc)))))
acl2x-alistp-domains-subsetpfunction
(defun acl2x-alistp-domains-subsetp (x y) (cond ((null x) t) ((endp y) nil) ((eql (caar x) (caar y)) (acl2x-alistp-domains-subsetp (cdr x) (cdr y))) ((< (caar x) (caar y)) nil) (t (acl2x-alistp-domains-subsetp x (cdr y)))))
merge-into-expansion-alistfunction
(defun merge-into-expansion-alist (acl2x-expansion-alist computed-expansion-alist) (cond ((atom computed-expansion-alist) acl2x-expansion-alist) ((acl2x-alistp-domains-subsetp acl2x-expansion-alist computed-expansion-alist) computed-expansion-alist) (t (merge-into-expansion-alist1 acl2x-expansion-alist computed-expansion-alist nil))))
restrict-expansion-alistfunction
(defun restrict-expansion-alist (index expansion-alist) (cond ((endp expansion-alist) nil) ((< (caar expansion-alist) index) (restrict-expansion-alist index (cdr expansion-alist))) (t expansion-alist)))
elide-locals-from-expansion-alistfunction
(defun elide-locals-from-expansion-alist (alist acc) (cond ((endp alist) (reverse acc)) (t (elide-locals-from-expansion-alist (cdr alist) (cons (cons (caar alist) (elide-locals (cdar alist))) acc)))))
write-port-filefunction
(defun write-port-file (full-book-string cmds ctx state) (let ((port-file (convert-book-string-to-port full-book-string))) (with-output-object-channel-sharing ch port-file (cond ((null ch) (er soft ctx "We cannot open file ~x0 for output." port-file)) (t (pprogn (io? event nil state (port-file) (fms! "Note: Writing .port file, ~s0.~|" (list (cons #\0 port-file)) (proofs-co state) state nil)) (with-print-defaults ((current-package "ACL2") (print-circle (f-get-global 'print-circle-files state)) (print-readably t)) (pprogn (print-object$ '(in-package "ACL2") ch state) (print-objects cmds ch state) (close-output-channel ch state) (value port-file)))))))))
save-parallelism-settingsmacro
(defmacro save-parallelism-settings (form) form)
include-book-alist-equal-modulo-localfunction
(defun include-book-alist-equal-modulo-local (old-post-alist new-post-alist) (cond ((atom old-post-alist) (atom new-post-alist)) ((atom new-post-alist) nil) ((and (consp (car old-post-alist)) (eq (car (car old-post-alist)) 'local)) (and (equal (cadr (car old-post-alist)) (car new-post-alist)) (include-book-alist-equal-modulo-local (cdr old-post-alist) (cdr new-post-alist)))) ((equal (car old-post-alist) (car new-post-alist)) (include-book-alist-equal-modulo-local (cdr old-post-alist) (cdr new-post-alist))) (t nil)))
copy-object-channel-until-markerfunction
(defun copy-object-channel-until-marker (marker ch-from ch-to state) (mv-let (eofp obj state) (read-object ch-from state) (cond ((or eofp (eq obj marker)) state) (t (pprogn (print-object$ obj ch-to state) (copy-object-channel-until-marker marker ch-from ch-to state))))))
copy-pcert0-to-pcert1function
(defun copy-pcert0-to-pcert1 (from to ctx state) (mv-let (ch-from state) (open-input-channel from :object state) (cond ((null ch-from) (er soft ctx "Unable to open file ~x0 for input (to copy to file ~x1)." from to)) (t (with-output-object-channel-sharing ch-to to (with-print-defaults ((current-package "ACL2") (print-circle (f-get-global 'print-circle-files state)) (print-readably t)) (cond ((null ch-to) (pprogn (close-input-channel ch-from state) (er soft ctx "Unable to open file ~x0 for output (to copy ~ into from file ~x1)." to from))) (t (pprogn (copy-object-channel-until-marker :pcert-info ch-from ch-to state) (close-input-channel ch-from state) (close-output-channel ch-to state) (value :invisible))))))))))
touch?function
(defun touch? (filename old-filename ctx state) (cond ((null old-filename) (value (sys-call "touch" (list filename)))) (t (mv-let (old-filename-date state) (file-write-date$ old-filename state) (mv-let (filename-date state) (file-write-date$ filename state) (cond ((and old-filename-date filename-date (<= old-filename-date filename-date)) (prog2$ (sys-call "touch" (list filename)) (mv-let (status state) (sys-call-status state) (cond ((zerop status) (value nil)) (t (er soft ctx "Obtained non-zero exit status ~x0 ~ when attempting to touch file ~x0 ." status filename)))))) (t (value nil))))))))
convert-book-string-to-compiledfunction
(defun convert-book-string-to-compiled (full-book-string state) (concatenate 'string (remove-lisp-suffix full-book-string nil) (f-get-global 'compiled-file-extension state)))
certify-book-finish-convertfunction
(defun certify-book-finish-convert (new-post-alist old-post-alist full-book-string ctx state) (cond ((include-book-alist-equal-modulo-local old-post-alist new-post-alist) (let ((pcert0-name (convert-book-string-to-cert full-book-string :create-pcert)) (pcert1-name (convert-book-string-to-cert full-book-string :convert-pcert)) (compiled-name (convert-book-string-to-compiled full-book-string state))) (er-progn (copy-pcert0-to-pcert1 pcert0-name pcert1-name ctx state) (touch? compiled-name pcert0-name ctx state) (value pcert1-name)))) (t (er soft ctx "Two sequences of included books unexpectedly differ: one from ~ the first pass of the Pcertify procedure, and one at the end ~ of the Convert procedure. Here is the include-book-alist as ~ of the end of the first pass of the Pcertify ~ procedure:~%~X02.~|~%And here is the include-book-alist at ~ the end of Convert procedure:~%~X12." old-post-alist new-post-alist nil))))
include-book-alist-uncertified-booksfunction
(defun include-book-alist-uncertified-books (alist acc ctx wrld state) (cond ((endp alist) (value acc)) (t (let* ((entry0 (car alist)) (entry (if (eq (car entry0) 'local) (cadr entry0) entry0)) (full-book-string (book-name-to-filename (car entry) wrld ctx)) (cert-name (convert-book-string-to-cert full-book-string t))) (mv-let (book-date state) (file-write-date$ full-book-string state) (mv-let (cert-date state) (file-write-date$ cert-name state) (include-book-alist-uncertified-books (cdr alist) (cond ((and book-date cert-date (<= book-date cert-date)) acc) (t (cons full-book-string acc))) ctx wrld state)))))))
count-forms-in-channelfunction
(defun count-forms-in-channel (ch state n) (mv-let (eofp state) (read-object-suppress ch state) (cond (eofp (mv n state)) (t (count-forms-in-channel ch state (1+ n))))))
skip-forms-in-channelfunction
(defun skip-forms-in-channel (n ch state) (cond ((zp n) (mv nil state)) (t (mv-let (eofp state) (read-object-suppress ch state) (cond (eofp (mv eofp state)) (t (skip-forms-in-channel (1- n) ch state)))))))
post-alist-from-pcert1-1function
(defun post-alist-from-pcert1-1 (n first-try-p pcert1-file msg ctx state) (mv-let (chan state) (open-input-channel pcert1-file :object state) (cond ((null chan) (er soft ctx "~@0" msg)) (t (mv-let (eofp state) (skip-forms-in-channel n chan state) (cond (eofp (pprogn (close-input-channel chan state) (er soft ctx "Implementation error: Unexpected end of file, reading ~x0 ~ forms from file ~x1. Please contact the ACL2 implementors." n pcert1-file))) (t (mv-let (eofp post-alist state) (read-object chan state) (cond (eofp (er soft ctx "Implementation error: Unexpected end of file, reading ~x0 ~ forms and then one more form from file ~x1. Please ~ contact the ACL2 implementors." n pcert1-file)) ((eq post-alist :pcert-info) (pprogn (close-input-channel chan state) (cond (first-try-p (post-alist-from-pcert1-1 (- n 2) nil pcert1-file msg ctx state)) (t (er soft ctx "Implementation error: Unexpectedly we appear to have ~ two occurrences of :PCERT-INFO at the top level of ~ file ~x0, at positions ~x1 and ~x2." pcert1-file (+ n 2) n))))) (t (pprogn (close-input-channel chan state) (cond ((include-book-alistp post-alist t) (value post-alist)) (t (er soft ctx "Ill-formed post-alist encountered in ~ file ~x0:~|~x1" pcert1-file post-alist))))))))))))))
post-alist-from-pcert1function
(defun post-alist-from-pcert1 (pcert1-file msg ctx state) (mv-let (chan state) (open-input-channel pcert1-file :object state) (cond ((null chan) (er soft ctx "~@0" msg)) (t (mv-let (len state) (count-forms-in-channel chan state 0) (pprogn (close-input-channel chan state) (assert$ (<= 2 len) (post-alist-from-pcert1-1 (- len 2) t pcert1-file msg ctx state))))))))
certificate-post-alistfunction
(defun certificate-post-alist (pcert1-file cert-file full-book-name ctx state) (er-let* ((post-alist (post-alist-from-pcert1 pcert1-file (msg "Unable to open file ~x0 for input, hence cannot complete ~ its renaming to ~x1." pcert1-file cert-file) ctx state))) (cond ((equal (caar post-alist) full-book-name) (value post-alist)) (t (er soft ctx "Ill-formed post-alist encountered: expected its caar ~ to be the full-book-name ~x0, but the post-alist ~ encountered was ~x1." full-book-name post-alist)))))
certify-book-finish-completefunction
(defun certify-book-finish-complete (full-book-string full-book-name ctx state) (let ((pcert0-file (convert-book-string-to-cert full-book-string :create-pcert)) (pcert1-file (convert-book-string-to-cert full-book-string :convert-pcert)) (cert-file (convert-book-string-to-cert full-book-string t)) (compiled-file (convert-book-string-to-compiled full-book-string state)) (expansion-file (expansion-filename full-book-string))) (er-let* ((post-alist (certificate-post-alist pcert1-file cert-file full-book-name ctx state)) (uncertified-books (include-book-alist-uncertified-books (cdr post-alist) nil ctx (w state) state))) (cond (uncertified-books (er soft ctx "Unable to complete the renaming of ~x0 to ~x1, because ~ ~#2~[~/each of ~]the following included book~#2~[~/s~] does not ~ have a .cert file that is at least as recent as that included ~ book: ~&2." pcert1-file cert-file uncertified-books)) (t (pprogn (fms "Note: Renaming file ~x0 to ~x1.~|" (list (cons #\0 pcert1-file) (cons #\1 cert-file)) (standard-co state) state nil) (er-progn (touch? cert-file pcert0-file ctx state) (touch? compiled-file pcert0-file ctx state) (touch? expansion-file pcert0-file ctx state) (value cert-file))))))))
expansion-alist-conflictfunction
(defun expansion-alist-conflict (acl2x-expansion-alist elided-expansion-alist) (cond ((endp acl2x-expansion-alist) (mv nil nil)) ((endp elided-expansion-alist) (mv (car acl2x-expansion-alist) nil)) ((< (caar acl2x-expansion-alist) (caar elided-expansion-alist)) (mv (car acl2x-expansion-alist) nil)) ((eql (caar acl2x-expansion-alist) (caar elided-expansion-alist)) (cond ((equal (elide-locals (cdar acl2x-expansion-alist)) (cdar elided-expansion-alist)) (expansion-alist-conflict (cdr acl2x-expansion-alist) (cdr elided-expansion-alist))) (t (mv (car acl2x-expansion-alist) (car elided-expansion-alist))))) (t (expansion-alist-conflict (cdr acl2x-expansion-alist) elided-expansion-alist))))
symbol-package-name-setfunction
(defun symbol-package-name-set (syms acc) (declare (xargs :guard (and (symbol-listp syms) (true-listp acc)))) (cond ((endp syms) acc) (t (symbol-package-name-set (cdr syms) (add-to-set-equal (symbol-package-name (car syms)) acc)))))
names-of-symbols-in-packagefunction
(defun names-of-symbols-in-package (syms package acc) (declare (xargs :guard (symbol-listp syms))) (cond ((endp syms) acc) (t (names-of-symbols-in-package (cdr syms) package (if (equal (symbol-package-name (car syms)) package) (cons (symbol-name (car syms)) acc) acc)))))
symbol-list-to-package-alist1function
(defun symbol-list-to-package-alist1 (syms packages acc) (declare (xargs :guard (and (symbol-listp syms) (true-listp packages) (alistp acc)))) (cond ((endp packages) acc) (t (symbol-list-to-package-alist1 syms (cdr packages) (acons (car packages) (names-of-symbols-in-package syms (car packages) nil) acc)))))
symbol-list-to-package-alistfunction
(defun symbol-list-to-package-alist (syms) (declare (xargs :guard (symbol-listp syms))) (symbol-list-to-package-alist1 syms (symbol-package-name-set syms nil) nil))
bookdata-alist1function
(defun bookdata-alist1 (full-book-name collect-p trips port-pkgs port-books books port-consts consts port-fns fns port-labels labels port-macros macros port-stobjs stobjs port-theories theories port-thms thms) (cond ((endp trips) (list :pkgs port-pkgs :port-books port-books :books books :port-consts (symbol-list-to-package-alist port-consts) :consts (symbol-list-to-package-alist consts) :port-fns (symbol-list-to-package-alist port-fns) :fns (symbol-list-to-package-alist fns) :port-labels (symbol-list-to-package-alist port-labels) :labels (symbol-list-to-package-alist labels) :port-macros (symbol-list-to-package-alist port-macros) :macros (symbol-list-to-package-alist macros) :port-stobjs (symbol-list-to-package-alist port-stobjs) :stobjs (symbol-list-to-package-alist stobjs) :port-theories (symbol-list-to-package-alist port-theories) :theories (symbol-list-to-package-alist theories) :port-thms (symbol-list-to-package-alist port-thms) :thms (symbol-list-to-package-alist thms))) (t (let ((trip (car trips))) (cond ((and (eq (car trip) 'include-book-path) (eq (cadr trip) 'global-value)) (bookdata-alist1 full-book-name (cond ((null (cddr trip)) 'port) (t (equal (car (cddr trip)) full-book-name))) (cdr trips) port-pkgs (cond ((and (eq collect-p 'port) (cddr trip) (not (equal (car (cddr trip)) full-book-name))) (cons (car (cddr trip)) port-books)) (t port-books)) (cond ((and (eq collect-p t) (cddr trip)) (assert$ (not (equal (car (cddr trip)) full-book-name)) (cons (car (cddr trip)) books))) (t books)) port-consts consts port-fns fns port-labels labels port-macros macros port-stobjs stobjs port-theories theories port-thms thms)) ((not collect-p) (bookdata-alist1 full-book-name nil (cdr trips) port-pkgs port-books books port-consts consts port-fns fns port-labels labels port-macros macros port-stobjs stobjs port-theories theories port-thms thms)) ((and (eq (car trip) 'event-landmark) (eq (cadr trip) 'global-value) (eq (access-event-tuple-type (cddr trip)) 'defpkg)) (bookdata-alist1 full-book-name collect-p (cdr trips) (assert$ (eq collect-p 'port) (cons (access-event-tuple-namex (cddr trip)) port-pkgs)) port-books books port-consts consts port-fns fns port-labels labels port-macros macros port-stobjs stobjs port-theories theories port-thms thms)) (t (let ((name (name-introduced trip nil))) (cond (name (case (cadr trip) (formals (bookdata-alist1 full-book-name collect-p (cdr trips) port-pkgs port-books books port-consts consts (if (eq collect-p 'port) (cons name port-fns) port-fns) (if (eq collect-p 'port) fns (cons name fns)) port-labels labels port-macros macros port-stobjs stobjs port-theories theories port-thms thms)) (theorem (bookdata-alist1 full-book-name collect-p (cdr trips) port-pkgs port-books books port-consts consts port-fns fns port-labels labels port-macros macros port-stobjs stobjs port-theories theories (if (eq collect-p 'port) (cons name port-thms) port-thms) (if (eq collect-p 'port) thms (cons name thms)))) (const (bookdata-alist1 full-book-name collect-p (cdr trips) port-pkgs port-books books (if (eq collect-p 'port) (cons name port-consts) port-consts) (if (eq collect-p 'port) consts (cons name consts)) port-fns fns port-labels labels port-macros macros port-stobjs stobjs port-theories theories port-thms thms)) (stobj (bookdata-alist1 full-book-name collect-p (cdr trips) port-pkgs port-books books port-consts consts port-fns fns port-labels labels port-macros macros (if (eq collect-p 'port) (cons name port-stobjs) port-stobjs) (if (eq collect-p 'port) stobjs (cons name stobjs)) port-theories theories port-thms thms)) (label (bookdata-alist1 full-book-name collect-p (cdr trips) port-pkgs port-books books port-consts consts port-fns fns (if (eq collect-p 'port) (cons name port-labels) port-labels) (if (eq collect-p 'port) labels (cons name labels)) port-macros macros port-stobjs stobjs port-theories theories port-thms thms)) (theory (bookdata-alist1 full-book-name collect-p (cdr trips) port-pkgs port-books books port-consts consts port-fns fns port-labels labels port-macros macros port-stobjs stobjs (if (eq collect-p 'port) (cons name port-theories) theories) (if (eq collect-p 'port) theories (cons name theories)) port-thms thms)) (macro-body (bookdata-alist1 full-book-name collect-p (cdr trips) port-pkgs port-books books port-consts consts port-fns fns port-labels labels (if (eq collect-p 'port) (cons name port-macros) port-macros) (if (eq collect-p 'port) macros (cons name macros)) port-stobjs stobjs port-theories theories port-thms thms)) (global-value (assert$ (eq (car trip) 'certification-tuple) (bookdata-alist1 full-book-name collect-p (cdr trips) port-pkgs port-books books port-consts consts port-fns fns port-labels labels port-macros macros port-stobjs stobjs port-theories theories port-thms thms))) (otherwise (er hard 'bookdata-alist1 "Unexpected case for the cadr of ~x0" trip)))) (t (bookdata-alist1 full-book-name collect-p (cdr trips) port-pkgs port-books books port-consts consts port-fns fns port-labels labels port-macros macros port-stobjs stobjs port-theories theories port-thms thms))))))))))
bookdata-alistfunction
(defun bookdata-alist (full-book-name wrld) (assert$ (null (global-val 'include-book-path wrld)) (let* ((boot-strap-wrld (lookup-world-index 'command (relative-to-absolute-command-number 0 wrld) wrld)) (boot-strap-len (length boot-strap-wrld)) (wrld-len (length wrld)) (new-trips (first-n-ac-rev (- wrld-len boot-strap-len) wrld nil))) (bookdata-alist1 full-book-name 'port new-trips nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil))))
maybe-write-bookdatafunction
(defun maybe-write-bookdata (full-book-string full-book-name wrld ctx state) (let ((write-bookdata (f-get-global 'write-bookdata state))) (cond ((eq write-bookdata :never) state) (t (mv-let (erp val state) (if write-bookdata (value t) (getenv! "ACL2_WRITE_BOOKDATA" state)) (assert$ (null erp) (cond (val (let ((outfile (concatenate 'string (remove-lisp-suffix full-book-string t) "__bookdata.out"))) (mv-let (channel state) (open-output-channel outfile :object state) (cond ((null channel) (prog2$ (er hard ctx "Error in maybe-write-bookdata: Unable to ~ open file ~x0 for output." outfile) state)) (t (pprogn (print-object$-fn (cons full-book-name (bookdata-alist full-book-name wrld)) nil channel state) (close-output-channel channel state))))))) (t state))))))))
fromtofunction
(defun fromto (i j) (declare (xargs :guard (and (rationalp i) (rationalp j)))) (if (< j i) nil (cons i (fromto (1+ i) j))))
remove-smaller-keys-from-sorted-alistfunction
(defun remove-smaller-keys-from-sorted-alist (index alist) (cond ((endp alist) nil) ((< (caar alist) index) (remove-smaller-keys-from-sorted-alist index (cdr alist))) (t alist)))
cert-include-expansion-alistfunction
(defun cert-include-expansion-alist (index expansion-alist) (append (pairlis$ (fromto 1 (1- index)) (make-list (1- index) :initial-element '(value-triple nil))) (remove-smaller-keys-from-sorted-alist index expansion-alist)))
read-useless-runes2function
(defun read-useless-runes2 (r alist fal filename ctx state) (declare (xargs :guard (and (rationalp r) (< 0 r) (<= r 1) (alistp alist) (true-list-listp alist)))) (cond ((endp alist) (value fal)) ((atom (car alist)) (er soft ctx "Illegal entry in file ~x0 (not a cons): ~x1." filename (car alist))) ((not (symbolp (caar alist))) (er soft ctx "Illegal entry in file ~x0 (CAR is not a symbol): ~x1." filename (caar alist))) ((not (useless-runes-report-p (cdar alist))) (er soft ctx "Illegal entry in file ~x0 (CDR is not a list of triples): ~x1." filename (cdar alist))) (t (let* ((key (caar alist)) (new0 (strip-caddrs (cdar alist))) (new (if (= r 1) new0 (take (ceiling (* r (length new0)) 1) new0))) (old (cdr (hons-get key fal)))) (read-useless-runes2 r (cdr alist) (hons-acons key (cons new old) fal) filename ctx state)))))
read-useless-runes1function
(defun read-useless-runes1 (r alist filename ctx state) (declare (xargs :guard (and (rationalp r) (< 0 r) (<= r 1) (alistp alist) (true-list-listp alist)))) (read-useless-runes2 r (reverse alist) nil filename ctx state))
read-file-iterate-safefunction
(defun read-file-iterate-safe (channel acc state) (mv-let (eof obj state) (mv-let (erp val state) (read-acl2-oracle state) (declare (ignore erp)) (cond (val (mv-let (eof state) (read-object-suppress channel state) (mv eof nil state))) (t (read-object channel state)))) (cond (eof (mv (reverse acc) state)) (t (read-file-iterate-safe channel (if (eq obj nil) acc (cons obj acc)) state)))))
useless-runes-env-infofunction
(defun useless-runes-env-info (useless-runes-r/w useless-runes-r/w-p ldp state) (cond ((and useless-runes-r/w-p (or (null useless-runes-r/w) ldp)) (value nil)) ((null ldp) (er-let* ((val (getenv! "ACL2_USELESS_RUNES" state))) (value (and val (list* "ACL2_USELESS_RUNES" val nil))))) (t (er-let* ((val-ld (getenv! "ACL2_USELESS_RUNES_LD" state)) (val (getenv! "ACL2_USELESS_RUNES" state))) (cond ((string-equal val-ld "CERT") (value (and val (list* "ACL2_USELESS_RUNES" val val-ld)))) (t (value (and val-ld (list* "ACL2_USELESS_RUNES_LD" val-ld nil)))))))))
useless-runes-source-msgfunction
(defun useless-runes-source-msg (env-info useless-runes-r/w ldp) (cond (env-info (let ((val (car env-info)) (var (cadr env-info)) (val-ld (cddr env-info))) (msg "the value ~x0 of environment variable ~s1~@2" val var (if val-ld (assert$ ldp (msg " (because environment variable ~ ACL2_USELESS_RUNES_LD has value ~s0)" val-ld)) "")))) (t (msg "~x0 keyword option :useless-runes ~x1" (if ldp 'ld 'certify-book) useless-runes-r/w))))
read-useless-runesfunction
(defun read-useless-runes (full-book-string env-info useless-runes-r/w val ldp ctx state) (assert$ (and (rationalp val) (not (zerop val)) (<= -1 val) (<= val 1)) (let ((useless-runes-filename (useless-runes-filename full-book-string))) (with-packages-unhidden (mv-let (channel state) (open-input-channel useless-runes-filename :object state) (cond (channel (er-let* ((alist (state-global-let* ((current-package "ACL2" set-current-package-state)) (mv-let (alist state) (read-file-iterate-safe channel nil state) (value alist))))) (pprogn (io? event nil state (useless-runes-filename) (fms! "; Note: Consulting useless-runes ~ file,~|; ~s0." (list (cons #\0 useless-runes-filename)) (standard-co state) state nil)) (close-input-channel channel state) (read-useless-runes1 (abs val) alist useless-runes-filename ctx state)))) ((< val 0) (value nil)) (t (er soft ctx "Unable to open file ~x0 for reading useless-runes data, ~ as specified by ~@1; see :DOC useless-runes." useless-runes-filename (useless-runes-source-msg env-info useless-runes-r/w ldp)))))))))
free-useless-runesfunction
(defun free-useless-runes (useless-runes state) (cond ((null useless-runes) state) (t (case (access useless-runes useless-runes :tag) (fast-alist (prog2$ (fast-alist-free (access useless-runes useless-runes :data)) state)) (channel (close-output-channel (car (access useless-runes useless-runes :data)) state)) (t (prog2$ (er hard 'free-useless-runes "Implementation error: Unexpected value of ~ useless-runes, ~x0" useless-runes) state))))))
useless-runes-valuefunction
(defun useless-runes-value (useless-runes-r/w useless-runes-r/w-p ldp ctx state) (let ((useless-runes-r/w useless-runes-r/w) (useless-runes-r/w-p useless-runes-r/w-p)) (er-let* ((env-info (useless-runes-env-info useless-runes-r/w useless-runes-r/w-p ldp state))) (mv-let (env-var env-val val-ld) (cond (env-info (mv (car env-info) (cadr env-info) (cddr env-info))) (t (mv nil nil nil))) (cond ((and env-info (string-equal env-val "WRITE") (not ldp)) (value (cons env-info 'write))) (t (case useless-runes-r/w (:write (value (cons nil 'write))) (:read (value (cons nil 1))) (:read? (value (cons nil -1))) ((nil) (cond (useless-runes-r/w-p (value nil)) ((or (null env-info) (string-equal env-val "NIL")) (value nil)) ((or (string-equal env-val "READ") (equal env-val "100")) (value (cons env-info 1))) ((or (string-equal env-val "READ?") (equal env-val "-100")) (value (cons env-info -1))) (t (let* ((len (length env-val)) (sign (if (and (not (zerop len)) (eql (char env-val 0) #\-)) 1 0)) (str (if (int= sign 1) (subseq env-val 1 len) env-val)) (len2 (if (int= sign 1) (1- len) len)) (percent (and (or (int= len2 1) (int= len2 2)) (all-digits-p (coerce str 'list) 10) (decimal-string-to-number str len2 0)))) (cond (percent (value (cons env-info (/ percent (if (int= sign 1) -100 100))))) (t (er soft ctx "Illegal value ~x0 for environment variable ~ ~@1. See :DOC useless-runes." env-val (cond (val-ld (assert$ ldp (msg " (because environment variable ~ ACL2_USELESS_RUNES_LD has value ~s0)" val-ld))) (t env-var))))))))) (t (cond ((and (integerp useless-runes-r/w) (not (zerop useless-runes-r/w)) (<= -100 useless-runes-r/w) (<= useless-runes-r/w 100)) (value (cons nil (/ useless-runes-r/w 100)))) (t (er soft ctx "Illegal value ~x0 for certify-book parameter ~ :USELESS-RUNES. See :DOC useless-runes." useless-runes-r/w)))))))))))
initial-useless-runesfunction
(defun initial-useless-runes (full-book-string useless-runes-r/w useless-runes-r/w-p ldp ctx state) (let ((bookp (and (stringp full-book-string) (let ((len (length full-book-string))) (and (< 5 len) (terminal-substringp ".lisp" full-book-string 4 (1- len))))))) (cond ((not (or useless-runes-r/w-p bookp)) (value nil)) (t (er-let* ((pair (useless-runes-value useless-runes-r/w useless-runes-r/w-p ldp ctx state)) (env-info (value (car pair))) (val (value (cdr pair))) (full-book-string (cond ((or (null val) (not ldp)) (value full-book-string)) (bookp (value (extend-pathname (f-get-global 'connected-book-directory state) full-book-string state))) (t (er soft ctx "A non-nil :useless-runes argument is only ~ permitted for a call of ~x0 when the first ~ argument is a string ending in ".lisp". But ~ the first argument is ~x1." 'ld full-book-string))))) (cond ((null val) (value nil)) ((eq val 'write) (let ((useless-runes-filename (useless-runes-filename full-book-string))) (mv-let (chan state) (open-output-channel useless-runes-filename :character state) (cond ((null chan) (er soft ctx "Unable to open file ~x0 for writing useless-runes data (as ~ specified by ~@1); see :DOC useless-runes." useless-runes-filename (useless-runes-source-msg env-info useless-runes-r/w ldp))) (t (value (make useless-runes :tag 'channel :data (cons chan (strip-cars (known-package-alist state))) :full-book-string full-book-string))))))) (t (assert$ (and (rationalp val) (<= -1 val) (not (zerop val)) (<= val 1)) (er-let* ((fal (read-useless-runes full-book-string env-info useless-runes-r/w val ldp ctx state))) (value (make useless-runes :tag 'fast-alist :data fal :full-book-string full-book-string)))))))))))
maybe-refresh-useless-runesfunction
(defun maybe-refresh-useless-runes (useless-runes) (cond ((and useless-runes (eq (access useless-runes useless-runes :tag) 'fast-alist)) (change useless-runes useless-runes :data (make-fast-alist (access useless-runes useless-runes :data)))) (t useless-runes)))
update-useless-runesfunction
(defun update-useless-runes (useless-runes state) (pprogn (free-useless-runes (f-get-global 'useless-runes state) state) (f-put-global 'useless-runes (maybe-refresh-useless-runes useless-runes) state)))
eval-some-portcullis-cmdsfunction
(defun eval-some-portcullis-cmds (port-index portcullis-cmds ctx state) (state-global-let* ((ld-skip-proofsp 'include-book) (skip-proofs-by-system t)) (mv-let (erp val expansion-alist ignore-kpa state) (eval-event-lst 0 nil (nthcdr port-index portcullis-cmds) t nil nil nil nil nil 'eval-some-portcullis-cmds ctx (proofs-co state) state) (declare (ignore expansion-alist ignore-kpa)) (mv erp val state))))
compress-cltl-command-stack-recfunction
(defun compress-cltl-command-stack-rec (stack fal) (cond ((endp stack) (strip-cdrs (fast-alist-free fal))) (t (compress-cltl-command-stack-rec (cdr stack) (let ((x (car stack))) (case-match x (('defuns mode & . defs) (assert$ (and (alistp defs) defs) (let* ((name (caar defs)) (pair (hons-get name fal))) (cond (pair (let ((old (cdr pair))) (cond ((and (eq (cadr old) :program) (eq mode :logic)) (hons-acons name `(defuns :logic reclassifying ,@DEFS) fal)) (t fal)))) (t (hons-acons name x fal)))))) ((defx name . &) (cond ((and (member-eq defx '(defconst defmacro defstobj defabsstobj)) (hons-get name fal)) fal) (t (hons-acons name x fal)))) (& (hons-acons nil x fal))))))))
compress-cltl-command-stackfunction
(defun compress-cltl-command-stack (stack) (compress-cltl-command-stack-rec (reverse stack) nil))
event-data-channelfunction
(defun event-data-channel (full-book-string write-event-data write-event-data-p ctx state) (er-let* ((write-event-data (if write-event-data-p (value write-event-data) (getenv! "ACL2_WRITE_EVENT_DATA" state)))) (cond ((null write-event-data) (value nil)) (t (let ((filename (event-data-filename full-book-string t))) (mv-let (channel state) (open-output-channel filename :object state) (cond ((null channel) (er soft ctx "Unable to open output channel for writing event-data ~ to file ~x0" filename)) (t (value channel)))))))))
chk-acceptable-certify-book-prelimfunction
(defun chk-acceptable-certify-book-prelim (user-book-name acl2x ttagsxp ctx state) (cond ((not (eq (caar (w state)) 'command-landmark)) (er soft ctx "Certify-book can only be run at the top-level, either directly in ~ the top-level loop or at the top level of LD.")) ((and (stringp user-book-name) (let ((len (length user-book-name))) (and (<= 10 len) (equal (subseq user-book-name (- len 10) len) "@expansion")))) (er soft ctx "Book filenames may not end in "@expansion".")) ((not (booleanp acl2x)) (er soft ctx "The argument :ACL2X for certify-book must take on the value of T or ~ NIL. The value ~x0 is thus illegal. See :DOC certify-book." acl2x)) ((and ttagsxp (not acl2x)) (er soft ctx "The :TTAGSX argument for certify-book may only be supplied if ~ :ACL2X is T. See :DOC set-write-acl2x.")) ((and (not acl2x) (f-get-global 'write-acl2x state)) (er soft ctx "Apparently set-write-acl2x has been evaluated with argument value ~ ~x0, yet certify-book is being called without supplying keyword ~ argument :ACL2X T. This is illegal. See :DOC set-write-acl2x. If ~ you do not intend to write a .acl2x file, you may wish to evaluate ~ ~x1." (f-get-global 'write-acl2x state) '(set-write-acl2x nil state))) (t (value nil))))
certify-book-write-portfunction
(defun certify-book-write-port (write-port pcert ctx state) (cond ((member-eq write-port '(t nil)) (value write-port)) ((eq write-port :default) (cond (pcert (value nil)) (t (er-let* ((str (getenv! "ACL2_WRITE_PORT" state))) (value (cond (str (intern$ (string-upcase str) "ACL2")) (t t))))))) (t (er soft ctx "Illegal :write-port argument, ~x0. See :DOC certify-book."))))
certify-book-cert-opfunction
(defun certify-book-cert-op (pcert pcert-env write-acl2x ctx state) (cond ((and write-acl2x pcert) (er soft ctx "It is illegal to specify the writing of a .acl2x file when a ~ non-nil value for :pcert (here, ~x1) is specified~@0." pcert (cond (pcert-env " (even when the :pcert argument is supplied, as in this ~ case, by an environment variable)") (t "")))) (write-acl2x (value (if (consp write-acl2x) :write-acl2xu :write-acl2x))) (t (case pcert (:create (value :create-pcert)) (:convert (value :convert-pcert)) ((t) (value :create+convert-pcert)) ((nil) (value t)) (otherwise (er soft ctx "Illegal value of :pcert, ~x0~@1. See :DOC certify-book." pcert (cond (pcert-env (msg " (from environment variable ACL2_PCERT_ARG=~x0" pcert-env)) (t ""))))))))
certify-book-compile-flgfunction
(defun certify-book-compile-flg (compile-flg cert-op ctx state) (er-let* ((env-compile-flg (getenv! "ACL2_COMPILE_FLG" state))) (cond ((or (and env-compile-flg (string-equal env-compile-flg "ALL")) (eq compile-flg :all)) (value t)) ((or (eq cert-op :convert-pcert) (null (f-get-global 'compiler-enabled state))) (value nil)) ((not (eq compile-flg :default)) (value compile-flg)) ((or (null env-compile-flg) (string-equal env-compile-flg "T")) (value t)) ((string-equal env-compile-flg "NIL") (value nil)) (t (er soft ctx "Illegal value, ~x0, for environment variable ~ ACL2_COMPILE_FLG. The legal values are (after converting ~ to uppercase) "", "T", "NIL", "", and "ALL"." env-compile-flg)))))
print-certify-book-step-1function
(defun print-certify-book-step-1 (fast-cert-p full-book-string cert-op fast-cert-mode state) (io? event nil state (fast-cert-p full-book-string cert-op fast-cert-mode) (fms "CERTIFICATION ATTEMPT~#h~[~|**using fast-cert mode**~|~/ ~ ~]~@0FOR ~x1~%~s2~@3~%~%*~ Step 1: Read ~x1 and compute its ~ book-hash.~%" (list (cons #\h (if fast-cert-p 0 1)) (cons #\0 (case cert-op ((:write-acl2xu :write-acl2x) "(for writing .acl2x file) ") (:create-pcert "(for writing .pcert0 file) ") (:create+convert-pcert "(for writing .pcert0 and .pcert1 files) ") (:convert-pcert "(for writing .pcert1 file) ") (t ""))) (cons #\1 full-book-string) (cons #\2 (f-get-global 'acl2-version state)) (cons #\3 (if (and fast-cert-mode (not fast-cert-p)) "~|Note that fast-cert mode is enabled but ~ will be ignored during certification, except ~ for noting in the certificate file that ~ fast-cert mode was enabled during ~ certification." ""))) (proofs-co state) state nil)))
certify-book-expansion-alist0function
(defun certify-book-expansion-alist0 (cert-op cert-obj acl2x-expansion-alist full-book-string acl2x-file ctx state) (cond ((eq cert-op :convert-pcert) (let ((elided-expansion-alist (access cert-obj cert-obj :expansion-alist))) (mv-let (bad-entry elided-entry) (expansion-alist-conflict acl2x-expansion-alist elided-expansion-alist) (cond (bad-entry (er soft ctx "The following expansion-alist entry from file ~ ~x0 is unexpected:~|~x1~|~@2" acl2x-file bad-entry (cond (elided-entry (msg "It was expected to correspond to ~ the following entry from the ~ :expansion-alist in file ~x0:~|~x1" (convert-book-string-to-cert full-book-string :create-pcert) elided-entry)) (t "")))) (t (value (merge-into-expansion-alist (merge-into-expansion-alist elided-expansion-alist acl2x-expansion-alist) (access cert-obj cert-obj :pcert-info)))))))) (t (value acl2x-expansion-alist))))
certify-book-step-2function
(defun certify-book-step-2 (ev-lst expansion-alist0 cert-op full-book-string acl2x-file ttags-allowed wrld1 directory-name write-acl2x full-book-name saved-acl2-defaults-table ctx state) (pprogn (print-certify-book-step-2 ev-lst expansion-alist0 (and (eq cert-op :convert-pcert) (convert-book-string-to-cert full-book-string :create-pcert)) acl2x-file state) (state-global-let* ((ttags-allowed ttags-allowed) (user-home-dir nil) (axiomsp (not (equal (global-val 'nonconstructive-axiom-names (scan-to-landmark-number 'event-landmark (global-val 'event-number-baseline wrld1) wrld1)) (global-val 'nonconstructive-axiom-names wrld1)))) (ld-redefinition-action nil)) (with-cbd directory-name (revert-world-on-error (er-let* ((portcullis-skipped-proofsp (value (and (global-val 'skip-proofs-seen (w state)) t))) (expansion-alist-and-index (process-embedded-events 'certify-book saved-acl2-defaults-table (or (eq cert-op :create-pcert) (and (consp write-acl2x) (car write-acl2x))) (cadr (car ev-lst)) (list 'certify-book full-book-name) (subst-by-position expansion-alist0 (cdr ev-lst) 1) 1 nil nil 'certify-book state)) (ignore (pprogn (chk-absstobj-invariants state) (illegal-to-certify-check nil ctx state))) (expansion-alist (value (cond (write-acl2x (assert$ (null expansion-alist0) (car expansion-alist-and-index))) ((eq cert-op :convert-pcert) :irrelevant) (t (merge-into-expansion-alist expansion-alist0 (car expansion-alist-and-index))))))) (cond (write-acl2x (assert$ (not (eq cert-op :convert-pcert)) (write-acl2x-file expansion-alist acl2x-file ctx state))) (t (let ((expansion-alist (cond ((or (eq cert-op :create-pcert) (eq cert-op :convert-pcert)) expansion-alist) (t (elide-locals-from-expansion-alist expansion-alist nil))))) (value (list (let ((val (global-val 'skip-proofs-seen (w state)))) (and val (not (eq (car val) :include-book)))) portcullis-skipped-proofsp (f-get-global 'axiomsp state) (global-val 'ttags-seen (w state)) (global-val 'include-book-alist-all (w state)) expansion-alist (let ((index0 (cdr expansion-alist-and-index))) (cond ((eq cert-op :convert-pcert) nil) ((integerp index0) (restrict-expansion-alist index0 expansion-alist)) (t nil))) (global-val 'translate-cert-data (w state)))))))))))))
certify-book-convert-pcertfunction
(defun certify-book-convert-pcert (full-book-string full-book-name user-book-name familiar-name portcullis-cmds0 cert-obj ev-lst cert-annotations post-alist1 ctx state) (er-let* ((book-hash (book-hash nil full-book-string portcullis-cmds0 (access cert-obj cert-obj :expansion-alist) (access cert-obj cert-obj :cert-data) ev-lst state)) (extra-entry (value (list* full-book-name user-book-name familiar-name cert-annotations book-hash)))) (certify-book-finish-convert (cons extra-entry post-alist1) (access cert-obj cert-obj :post-alist) full-book-string ctx state)))
certify-book-step-3-infofunction
(defun certify-book-step-3-info (fast-cert-p wrld1 wrld-post-pass1) (let* ((rollback-pair (and (not fast-cert-p) (global-val 'cert-replay wrld-post-pass1))) (index (assert$ (listp rollback-pair) (and (posp (car rollback-pair)) (car rollback-pair)))) (port-index (and rollback-pair (not index) (- (- (car (car rollback-pair))) (access command-number-baseline-info (global-val 'command-number-baseline-info wrld-post-pass1) :original)))) (port-non-localp (and port-index (not (cdr (car rollback-pair))))) (rollback-wrld (if rollback-pair (cdr rollback-pair) wrld1)) (cert-data-pass1-saved (and rollback-pair (cert-data-pass1-saved (if index rollback-wrld wrld1) wrld-post-pass1)))) (mv rollback-pair index port-index port-non-localp rollback-wrld cert-data-pass1-saved)))
certify-book-step-3+function
(defun certify-book-step-3+ (rollback-pair rollback-wrld port-index portcullis-cmds0 compile-flg cert-op expansion-alist acl2x-expansion-alist fast-cert-p wrld1-known-package-alist index cert-data-pass1-saved uncertified-okp defaxioms-okp skip-proofs-okp ttags-seen translate-cert-data expansion-alist-to-check full-book-string post-alist1 directory-name ev-lst full-book-name user-book-name familiar-name cert-annotations pass1-known-package-alist acl2x-file pre-alist-wrld1 k expansion-alist0 saved-acl2-defaults-table wrld1 event-data-channel ctx state) (declare (ignore event-data-channel)) (pprogn (cond (rollback-pair (set-w 'retraction rollback-wrld state)) (t state)) (let ((rollback-wrld-known-package-alist (and rollback-pair (global-val 'known-package-alist rollback-wrld)))) (er-progn (if port-index (eval-some-portcullis-cmds port-index portcullis-cmds0 ctx state) (value nil)) (pprogn (with-hcomp-bindings (mv-let (expansion-alist pcert-info) (cond ((eq cert-op :create-pcert) (elide-locals-and-split-expansion-alist expansion-alist acl2x-expansion-alist nil nil)) (t (mv expansion-alist (if (eq cert-op :create+convert-pcert) :proved nil)))) (er-let* ((portcullis-wrld (value (if port-index (w state) wrld1))) (pre-alist (value (cond (fast-cert-p nil) (port-index (global-val 'include-book-alist portcullis-wrld)) (t pre-alist-wrld1)))) (portcullis-wrld-known-package-alist (value (global-val 'known-package-alist portcullis-wrld))) (defpkg-items (if fast-cert-p (value nil) (defpkg-items pass1-known-package-alist (if rollback-pair rollback-wrld-known-package-alist wrld1-known-package-alist) ctx portcullis-wrld state))) (cltl-command-stack0 (value (if fast-cert-p (compress-cltl-command-stack (global-val 'top-level-cltl-command-stack (w state))) nil))) (declaim-list (state-global-let* ((ld-redefinition-action nil)) (er-progn (hcomp-build-from-state (if fast-cert-p cltl-command-stack0 (global-val 'top-level-cltl-command-stack (w state))) state) (cond (rollback-pair (include-book-fn user-book-name state nil (cons (if index (cert-include-expansion-alist index expansion-alist) expansion-alist) cert-data-pass1-saved) uncertified-okp defaxioms-okp skip-proofs-okp ttags-seen nil nil)) (t (get-declaim-list state)))))) (ignore (cond (rollback-pair (maybe-install-acl2-defaults-table saved-acl2-defaults-table state)) (t (value nil))))) (let* ((wrld2 (w state)) (cltl-command-stack (if fast-cert-p cltl-command-stack0 (global-val 'top-level-cltl-command-stack wrld2))) (new-fns (top-level-user-fns cltl-command-stack nil)) (cert-data-pass2 (cert-data-for-certificate new-fns translate-cert-data wrld2)) (pkg-names (pkg-names (cons expansion-alist-to-check cert-data-pass2) portcullis-wrld-known-package-alist)) (new-defpkg-list (new-defpkg-list defpkg-items (delete-names-from-kpa pkg-names (global-val 'known-package-alist wrld2)) (if rollback-pair rollback-wrld-known-package-alist wrld1-known-package-alist))) (include-book-alist-wrld2 (global-val 'include-book-alist wrld2)) (post-alist2 (cond (fast-cert-p nil) (rollback-pair (cdr include-book-alist-wrld2)) (t include-book-alist-wrld2)))) (fast-alist-free-cert-data-on-exit cert-data-pass2 (pprogn (maybe-write-bookdata full-book-string full-book-name wrld2 ctx state) (mv-let (new-bad-fns all-bad-fns) (cond ((or fast-cert-p (warning-disabled-p "Guards")) (mv nil nil)) (t (mv (collect-ideals new-fns wrld2 nil) (collect-ideal-user-defuns wrld2)))) (cond ((or new-bad-fns all-bad-fns) (print-certify-book-guards-warning full-book-string new-bad-fns all-bad-fns k ctx state)) (t state))) (er-progn (chk-certify-book-step-3 post-alist2 post-alist1 ctx state) (with-cbd directory-name (pprogn (print-certify-book-step-4 full-book-string cert-op state) (er-let* ((portcullis-cmds (value (append? portcullis-cmds0 new-defpkg-list))) (book-hash (book-hash nil full-book-string portcullis-cmds expansion-alist cert-data-pass2 ev-lst state)) (extra-entry (value (list* full-book-name user-book-name familiar-name cert-annotations book-hash))) (temp-alist (make-certificate-files full-book-string (cons portcullis-cmds pre-alist) (cons extra-entry post-alist1) (cons extra-entry post-alist2) expansion-alist cert-data-pass2 pcert-info cert-op ctx state)) (os-compiled-file (cond (compile-flg (pprogn (print-certify-book-step-5 full-book-string state) (er-progn (write-expansion-file portcullis-cmds declaim-list new-fns cltl-command-stack (expansion-filename full-book-string) expansion-alist pkg-names ev-lst pass1-known-package-alist ctx state)))) (t (value nil))))) (er-progn (pprogn (cond (expansion-alist0 (observation ctx "Used expansion-alist obtained from file ~x0." acl2x-file)) (t state)) (value full-book-string))))))))))))))))))
certify-book-fnfunction
(defun certify-book-fn (user-book-name k compile-flg defaxioms-okp skip-proofs-okp ttags ttagsx ttagsxp acl2x write-port pcert useless-runes-r/w useless-runes-r/w-p write-event-data write-event-data-p state) (with-ctx-summarized (cons 'certify-book user-book-name) (er-progn (chk-acceptable-certify-book-prelim user-book-name acl2x ttagsxp ctx state) (state-global-let* ((warnings-as-errors nil)) (save-parallelism-settings (er-let* ((pcert-env (cond ((eq pcert :default) (getenv! "ACL2_PCERT_ARG" state)) (t (value nil)))) (pcert (cond ((not pcert-env) (value (if (eq pcert :default) nil pcert))) ((string-equal pcert-env "T") (value t)) (t (value (intern (string-upcase pcert-env) "KEYWORD"))))) (ttags-seen0 (value (global-val 'ttags-seen (w state))))) (mv-let (full-book-string full-book-name directory-name familiar-name) (parse-book-name (cbd) user-book-name ".lisp" ctx state) (cond ((eq pcert :complete) (certify-book-finish-complete full-book-string full-book-name ctx state)) (t (er-let* ((write-port (certify-book-write-port write-port pcert ctx state)) (write-acl2x (value (f-get-global 'write-acl2x state))) (cert-op (certify-book-cert-op pcert pcert-env write-acl2x ctx state)) (skip-proofs-okp (value (cond ((eq skip-proofs-okp :default) (consp write-acl2x)) (t skip-proofs-okp)))) (uncertified-okp (value (consp write-acl2x))) (ttagsx (value (if ttagsxp ttagsx ttags))) (ttags (chk-well-formed-ttags (if write-acl2x ttagsx ttags) (cbd) ctx state)) (ttags-allowed/ttags-seen-ignored (chk-acceptable-ttags1 ttags-seen0 nil ttags nil :quiet ctx state)) (event-data-channel (if (member-eq cert-op '(t :convert-pcert :create+convert-pcert)) (event-data-channel full-book-string write-event-data write-event-data-p ctx state) (value nil))) (certify-book-info-0 (value (make certify-book-info :full-book-name full-book-name :cert-op cert-op :event-data-channel event-data-channel)))) (state-global-let* ((compiler-enabled (f-get-global 'compiler-enabled state)) (port-file-enabled (f-get-global 'port-file-enabled state)) (certify-book-info certify-book-info-0) (match-free-error nil) (defaxioms-okp-cert defaxioms-okp) (skip-proofs-okp-cert skip-proofs-okp) (guard-checking-on t)) (er-let* ((compile-flg (certify-book-compile-flg compile-flg cert-op ctx state)) (saved-acl2-defaults-table (value (table-alist 'acl2-defaults-table (w state)))) (suspect-book-action-alist (value (list (cons :uncertified-okp uncertified-okp) (cons :defaxioms-okp defaxioms-okp) (cons :skip-proofs-okp skip-proofs-okp)))) (cert-obj (chk-acceptable-certify-book user-book-name full-book-string full-book-name directory-name suspect-book-action-alist cert-op k ctx state)) (portcullis-cmds0 (value (access cert-obj cert-obj :cmds))) (old-useless-runes (value (f-get-global 'useless-runes state))) (useless-runes (initial-useless-runes full-book-string useless-runes-r/w useless-runes-r/w-p nil ctx state)) (ignore (cond (write-port (write-port-file full-book-string portcullis-cmds0 ctx state)) (t (value nil))))) (let* ((wrld1 (w state)) (pre-alist-wrld1 (global-val 'include-book-alist wrld1)) (wrld1-known-package-alist (global-val 'known-package-alist wrld1)) (acl2x-file (convert-book-string-to-acl2x full-book-string)) (fast-cert-mode (fast-cert-mode state)) (fast-cert-p (and (not pcert) (eq fast-cert-mode t)))) (pprogn (f-put-global 'useless-runes useless-runes state) (print-certify-book-step-1 fast-cert-p full-book-string cert-op fast-cert-mode state) (er-let* ((ev-lst (let nil (read-object-file full-book-string ctx state))) (acl2x-expansion-alist (cond (write-acl2x (value nil)) (t (read-acl2x-file acl2x-file full-book-string (length ev-lst) acl2x ctx state)))) (expansion-alist0 (certify-book-expansion-alist0 cert-op cert-obj acl2x-expansion-alist full-book-string acl2x-file ctx state)) (pass1-result (certify-book-step-2 ev-lst expansion-alist0 cert-op full-book-string acl2x-file (car ttags-allowed/ttags-seen-ignored) wrld1 directory-name write-acl2x full-book-name saved-acl2-defaults-table ctx state))) (cond (write-acl2x (value acl2x-file)) (t (let* ((pass1-known-package-alist (global-val 'known-package-alist (w state))) (skipped-proofsp (nth 0 pass1-result)) (portcullis-skipped-proofsp (nth 1 pass1-result)) (axiomsp (nth 2 pass1-result)) (ttags-seen (nth 3 pass1-result)) (new-include-book-alist-all (nth 4 pass1-result)) (expansion-alist (nth 5 pass1-result)) (expansion-alist-to-check (nth 6 pass1-result)) (translate-cert-data (nth 7 pass1-result)) (cert-annotations (list (cons :skipped-proofsp skipped-proofsp) (cons :axiomsp axiomsp) (cons :ttags ttags-seen))) (post-alist1 (if fast-cert-p nil new-include-book-alist-all))) (er-progn (chk-cert-annotations cert-annotations portcullis-skipped-proofsp portcullis-cmds0 full-book-string suspect-book-action-alist ctx state) (cond ((eq cert-op :convert-pcert) (certify-book-convert-pcert full-book-string full-book-name user-book-name familiar-name portcullis-cmds0 cert-obj ev-lst cert-annotations post-alist1 ctx state)) (t (mv-let (rollback-pair index port-index port-non-localp rollback-wrld cert-data-pass1-saved) (certify-book-step-3-info fast-cert-p wrld1 (w state)) (fast-alist-free-cert-data-on-exit cert-data-pass1-saved (pprogn (update-useless-runes old-useless-runes state) (if event-data-channel (close-output-channel event-data-channel state) state) (print-certify-book-step-3 index port-index port-non-localp state) (certify-book-step-3+ rollback-pair rollback-wrld port-index portcullis-cmds0 compile-flg cert-op expansion-alist acl2x-expansion-alist fast-cert-p wrld1-known-package-alist index cert-data-pass1-saved uncertified-okp defaxioms-okp skip-proofs-okp ttags-seen translate-cert-data expansion-alist-to-check full-book-string post-alist1 directory-name ev-lst full-book-name user-book-name familiar-name cert-annotations pass1-known-package-alist acl2x-file pre-alist-wrld1 k expansion-alist0 saved-acl2-defaults-table wrld1 event-data-channel ctx state)))))))))))))))))))))))))
certify-bookmacro
(defmacro certify-book (user-book-name &optional (k '0) (compile-flg ':default) &key (defaxioms-okp 'nil) (skip-proofs-okp ':default) (ttags 'nil) (ttagsx 'nil ttagsxp) (acl2x 'nil) (write-port ':default) (pcert ':default) (useless-runes 'nil useless-runes-p) (write-event-data 'nil write-event-data-p)) (declare (xargs :guard (and (booleanp acl2x) (member-eq compile-flg '(nil t :all :default))))) (list 'certify-book-fn (list 'quote user-book-name) (list 'quote k) (list 'quote compile-flg) (list 'quote defaxioms-okp) (list 'quote skip-proofs-okp) (list 'quote ttags) (list 'quote ttagsx) (list 'quote ttagsxp) (list 'quote acl2x) (list 'quote write-port) (list 'quote pcert) (list 'quote useless-runes) (list 'quote useless-runes-p) (list 'quote write-event-data) (list 'quote write-event-data-p) 'state))
certify-book!macro
(defmacro certify-book! (user-book-name &optional (k '0) (compile-flg 't compile-flg-supplied-p) &rest args) (declare (xargs :guard (and (integerp k) (<= 0 k)))) `(er-progn (ubt! ,(1+ K)) ,(IF COMPILE-FLG-SUPPLIED-P `(CERTIFY-BOOK ,USER-BOOK-NAME ,K ,COMPILE-FLG ,@ARGS) `(CERTIFY-BOOK ,USER-BOOK-NAME ,K))))
redundant-defchoosepfunction
(defun redundant-defchoosep (name event-form wrld) (let* ((old-ev (get-event name wrld))) (and old-ev (case-match old-ev (('defchoose !name old-bound-vars old-free-vars old-body . old-rest) (case-match event-form (('defchoose !name new-bound-vars new-free-vars new-body . new-rest) (and (equal old-bound-vars new-bound-vars) (equal old-free-vars new-free-vars) (equal old-body new-body) (eq (cadr (assoc-keyword :strengthen old-rest)) (cadr (assoc-keyword :strengthen new-rest)))))))))))
chk-arglist-for-defchoosefunction
(defun chk-arglist-for-defchoose (args bound-vars-flg ctx state) (cond ((arglistp args) (value nil)) ((not (true-listp args)) (er soft ctx "The ~#0~[bound~/free~] variables of a DEFCHOOSE event must be a ~ true list but ~x1 is not." (if bound-vars-flg 0 1) args)) (t (mv-let (culprit explan) (find-first-bad-arg args) (er soft ctx "The ~#0~[bound~/free~] variables of a DEFCHOOSE event ~ must be a true list of distinct, legal variable names. ~ ~x1 is not such a list. The element ~x2 violates the ~ rules because it ~@3." (if bound-vars-flg 0 1) args culprit explan)))))
without-warnings-fnfunction
(defun without-warnings-fn (form) `(state-global-let* ((inhibit-output-lst (f-get-global 'inhibit-output-lst state))) (pprogn (f-put-global 'inhibit-output-lst (add-to-set-eq 'warning (f-get-global 'inhibit-output-lst state)) state) ,FORM)))
without-warningsmacro
(defmacro without-warnings (form) (without-warnings-fn form))
translate-ignore-okfunction
(defun translate-ignore-ok (x stobjs-out logic-modep known-stobjs ctx w state) (let ((w (putprop 'acl2-defaults-table 'table-alist (put-assoc-equal-fast :ignore-ok t (table-alist 'acl2-defaults-table w)) w))) (translate x stobjs-out logic-modep known-stobjs ctx w state)))
translate-without-warnings-ignore-okmacro
(defmacro translate-without-warnings-ignore-ok (&rest args) `(without-warnings (translate-ignore-ok ,@ARGS)))
defchoose-constraint-basicfunction
(defun defchoose-constraint-basic (fn bound-vars formals tbody ctx wrld state) (cond ((null (cdr bound-vars)) (er-let* ((consequent (translate-without-warnings-ignore-ok `(let ((,(CAR BOUND-VARS) ,(CONS FN FORMALS))) ,TBODY) t t t ctx wrld state))) (value (fcons-term* 'implies tbody consequent)))) (t (er-let* ((consequent (translate-without-warnings-ignore-ok `(mv-let ,BOUND-VARS ,(CONS FN FORMALS) ,TBODY) t t t ctx wrld state))) (value (fcons-term* 'if (fcons-term* 'true-listp (cons-term fn formals)) (fcons-term* 'implies tbody consequent) *nil*))))))
generate-variable-lst-simplefunction
(defun generate-variable-lst-simple (var-lst avoid-lst) (cond ((null var-lst) nil) (t (let ((old-var (car var-lst))) (mv-let (str n) (strip-final-digits (symbol-name old-var)) (let ((new-var (genvar (find-pkg-witness old-var) str (1+ n) avoid-lst))) (cons new-var (generate-variable-lst-simple (cdr var-lst) (cons new-var avoid-lst)))))))))
defchoose-constraint-extrafunction
(defun defchoose-constraint-extra (fn bound-vars formals body) (let* ((formals2 (generate-variable-lst-simple formals (append bound-vars formals))) (body2 `(let ,(PAIRLIS$ FORMALS (PAIRLIS$ FORMALS2 NIL)) ,BODY)) (equality `(equal (,FN ,@FORMALS) (,FN ,@FORMALS2)))) (cond ((null (cdr bound-vars)) (let ((bound-var (car bound-vars))) `(or ,EQUALITY (let ((,BOUND-VAR (,FN ,@FORMALS))) (and ,BODY (not ,BODY2))) (let ((,BOUND-VAR (,FN ,@FORMALS2))) (and ,BODY2 (not ,BODY)))))) (t `(or ,EQUALITY (mv-let (,@BOUND-VARS) (,FN ,@FORMALS) (and ,BODY (not ,BODY2))) (mv-let (,@BOUND-VARS) (,FN ,@FORMALS2) (and ,BODY2 (not ,BODY))))))))
defchoose-constraintfunction
(defun defchoose-constraint (fn bound-vars formals body tbody strengthen ctx wrld state) (er-let* ((basic (defchoose-constraint-basic fn bound-vars formals tbody ctx wrld state))) (cond (strengthen (er-let* ((extra (translate-without-warnings-ignore-ok (defchoose-constraint-extra fn bound-vars formals body) t t t ctx wrld state))) (value (conjoin2 basic extra)))) (t (value basic)))))
defchoose-fnfunction
(defun defchoose-fn (def state event-form) (declare (xargs :guard (true-listp def))) (when-logic "DEFCHOOSE" (with-ctx-summarized (cons 'defchoose (car def)) (let* ((wrld (w state)) (event-form (or event-form (cons 'defchoose def))) (raw-bound-vars (cadr def)) (valid-keywords '(:strengthen)) (ka (nthcdr 4 def)) (kap (keyword-value-listp ka)) (strengthen (and kap (cadr (assoc-keyword :strengthen ka))))) (er-progn (chk-all-but-new-name (car def) ctx 'constrained-function wrld state) (cond ((not (and kap (null (strip-keyword-list valid-keywords ka)))) (er soft ctx "Defchoose forms must have the form (defchoose fn bound-vars ~ formals body), with optional keyword argument~#0~[~/s~] ~&0. ~ However, ~x1 does not have this form. See :DOC defchoose." valid-keywords event-form)) ((not (booleanp strengthen)) (er soft ctx "The :strengthen argument of a defchoose event must be t or nil. ~ The event ~x0 is thus illegal." event-form)) ((redundant-defchoosep (car def) event-form wrld) (stop-redundant-event ctx state :name (car def))) (t (enforce-redundancy event-form ctx wrld (cond ((null raw-bound-vars) (er soft ctx "The bound variables of a defchoose form must be non-empty. ~ The form ~x0 is therefore illegal." event-form)) (t (let ((fn (car def)) (bound-vars (if (atom raw-bound-vars) (list raw-bound-vars) raw-bound-vars)) (formals (caddr def)) (body (cadddr def))) (er-progn (chk-arglist-for-defchoose bound-vars t ctx state) (chk-arglist-for-defchoose formals nil ctx state) (er-let* ((tbody (translate body t t t ctx wrld state)) (wrld (chk-just-new-name fn nil 'function nil ctx wrld state))) (cond ((intersectp-eq bound-vars formals) (er soft ctx "The bound and free variables of a defchoose form must ~ not intersect, but their intersection for the form ~ ~x0 is ~x1." event-form (intersection-eq bound-vars formals))) (t (let* ((body-vars (all-vars tbody)) (bound-and-free-vars (append bound-vars formals)) (ignored (set-difference-eq bound-and-free-vars body-vars)) (ignore-ok (cdr (assoc-eq :ignore-ok (table-alist 'acl2-defaults-table wrld)))) (ignored-vars-string "The variable~#0~[ ~&0~ does~/s ~&0 do~] not occur ~ in the body of the form ~x1. However, ~#0~[this ~ variable~/each of these variables~] appears in ~ the bound variables or the formals of that form. ~ In order to avoid this error, see :DOC ~ set-ignore-ok.")) (cond ((not (subsetp-eq body-vars bound-and-free-vars)) (er soft ctx "All variables in the body of a defchoose form ~ must appear among the bound or free variables ~ supplied in that form. However, the ~ ~#0~[variable ~x0 does~/variables ~&0 do~] not ~ appear in the bound or free variables of the form ~ ~x1, even though ~#0~[it appears~/they appear~] ~ in its body." (reverse (set-difference-eq body-vars bound-and-free-vars)) event-form)) ((and ignored (null ignore-ok)) (er soft ctx ignored-vars-string ignored event-form)) (t (pprogn (cond ((and ignored (eq ignore-ok :warn)) (warning$ ctx "Ignored-variables" ignored-vars-string ignored event-form)) (t state)) (let* ((stobjs-in (compute-stobj-flags formals nil nil wrld)) (stobjs-out (compute-stobj-flags bound-vars nil nil wrld)) (wrld wrld) (wrld (putprop fn 'constrainedp t (putprop fn 'hereditarily-constrained-fnnames (list fn) (putprop fn 'symbol-class :common-lisp-compliant (putprop-unless fn 'stobjs-out stobjs-out nil (putprop-unless fn 'stobjs-in stobjs-in nil (putprop fn 'formals formals wrld)))))))) (er-let* ((constraint (defchoose-constraint fn bound-vars formals body tbody strengthen ctx wrld state))) (install-event fn event-form 'defchoose fn nil `(defuns nil nil (,FN ,FORMALS ,(NULL-BODY-ER FN FORMALS NIL))) :protect ctx (putprop fn 'defchoose-axiom constraint wrld) state))))))))))))))))))))))
*defun-sk-keywords*constant
(defconst *defun-sk-keywords* '(:quant-ok :skolem-name :thm-name :rewrite :strengthen :constrain :verbose))
non-acceptable-defun-sk-pfunction
(defun non-acceptable-defun-sk-p (name args body quant-ok rewrite exists-p dcls) (let ((bound-vars (and (true-listp body) (cadr body) (if (atom (cadr body)) (list (cadr body)) (cadr body))))) (cond ((and rewrite exists-p) (msg "It is illegal to supply a :rewrite argument for a defun-sk form ~ that uses the exists quantifier. See :DOC defun-sk.")) ((and (keywordp rewrite) (not (member-eq rewrite '(:direct :default)))) (msg "The only legal keyword values for the :rewrite argument of a ~ defun-sk are :direct and :default. ~x0 is thus illegal." rewrite)) ((not (and (plausible-dclsp dcls) (not (get-string dcls)))) (let ((str "The ~@0 of a DEFUN-SK event must be of the form (dcl ... ~ dcl), where each dcl is a DECLARE form. The DECLARE forms ~ may contain TYPE, IGNORE, and XARGS entries, where the ~ legal XARGS keys are ~&1. The following value for the ~@0 ~ is thus illegal: ~x2. See :DOC DEFUN-SK.")) (msg str "DECLARE forms" *xargs-keywords* dcls))) ((not (true-listp args)) (msg "The second argument of DEFUN-SK must be a true list of legal ~ variable names, but ~x0 is not a true-listp." args)) ((not (arglistp args)) (mv-let (culprit explan) (find-first-bad-arg args) (msg "The formal parameters (second argument) of a DEFUN-SK form must ~ be a true list of distinct, legal variable names. ~x0 is not ~ such a list. The element ~x1 violates the rules because it ~@2." args culprit explan))) ((not (and (true-listp body) (equal (length body) 3) (member-eq (car body) '(forall exists)) (true-listp bound-vars) (null (collect-non-legal-variableps bound-vars)))) (msg "The body (last argument) of a DEFUN-SK form must be a true list of ~ the form (Q vars term), where Q is ~x0 or ~x1 and vars is a ~ variable or a true list of variables. The body ~x2 is therefore ~ illegal." 'forall 'exists body)) ((member-eq 'state bound-vars) (msg "The body (last argument) of a DEFUN-SK form must be a true list of ~ the form (Q vars term), where vars represents the bound ~ variables. The bound variables must not include STATE. The body ~ ~x0 is therefore illegal." body)) ((null (cadr body)) (msg "The variables of the body of a DEFUN-SK, following the quantifier ~ EXISTS or FORALL, must be a non-empty list. However, in DEFUN-SK ~ of ~x0, they are empty." name)) ((intersectp-eq bound-vars args) (msg "The formal parameters of a DEFUN-SK form must be disjoint from ~ the variables bound by its body. However, the ~#0~[variable ~x0 ~ belongs~/variables ~&0 belong~] to both the formal parameters, ~ ~x1, and the bound variables, ~x2." (intersection-eq bound-vars args) args bound-vars)) ((and (not quant-ok) (or (tree-occur-eq 'forall (caddr body)) (tree-occur-eq 'exists (caddr body)))) (msg "The symbol ~x0 occurs in the term you have supplied to DEFUN-SK, ~ namely, ~x1. By default, this is not allowed. Perhaps you ~ believe that DEFUN-SK can appropriately handle quantifiers other ~ than one outermost quantifier; however, this is not the case. If ~ however you really intend this DEFUN-SK form to be executed, ~ simply give a non-nil :quant-ok argument. See :DOC defun-sk." (if (tree-occur-eq 'forall (caddr body)) 'forall 'exists) body)) (t nil))))
definition-rule-namefunction
(defun definition-rule-name (name) (declare (xargs :guard (symbolp name))) (add-suffix name "-DEFINITION"))
verify-guards?macro
(defmacro verify-guards? (guard-p &rest args) (declare (xargs :guard (booleanp guard-p))) (cond (guard-p `(make-event (if (int= (default-verify-guards-eagerness (w state)) 0) '(value-triple :skipped) '(verify-guards ,@ARGS)) :expansion? (verify-guards ,@ARGS))) (t `(make-event (if (member (default-verify-guards-eagerness (w state)) '(2 3)) '(verify-guards ,@ARGS) '(value-triple :skipped)) :expansion? (value-triple :skipped)))))
parse-defun-sk-dclsfunction
(defun parse-defun-sk-dcls (dcls) (let* ((guard-p (and (fetch-dcl-fields '(type :guard) dcls) t)) (verify-guards-fields (remove-duplicates-equal (fetch-dcl-field :verify-guards dcls))) (verify-guards-p (cond ((equal verify-guards-fields '(t)) t) ((equal verify-guards-fields '(nil)) nil) ((equal verify-guards-fields nil) '?) (t 'error))) (non-exec-p-fields (remove-duplicates-equal (fetch-dcl-field :non-executable dcls))) (non-exec-p (cond ((cdr non-exec-p-fields) 'error) ((consp non-exec-p-fields) (car non-exec-p-fields)) (t t))) (guard-hints-fields (fetch-dcl-field :guard-hints dcls)) (guard-hints (cond ((cdr guard-hints-fields) 'error) (t (car guard-hints-fields)))) (dcls (cons '(declare (xargs :verify-guards nil)) (strip-dcls '(:guard-hints) (if (eq verify-guards-p t) (strip-dcls '(:verify-guards) dcls) dcls)))) (dcls (let ((guards (fetch-dcl-fields '(:guard) dcls))) (cond ((member-equal guards '((t) ('t) nil)) (cons `(declare (xargs :guard t)) (strip-dcls '(:guard) dcls))) (t dcls))))) (cond ((or (eq verify-guards-p 'error) (eq non-exec-p 'error) (eq guard-hints 'error)) (mv (msg "There are at least two~#0~[~/ distinct~] values ~ associated with XARGS declaration keyword ~x1. See :DOC ~ defun-sk." (if (eq guard-hints 'error) 0 1) (if (eq verify-guards-p 'error) :verify-guards (if (eq non-exec-p 'error) :non-executable :guard-hints))) nil nil nil nil nil)) (t (mv nil guard-p verify-guards-p non-exec-p guard-hints dcls)))))
map-with-outputfunction
(defun map-with-output (kwd arg forms) (declare (xargs :guard (true-listp forms))) (pairlis-x1 'with-output (pairlis-x1 kwd (pairlis-x1 arg (pairlis$ forms nil)))))
defun-sk-fnfunction
(defun defun-sk-fn (form name args rest) (declare (xargs :mode :program)) (let ((ctx `(defun-sk . ,NAME))) (mv-let (erp dcls-and-body keyword-alist) (partition-rest-and-keyword-args rest *defun-sk-keywords*) (cond (erp (er hard ctx "The keyword arguments to the DEFUN-SK event must appear after ~ the body. The allowed keyword arguments are ~&0, and these may ~ not be duplicated. Thus, ~x1 is ill-formed." *defun-sk-keywords* form)) (t (let* ((quant-ok (cdr (assoc-eq :quant-ok keyword-alist))) (skolem-name (cdr (assoc-eq :skolem-name keyword-alist))) (thm-name (cdr (assoc-eq :thm-name keyword-alist))) (constrained-pair (assoc-eq :constrain keyword-alist)) (constrained (cdr constrained-pair)) (verbose (cdr (assoc-eq :verbose keyword-alist))) (def-name (cond ((eq constrained t) (definition-rule-name name)) ((symbolp constrained) constrained) (t (er hard ctx "The :constrain argument of DEFUN-SK ~ must be a symbol, but ~x0 is not." constrained)))) (rewrite (cdr (assoc-eq :rewrite keyword-alist))) (strengthen (cdr (assoc-eq :strengthen keyword-alist))) (dcls0 (butlast dcls-and-body 1)) (body (car (last dcls-and-body))) (exists-p (and (true-listp body) (eq (car body) 'exists))) (msg (non-acceptable-defun-sk-p name args body quant-ok rewrite exists-p dcls0))) (if msg `(er soft ',CTX "~@0" ',MSG) (mv-let (erp guard-p verify-guards-p non-exec-p guard-hints dcls) (parse-defun-sk-dcls dcls0) (if erp `(er soft ',CTX "~@0" ',ERP) (let* ((bound-vars (and (true-listp body) (or (symbolp (cadr body)) (true-listp (cadr body))) (cond ((atom (cadr body)) (list (cadr body))) (t (cadr body))))) (body-guts (and (true-listp body) (caddr body))) (defchoose-body (if exists-p body-guts `(not ,BODY-GUTS))) (skolem-name (or skolem-name (add-suffix name "-WITNESS"))) (stobjs (fetch-dcl-field :stobjs dcls)) (dfs (fetch-dcl-field :dfs dcls)) (skolem-call `(,SKOLEM-NAME ,@ARGS)) (skolem-call (if (or stobjs dfs) `(non-exec ,SKOLEM-CALL) skolem-call)) (defun-body (if (= (length bound-vars) 1) `(let ((,(CAR BOUND-VARS) ,SKOLEM-CALL)) ,BODY-GUTS) `(mv-let (,@BOUND-VARS) ,SKOLEM-CALL ,BODY-GUTS))) (thm-name (or thm-name (add-suffix name (if exists-p "-SUFF" "-NECC")))) (defun-form `(,(IF NON-EXEC-P 'DEFUN-NX 'DEFUN) ,NAME ,ARGS ,@DCLS ,DEFUN-BODY)) (defun-constraint (and constrained `(defthm ,DEF-NAME (equal (,NAME ,@ARGS) ,DEFUN-BODY) :rule-classes :definition))) (encap-forms `((logic) (set-match-free-default :all) (set-inhibit-warnings "Theory" "Use" "Free" "Non-rec" "Infected") (encapsulate (((,SKOLEM-NAME ,@(MAKE-LIST (LENGTH ARGS) :INITIAL-ELEMENT '*)) => ,(IF (= (LENGTH BOUND-VARS) 1) '* (CONS 'MV (MAKE-LIST (LENGTH BOUND-VARS) :INITIAL-ELEMENT '*)))) ,@(AND CONSTRAINED `((,NAME ,ARGS T ,@(AND STOBJS `(:STOBJS ,@STOBJS)) ,@(AND DFS `(:DFS ,@DFS)) ,@(AND GUARD-P (MV-LET (IGN GUARD) (DCLS-GUARD-RAW-FROM-DEF (CDR DEFUN-FORM) NIL) (DECLARE (IGNORE IGN)) `(:GUARD ,GUARD))))))) (local (in-theory '(implies))) (local (encapsulate nil (set-ignore-ok t) (defchoose ,SKOLEM-NAME ,BOUND-VARS ,ARGS ,DEFCHOOSE-BODY ,@(AND STRENGTHEN '(:STRENGTHEN T))))) ,@(AND STRENGTHEN `((DEFTHM ,(ADD-SUFFIX SKOLEM-NAME "-STRENGTHEN") ,(DEFCHOOSE-CONSTRAINT-EXTRA SKOLEM-NAME BOUND-VARS ARGS DEFCHOOSE-BODY) :HINTS (("Goal" :USE ,SKOLEM-NAME :IN-THEORY (THEORY 'MINIMAL-THEORY))) :RULE-CLASSES NIL))) ,@(COND (CONSTRAINED `((LOCAL ,DEFUN-FORM) ,DEFUN-CONSTRAINT (LOCAL (IN-THEORY (DISABLE (,NAME)))))) (T `(,DEFUN-FORM (IN-THEORY (DISABLE (,NAME)))))) (defthm ,THM-NAME ,(COND (EXISTS-P `(IMPLIES ,BODY-GUTS (,NAME ,@ARGS))) ((EQ REWRITE :DIRECT) `(IMPLIES (,NAME ,@ARGS) ,BODY-GUTS)) ((MEMBER-EQ REWRITE '(NIL :DEFAULT)) `(IMPLIES (NOT ,BODY-GUTS) (NOT (,NAME ,@ARGS)))) (T REWRITE)) :hints (("Goal" :use (,SKOLEM-NAME ,NAME) :in-theory (theory 'minimal-theory))))) (extend-pe-table ,NAME ,FORM) ,@(AND (NOT CONSTRAINED) (CASE VERIFY-GUARDS-P ((T) `((VERIFY-GUARDS ,NAME ,@(AND GUARD-HINTS (LIST :HINTS GUARD-HINTS))))) ((NIL) NIL) (OTHERWISE `((VERIFY-GUARDS? ,GUARD-P ,NAME ,@(AND GUARD-HINTS (LIST :HINTS GUARD-HINTS))))))) (value-triple '(:return-value ,NAME) :on-skip-proofs t)))) (cond (verbose `(encapsulate nil ,@ENCAP-FORMS)) (t `(with-output :off (:other-than error summary) :ctx ',CTX :summary-off value :gag-mode nil (encapsulate nil ,@(MAP-WITH-OUTPUT :OFF 'SUMMARY ENCAP-FORMS)))))))))))))))
tameness-conditionsfunction
(defun tameness-conditions (ilks var) (declare (xargs :mode :program)) (cond ((endp ilks) nil) ((eq (car ilks) :fn) (cons `(tamep-functionp (car ,VAR)) (tameness-conditions (cdr ilks) (list 'cdr var)))) ((eq (car ilks) :expr) (cons `(tamep (car ,VAR)) (tameness-conditions (cdr ilks) (list 'cdr var)))) (t (tameness-conditions (cdr ilks) (list 'cdr var)))))
successive-cadrsfunction
(defun successive-cadrs (formals var) (declare (xargs :mode :program)) (cond ((endp formals) nil) (t (cons `(car ,VAR) (successive-cadrs (cdr formals) (list 'cdr var))))))
make-apply$-warrant-defun-skfunction
(defun make-apply$-warrant-defun-sk (fn formals bdg trans1-flg) (let* ((name (warrant-name fn)) (form (cond ((eq (access apply$-badge bdg :ilks) t) `(defun-sk ,NAME nil (forall (args) (and (equal (badge-userfn ',FN) ',BDG) (equal (apply$-userfn ',FN args) ,(IF (EQL (ACCESS APPLY$-BADGE BDG :OUT-ARITY) 1) `(,FN ,@(SUCCESSIVE-CADRS FORMALS 'ARGS)) `(MV-LIST ',(ACCESS APPLY$-BADGE BDG :OUT-ARITY) (,FN ,@(SUCCESSIVE-CADRS FORMALS 'ARGS))))))) :constrain t)) (t (let* ((hyp-list (tameness-conditions (access apply$-badge bdg :ilks) 'args)) (hyp (if (null (cdr hyp-list)) (car hyp-list) `(and ,@HYP-LIST)))) `(defun-sk ,NAME nil (forall (args) (implies ,HYP (and (equal (badge-userfn ',FN) ',BDG) (equal (apply$-userfn ',FN args) ,(IF (EQL (ACCESS APPLY$-BADGE BDG :OUT-ARITY) 1) `(,FN ,@(SUCCESSIVE-CADRS FORMALS 'ARGS)) `(MV-LIST ',(ACCESS APPLY$-BADGE BDG :OUT-ARITY) (,FN ,@(SUCCESSIVE-CADRS FORMALS 'ARGS)))))))) :constrain t)))))) (cond ((null trans1-flg) form) (t (let* ((defun-sk-event (defun-sk-fn form name nil (cdddr form))) (with-output-p (eq (car defun-sk-event) 'with-output)) (defun-sk-event (if with-output-p (car (last defun-sk-event)) defun-sk-event)) (crux (nth 5 defun-sk-event)) (crux (if with-output-p (car (last crux)) crux)) (constrained-fn (and (consp crux) (eq (car crux) 'encapsulate) (consp (nth 1 crux)) (consp (car (nth 1 crux))) (consp (car (car (nth 1 crux)))) (car (car (car (nth 1 crux))))))) (cond ((eq constrained-fn (add-suffix name "-WITNESS")) crux) (t (er hard 'make-apply$-warrant-defun-sk "Make-apply$-warrant-defun-sk, when called on the function ~ symbol ~x0, expected to find an ENCAPSULATE constraining ~ ~x1 as the 5th element of the form created by ~ DEFUN-SK-EVENT. But that sanity check failed. This ~ indicates that make-apply$-warrant-defun-sk and ~ defun-sk-event are no longer in sync. Please advise the ~ ACL2 implementors!" name (add-suffix name "-WITNESS")))))))))
defun-skmacro
(defmacro defun-sk (&whole form name args &rest rest) (defun-sk-fn form name args rest))
doublet-style-symbol-to-symbol-alistpfunction
(defun doublet-style-symbol-to-symbol-alistp (x) (cond ((atom x) (equal x nil)) (t (and (consp (car x)) (symbolp (caar x)) (consp (cdar x)) (symbolp (cadar x)) (null (cddar x)) (doublet-style-symbol-to-symbol-alistp (cdr x))))))
chk-legal-defstobj-namefunction
(defun chk-legal-defstobj-name (name state) (cond ((eq name 'state) (er soft (cons 'defstobj name) "STATE is an illegal name for a user-declared ~ single-threaded object.")) ((string-prefixp *with-global-stobj-prefix* (symbol-name name)) (er soft (cons 'defstobj name) "The name ~x0 is not a legal stobj name because its name starts ~ with ~x1. Such names are reserved for use in the expansions of ~ ~x2 calls." name *with-global-stobj-prefix* 'with-global-stobj)) ((legal-variablep name) (value nil)) (t (er soft (cons 'defstobj name) "The symbol ~x0 may not be declared as a single-threaded object ~ name because it is not a legal variable name." name))))
chk-unrestricted-guards-for-type-spec-termfunction
(defun chk-unrestricted-guards-for-type-spec-term (names wrld ctx state) (cond ((null names) (value nil)) ((or (not (eq (arity (car names) wrld) 1)) (equal (guard (car names) nil wrld) *t*)) (chk-unrestricted-guards-for-type-spec-term (cdr names) wrld ctx state)) (t (er soft ctx "The guard for ~x0 is ~p1. But in order to use ~x0 in the ~ type-specification of a single-threaded object it must ~ have a guard of T." (car names) (untranslate (guard (car names) nil wrld) t wrld)))))
non-common-lisp-compliants-in-satisfiesmutual-recursion
(mutual-recursion (defun non-common-lisp-compliants-in-satisfies (type wrld) (cond ((atom type) (mv nil nil)) ((or (eq (car type) 'not) (eq (car type) 'complex)) (non-common-lisp-compliants-in-satisfies (cadr type) wrld)) ((or (eq (car type) 'and) (eq (car type) 'or)) (non-common-lisp-compliants-in-satisfies-lst (cdr type) wrld)) ((consp type) (if (eq (car type) 'satisfies) (mv t (if (eq (symbol-class (cadr type) wrld) :common-lisp-compliant) nil (list (cadr type)))) (mv nil nil))) (t (mv nil nil)))) (defun non-common-lisp-compliants-in-satisfies-lst (lst wrld) (cond ((endp lst) (mv nil nil)) (t (mv-let (flg1 fns1) (non-common-lisp-compliants-in-satisfies (car lst) wrld) (mv-let (flg2 fns2) (non-common-lisp-compliants-in-satisfies-lst (cdr lst) wrld) (mv (or flg1 flg2) (union-eq fns1 fns2))))))))
chk-stobj-field-type-termfunction
(defun chk-stobj-field-type-term (term type init field name type-string ctx wrld state) (er-let* ((pair (simple-translate-and-eval term (list (cons 'x init)) nil (msg "The type ~x0" term) ctx wrld state nil))) (mv-let (flg bad-fns) (non-common-lisp-compliants-in-satisfies type wrld) (cond (bad-fns (er soft ctx "The type specifier for the ~x0 field of the proposed stobj, ~x1, ~ applies SATISFIES to the function symbol~#2~[ ~&2, the guard of ~ which has~/s ~&2, the guards of which have~] not yet been ~ verified. See :DOC defstobj." field name bad-fns)) ((not (cdr pair)) (er soft ctx "The value specified by the :initially keyword, namely ~x0, fails ~ to satisfy the declared type ~x1~@2 for the ~x3 field of ~x4." init type type-string field name)) ((null flg) (value nil)) (t (mv-let (cl-set ttree) (guard-clauses+ (car pair) nil t nil :do-not-simplify wrld nil nil nil nil) (assert$ (eq ttree nil) (mv-let (cl-set ttree) (clean-up-clause-set cl-set nil wrld nil state) (declare (ignore ttree)) (cond ((null cl-set) (value nil)) (t (er soft ctx "The type specifier for the ~x0 field of the proposed ~ stobj, ~x1, produces the term, ~x2, which ACL2 is ~ unable to check is guard-verified. See :DOC defstobj." field name term)))))))))))
chk-stobj-field-etypefunction
(defun chk-stobj-field-etype (etype type field name initp init arrayp non-memoizable child-stobj-memoizable-error-string ctx wrld state) (let* ((stobjp (stobjp etype t wrld)) (etype-term (and (not stobjp) (translate-declaration-to-guard etype 'x wrld))) (etype-error-string "The element type specified for the ~x0 field of ~x1, namely ~x2, ~ is not recognized by ACL2 as a type-spec (see :DOC type-spec) or ~ as a user-defined stobj name.")) (cond (stobjp (cond ((eq etype 'state) (er soft ctx etype-error-string field name etype)) ((and non-memoizable (not (getpropc etype 'non-memoizable nil wrld))) (er soft ctx child-stobj-memoizable-error-string name etype)) ((null initp) (value nil)) (t (er soft ctx "The :initially keyword must be omitted for a :type ~ specified as an array of stobjs or a hash-table of ~ stobjs. But for :type ~x0, :initially is specified as ~ ~x1 for the ~x2 field of ~x3." type init field name)))) ((null etype-term) (er soft ctx etype-error-string field name etype)) (t (chk-stobj-field-type-term etype-term etype init field name (msg " in the ~@0 specification" (if arrayp "array" "hash-table")) ctx wrld state)))))
chk-stobj-field-descriptorfunction
(defun chk-stobj-field-descriptor (name field-descriptor non-memoizable ctx wrld state) (cond ((symbolp field-descriptor) (value nil)) (t (er-progn (cond ((and (consp field-descriptor) (symbolp (car field-descriptor)) (keyword-value-listp (cdr field-descriptor)) (member-equal (length field-descriptor) '(1 3 5 7 9)) (let ((keys (odds field-descriptor))) (and (no-duplicatesp keys) (subsetp-eq keys '(:type :element-type :initially :resizable))))) (value nil)) (t (er soft ctx "The field descriptors of a single-threaded object ~ definition must be a symbolic field-name or a list of the ~ form (field-name :type type :initially val), where ~ field-name is a symbol. The :type and :initially keyword ~ assignments are optional and their order is irrelevant. ~ The purported descriptor ~x0 for a field in ~x1 is not of ~ this form." field-descriptor name))) (let* ((field (car field-descriptor)) (type (if (assoc-keyword :type (cdr field-descriptor)) (cadr (assoc-keyword :type (cdr field-descriptor))) t)) (element-type (cadr (assoc-keyword :element-type (cdr field-descriptor)))) (initp (assoc-keyword :initially (cdr field-descriptor))) (init (if initp (cadr initp) nil)) (resizable (if (assoc-keyword :resizable (cdr field-descriptor)) (cadr (assoc-keyword :resizable (cdr field-descriptor))) nil)) (child-stobj-memoizable-error-string "It is illegal to declare stobj ~x0 as :NON-MEMOIZABLE, because ~ it has a child stobj, ~x1, that was not thus declared. See ~ :DOC defstobj.")) (cond ((and resizable (not (eq resizable t))) (er soft ctx "The :resizable value in the ~x0 field of ~x1 is illegal: ~x2. ~ The legal values are t and nil." field name resizable)) ((and (consp type) (eq (car type) 'array)) (cond ((not (and (true-listp type) (equal (length type) 3) (true-listp (caddr type)) (equal (length (caddr type)) 1))) (er soft ctx "When a field descriptor specifies an ARRAY :type, the type ~ must be of the form (ARRAY etype (n)). Note that we only ~ support single-dimensional arrays. The purported ARRAY :type ~ ~x0 for the ~x1 field of ~x2 is not of this form." type field name)) (t (let* ((type0 (fix-stobj-array-type type wrld)) (etype (cadr type0)) (n (car (caddr type0)))) (cond ((not (natp n)) (er soft ctx "An array dimension must be a non-negative integer or a ~ defined constant whose value is a non-negative integer. ~ ~ The :type ~x0 for the ~x1 field of ~x2 is thus ~ illegal." type0 field name)) ((and element-type (not (or (eq element-type t) (equal element-type etype)))) (er soft ctx "When the :element-type keyword is specified for a stobj ~ array field, it must be either T or the type specified ~ for the elements of the array by its :type keyword. ~ The :element-type of ~x0 is thus illegal for :type ~x1." element-type type)) (t (chk-stobj-field-etype etype type field name initp init t non-memoizable child-stobj-memoizable-error-string ctx wrld state))))))) ((or element-type (assoc-keyword :resizable (cdr field-descriptor))) (er soft ctx "The ~#0~[:resizable~/:element-type~] keyword is only legal for ~ array types, hence is illegal for the ~x1 field of ~x2." (if element-type 1 0) field name)) ((and (consp type) (eq (car type) 'hash-table)) (cond ((not (and (true-listp type) (member (length type) '(2 3 4)))) (er soft ctx "A hash-table type must be a true-list of length 2, 3, or ~ 4. The type ~x0 is thus illegal. See :DOC defstobj.~%" type)) (t (let* ((type (fix-stobj-hash-table-type type wrld)) (test (stobj-hash-table-test type)) (size (stobj-hash-table-init-size type)) (etype (stobj-hash-table-element-type type))) (cond ((not (member-eq test '(eq eql equal hons-equal))) (er soft ctx "A hash-table test must be ~v0. The test ~ given was ~x1. See :DOC defstobj.~%" '(eq eql hons-equal equal) test)) ((and size (not (natp size))) (er soft ctx "A hash-table type must specify the size (the ~ optional second argument) as nil or a natural ~ number, either directly or using a defined ~ constant. The type ~x0 is thus illegal. See ~ :DOC defstobj.~%" type)) ((not (eq etype t)) (chk-stobj-field-etype etype type field name initp init nil non-memoizable child-stobj-memoizable-error-string ctx wrld state)) (t (value nil))))))) ((and (consp type) (eq (car type) 'stobj-table)) (cond ((not (and (true-listp type) (member (length type) '(1 2)))) (er soft ctx "A stobj-table type must be a true-list of length 1 or 2, ~ interpreted as (STOBJ-TABLE) or (STOBJ-TABLE SIZE). The ~ type ~x0 is thus illegal.~%" type)) (t (let ((type (fix-stobj-table-type type wrld))) (cond ((and (cdr type) (not (natp (cadr type)))) (er soft ctx "A stobj-table type of the form (STOBJ-TABLE ~ SIZE) must specify SIZE as a natural number, ~ either directly or using a defined constant. ~ The type ~x0 is thus illegal.~%" type)) (t (value nil))))))) (t (let* ((stobjp (stobjp type t wrld)) (type-term (and (not stobjp) (translate-declaration-to-guard type 'x wrld))) (type-error-string "The :type specified for the ~x0 field of ~x1, namely ~x2, ~ is not recognized by ACL2 as a type-spec (see :DOC ~ type-spec) or as a user-defined stobj name.")) (cond (stobjp (cond ((eq type 'state) (er soft ctx type-error-string field name type)) ((and non-memoizable (not (getpropc type 'non-memoizable nil wrld))) (er soft ctx child-stobj-memoizable-error-string name type)) ((null initp) (value nil)) (t (er soft ctx "The :initially keyword must be omitted for a ~ :type specified as a stobj. But for :type ~x0, ~ :initially is specified as ~x1 for the ~x2 field ~ of ~x3." type init field name)))) ((null type-term) (er soft ctx type-error-string field name type)) (t (chk-stobj-field-type-term type-term type init field name "" ctx wrld state)))))))))))
chk-acceptable-defstobj-renamingfunction
(defun chk-acceptable-defstobj-renaming (name field-descriptors renaming ctx state default-names) (cond ((endp field-descriptors) (let ((default-names (list* (defstobj-fnname name :recognizer :top nil) (defstobj-fnname name :creator :top nil) (reverse default-names))) (domain (strip-cars renaming))) (cond ((null renaming) (cond ((not (no-duplicatesp-eq default-names)) (er soft ctx "The field descriptors are illegal because they require ~ the use of the same name for two different functions. ~ The duplicated name~#0~[ is~/s are~] ~&0. You must ~ change the component names so that no conflict occurs. ~ ~ You may then wish to use the :RENAMING option to ~ introduce your own names for these functions. See ~ :DOC defstobj." (duplicates default-names))) (t (value nil)))) ((not (no-duplicatesp-eq default-names)) (er soft ctx "The field descriptors are illegal because they require ~ the use of the same default name for two different ~ functions. The duplicated default name~#0~[ is~/s are~] ~ ~&0. You must change the component names so that no ~ conflict occurs. Only then may you use the :RENAMING ~ option to rename the default names." (duplicates default-names))) ((not (no-duplicatesp-eq domain)) (er soft ctx "No two entries in the :RENAMING alist may mention the ~ same target symbol. Your alist, ~x0, contains ~ duplications in its domain." renaming)) ((not (subsetp domain default-names)) (er soft ctx "Your :RENAMING alist, ~x0, mentions ~#1~[a function ~ symbol~/function symbols~] in its domain which ~ ~#1~[is~/are~] not among the default symbols to be ~ renamed. The offending symbol~#1~[ is~/s are~] ~&1. ~ The default defstobj names for this event are ~&2." renaming (set-difference-equal domain default-names) default-names)) (t (value nil))))) (t (let* ((field (if (atom (car field-descriptors)) (car field-descriptors) (car (car field-descriptors)))) (type (if (consp (car field-descriptors)) (or (cadr (assoc-keyword :type (cdr (car field-descriptors)))) t) t)) (key2 (defstobj-fnname-key2 type))) (chk-acceptable-defstobj-renaming name (cdr field-descriptors) renaming ctx state (list* (defstobj-fnname field :updater key2 nil) (defstobj-fnname field :accessor key2 nil) (defstobj-fnname field :recognizer key2 nil) (cond ((eq key2 :array) (list* (defstobj-fnname field :length key2 nil) (defstobj-fnname field :resize key2 nil) default-names)) ((or (eq key2 :hash-table) (eq key2 :stobj-table)) (list* (defstobj-fnname field :boundp key2 nil) (defstobj-fnname field :accessor? key2 nil) (defstobj-fnname field :remove key2 nil) (defstobj-fnname field :count key2 nil) (defstobj-fnname field :clear key2 nil) (defstobj-fnname field :init key2 nil) default-names)) (t default-names))))))))
chk-acceptable-defstobj1function
(defun chk-acceptable-defstobj1 (name field-descriptors ftemps renaming non-memoizable ctx wrld state names const-names) (cond ((endp ftemps) (let* ((recog-name (defstobj-fnname name :recognizer :top renaming)) (creator-name (defstobj-fnname name :creator :top renaming)) (names (list* recog-name creator-name names))) (er-progn (chk-all-but-new-name recog-name ctx 'function wrld state) (chk-all-but-new-name creator-name ctx 'function wrld state) (chk-acceptable-defstobj-renaming name field-descriptors renaming ctx state nil) (cond ((and renaming (not (no-duplicatesp-eq names))) (er soft ctx "The field descriptors are illegal because they require the ~ use of the same name for two different functions. The ~ duplicated name~#0~[ is~/s are~] ~&0. You must change the ~ supplied :RENAMING option so that no conflict occurs." (duplicates names))) (t (value nil))) (chk-just-new-names names 'function nil ctx wrld state) (chk-just-new-names const-names 'const nil ctx wrld state)))) (t (er-progn (chk-stobj-field-descriptor name (car ftemps) non-memoizable ctx wrld state) (let* ((field (if (atom (car ftemps)) (car ftemps) (car (car ftemps)))) (type (if (consp (car ftemps)) (or (cadr (assoc-keyword :type (cdr (car ftemps)))) t) t)) (key2 (defstobj-fnname-key2 type)) (boundp-name (defstobj-fnname field :boundp key2 renaming)) (accessor?-name (defstobj-fnname field :accessor? key2 renaming)) (remove-name (defstobj-fnname field :remove key2 renaming)) (count-name (defstobj-fnname field :count key2 renaming)) (clear-name (defstobj-fnname field :clear key2 renaming)) (init-name (defstobj-fnname field :init key2 renaming)) (fieldp-name (defstobj-fnname field :recognizer key2 renaming)) (accessor-name (defstobj-fnname field :accessor key2 renaming)) (accessor-const-name (defconst-name accessor-name)) (updater-name (defstobj-fnname field :updater key2 renaming)) (length-name (defstobj-fnname field :length key2 renaming)) (resize-name (defstobj-fnname field :resize key2 renaming))) (er-progn (chk-all-but-new-name fieldp-name ctx 'function wrld state) (chk-all-but-new-name accessor-name ctx 'function wrld state) (chk-all-but-new-name updater-name ctx 'function wrld state) (chk-all-but-new-name accessor-const-name ctx 'const wrld state) (cond ((eq key2 :array) (er-progn (chk-all-but-new-name length-name ctx 'function wrld state) (chk-all-but-new-name resize-name ctx 'function wrld state))) ((or (eq key2 :hash-table) (eq key2 :stobj-table)) (er-progn (chk-all-but-new-name boundp-name ctx 'function wrld state) (if (eq key2 :hash-table) (chk-all-but-new-name accessor?-name ctx 'function wrld state) (value nil)) (chk-all-but-new-name remove-name ctx 'function wrld state) (chk-all-but-new-name count-name ctx 'function wrld state) (chk-all-but-new-name init-name ctx 'function wrld state) (chk-all-but-new-name clear-name ctx 'function wrld state))) (t (value nil))) (chk-acceptable-defstobj1 name field-descriptors (cdr ftemps) renaming non-memoizable ctx wrld state (list* fieldp-name accessor-name updater-name (cond ((eq key2 :array) (list* length-name resize-name names)) ((eq key2 :hash-table) (list* boundp-name accessor?-name remove-name count-name clear-name init-name names)) ((eq key2 :stobj-table) (list* boundp-name remove-name count-name clear-name init-name names)) (t names))) (cons accessor-const-name const-names))))))))
old-field-descriptorsfunction
(defun old-field-descriptors (name wrld) (assert$ (getpropc name 'stobj nil wrld) (let ((ev (get-event name wrld))) (and ev (assert$ (and (eq (car ev) 'defstobj) (eq (cadr ev) name)) (mv-let (erp field-descriptors key-alist) (partition-rest-and-keyword-args (cddr ev) *defstobj-keywords*) (declare (ignore key-alist)) (and (null erp) field-descriptors)))))))
redundant-defstobjpfunction
(defun redundant-defstobjp (name args wrld) (and (getpropc name 'stobj nil wrld) (let ((ev (get-event name wrld))) (and ev (eq (car ev) 'defstobj) (eq (cadr ev) name) (equal (cddr ev) args)))))
congruent-stobj-fieldsfunction
(defun congruent-stobj-fields (fields1 fields2) (cond ((endp fields1) (null fields2)) (t (let ((x1 (car fields1)) (x2 (car fields2))) (and (if (symbolp x1) (symbolp x2) (and (consp x1) (consp x2) (equal (cdr x1) (cdr x2)))) (congruent-stobj-fields (cdr fields1) (cdr fields2)))))))
chk-acceptable-defstobjfunction
(defun chk-acceptable-defstobj (name args ctx wrld state) (cond ((not (symbolp name)) (er soft ctx "The first argument of a DEFSTOBJ event must be a symbol. Thus, ~x0 ~ is ill-formed." (list* 'defstobj name args))) (t (mv-let (erp field-descriptors key-alist) (partition-rest-and-keyword-args args *defstobj-keywords*) (cond (erp (er soft ctx "The keyword arguments to the DEFSTOBJ event must appear after all ~ field descriptors. The allowed keyword arguments are ~&0, and ~ these may not be duplicated, and must be followed by the ~ corresponding value of the keyword argument. Thus, ~x1 is ~ ill-formed." *defstobj-keywords* (list* 'defstobj name args))) ((redundant-defstobjp name args wrld) (value 'redundant)) (t (let ((renaming (cdr (assoc-eq :renaming key-alist))) (inline (cdr (assoc-eq :inline key-alist))) (congruent-to (cdr (assoc-eq :congruent-to key-alist))) (non-memoizable (cdr (assoc-eq :non-memoizable key-alist))) (non-executable (cdr (assoc-eq :non-executable key-alist)))) (cond ((not (booleanp inline)) (er soft ctx "DEFSTOBJ requires the :INLINE keyword argument to have a ~ Boolean value. See :DOC defstobj.")) ((not (and (booleanp non-memoizable) (booleanp non-executable))) (er soft ctx "DEFSTOBJ requires the ~x0 keyword argument to ~ have a Boolean value. See :DOC defstobj." (if (booleanp non-memoizable) :non-executable :non-memoizable))) ((and congruent-to (not (stobjp congruent-to t wrld))) (er soft ctx "The :CONGRUENT-TO field of a DEFSTOBJ must either be nil or ~ the name of an existing stobj, but the value ~x0 is neither. ~ See :DOC defstobj." congruent-to)) ((and congruent-to (getpropc congruent-to 'absstobj-info nil wrld)) (er soft ctx "The symbol ~x0 is the name of an abstract stobj in the ~ current ACL2 world, so it is not legal for use as the ~ :CONGRUENT-TO argument of DEFSTOBJ." congruent-to)) ((and congruent-to (not (congruent-stobj-fields field-descriptors (old-field-descriptors congruent-to wrld)))) (er soft ctx "A non-nil :CONGRUENT-TO field of a DEFSTOBJ must be the name ~ of a stobj that has the same shape as the proposed new stobj. ~ ~ However, the proposed stobj named ~x0 does not have the ~ same shape as the existing stobj named ~x1. See :DOC ~ defstobj." name congruent-to)) ((and congruent-to (not (eq non-memoizable (getpropc congruent-to 'non-memoizable nil wrld)))) (er soft ctx "Congruent stobjs must agree on whether or not they are ~ specified as :NON-MEMOIZABLE. However, this fails for the ~ proposed stobj, ~x0, which is specified as :CONGRUENT-TO the ~ stobj ~x1, since ~x2 is specified with :NON-MEMOIZABLE T but ~ ~x3 is not. See :DOC defstobj." name congruent-to (if non-memoizable name congruent-to) (if non-memoizable congruent-to name))) (t (er-progn (chk-all-but-new-name name ctx 'stobj wrld state) (cond ((member-eq name '(i v k ht-size rehash-size rehash-threshold)) (er soft ctx "DEFSTOBJ does not allow single-threaded objects with ~ the names ~v0, because those symbols may be used as ~ formals, along with the new stobj name itself, in ~ ``primitive'' stobj functions that will be defined." '(i v k ht-size rehash-size rehash-threshold))) (t (value nil))) (chk-legal-defstobj-name name state) (cond ((not (doublet-style-symbol-to-symbol-alistp renaming)) (er soft ctx "The :RENAMING argument to DEFSTOBJ must be an alist ~ containing elements of the form (sym sym), where each ~ element of such a doublet is a symbol. Your argument, ~ ~x0, is thus illegal." renaming)) (t (value nil))) (er-let* ((wrld1 (chk-just-new-name name nil 'stobj nil ctx wrld state)) (wrld2 (chk-just-new-name (the-live-var name) nil 'stobj-live-var nil ctx wrld1 state))) (chk-acceptable-defstobj1 name field-descriptors field-descriptors renaming non-memoizable ctx wrld2 state nil nil))))))))))))
defstobj-field-fns-axiomatic-defsfunction
(defun defstobj-field-fns-axiomatic-defs (top-recog var n field-templates wrld) (cond ((endp field-templates) nil) (t (let* ((field-template (car field-templates)) (type (access defstobj-field-template field-template :type)) (arrayp (and (consp type) (eq (car type) 'array))) (hashp (and (consp type) (eq (car type) 'hash-table))) (init0 (access defstobj-field-template field-template :init)) (etype (cond (arrayp (cadr type)) (hashp (stobj-hash-table-element-type type)) (t nil))) (creator (get-stobj-creator (or etype type) wrld)) (init (if creator `(non-exec (,CREATOR)) (and init0 (kwote init0)))) (hash-test (and hashp (stobj-hash-table-test type))) (stobj-tablep (and (consp type) (eq (car type) 'stobj-table))) (stobjp (cond (etype (and (not (eq etype 'state)) (stobjp etype t wrld))) (t (and (not (eq type 'state)) (stobjp type t wrld))))) (stobj-formal (and stobjp (or etype type))) (v-formal (or stobj-formal 'v)) (stobj-xargs (and stobj-formal `(:stobjs ,STOBJ-FORMAL))) (type-term (and (not arrayp) (not hashp) (not stobj-tablep) (if (or (null wrld) stobj-formal) t (translate-declaration-to-guard type v-formal wrld)))) (etype-term (and (or arrayp hashp) (if (or (null wrld) stobj-formal) t (translate-declaration-to-guard etype v-formal wrld)))) (array-length (and arrayp (car (caddr type)))) (accessor-name (access defstobj-field-template field-template :accessor-name)) (updater-name (access defstobj-field-template field-template :updater-name)) (length-name (access defstobj-field-template field-template :length-name)) (resize-name (access defstobj-field-template field-template :resize-name)) (resizable (access defstobj-field-template field-template :resizable)) (other (access defstobj-field-template field-template :other)) (boundp-name (nth 0 other)) (accessor?-name (nth 1 other)) (remove-name (nth 2 other)) (count-name (nth 3 other)) (clear-name (nth 4 other)) (init-name (nth 5 other))) (cond (arrayp (append `((,LENGTH-NAME (,VAR) (declare (xargs :guard (,TOP-RECOG ,VAR) :verify-guards t) ,@(AND (NOT RESIZABLE) `((IGNORE ,VAR)))) ,(IF RESIZABLE `(LEN (NTH ,N ,VAR)) ARRAY-LENGTH)) (,RESIZE-NAME (i ,VAR) (declare (xargs :guard (,TOP-RECOG ,VAR) :verify-guards t) ,@(AND (NOT RESIZABLE) '((IGNORE I)))) ,(IF RESIZABLE `(UPDATE-NTH ,N (RESIZE-LIST (NTH ,N ,VAR) I ,INIT) ,VAR) `(PROG2$ (HARD-ERROR ',RESIZE-NAME "The array field corresponding to accessor ~x0 of ~ stobj ~x1 was not declared :resizable t. ~ Therefore, it is illegal to resize this array." (LIST (CONS #\0 ',ACCESSOR-NAME) (CONS #\1 ',VAR))) ,VAR))) (,ACCESSOR-NAME (i ,VAR) (declare (xargs :guard (and (,TOP-RECOG ,VAR) (integerp i) (<= 0 i) (< i (,LENGTH-NAME ,VAR))) :verify-guards t)) (nth i (nth ,N ,VAR))) (,UPDATER-NAME (i ,V-FORMAL ,VAR) (declare (xargs :guard (and (,TOP-RECOG ,VAR) (integerp i) (<= 0 i) (< i (,LENGTH-NAME ,VAR)) ,@(IF (EQ ETYPE-TERM T) NIL (LIST ETYPE-TERM))) :verify-guards t ,@STOBJ-XARGS)) ,(LET ((FORM `(UPDATE-NTH-ARRAY ,N I ,V-FORMAL ,VAR))) (IF STOBJ-FORMAL `(NON-EXEC ,FORM) FORM)))) (defstobj-field-fns-axiomatic-defs top-recog var (+ n 1) (cdr field-templates) wrld))) ((or hashp stobj-tablep) (flet ((common-guard (hash-test var top-recog etype-term) (cond ((eq hash-test 'eq) `(and (,TOP-RECOG ,VAR) (symbolp k) ,@(AND ETYPE-TERM (NOT (EQ ETYPE-TERM T)) (LIST ETYPE-TERM)))) ((eq hash-test 'eql) `(and (,TOP-RECOG ,VAR) (eqlablep k) ,@(AND ETYPE-TERM (NOT (EQ ETYPE-TERM T)) (LIST ETYPE-TERM)))) (t (if (and etype-term (not (eq etype-term t))) `(and (,TOP-RECOG ,VAR) ,ETYPE-TERM) `(,TOP-RECOG ,VAR)))))) (append `(,(COND (HASHP `(,ACCESSOR-NAME (K ,VAR) (DECLARE (XARGS :GUARD ,(COMMON-GUARD HASH-TEST VAR TOP-RECOG NIL) :VERIFY-GUARDS T)) ,(IF (NULL INIT) `(CDR (HONS-ASSOC-EQUAL K (NTH ,N ,VAR))) `(LET ((PAIR (HONS-ASSOC-EQUAL K (NTH ,N ,VAR)))) (IF PAIR (CDR PAIR) ,INIT))))) (T `(,ACCESSOR-NAME (K ,VAR V) (DECLARE (XARGS :GUARD ,(COMMON-GUARD HASH-TEST VAR TOP-RECOG NIL) :VERIFY-GUARDS T)) (LET ((PAIR (HONS-ASSOC-EQUAL K (NTH ,N ,VAR)))) (IF PAIR (CDR PAIR) V))))) (,UPDATER-NAME (k ,V-FORMAL ,VAR) (declare (xargs :guard ,(COMMON-GUARD HASH-TEST VAR TOP-RECOG ETYPE-TERM) :verify-guards t ,@STOBJ-XARGS)) ,(LET ((FORM `(UPDATE-NTH ,N (CONS (CONS K ,V-FORMAL) (NTH ,N ,VAR)) ,VAR))) (IF STOBJ-FORMAL `(NON-EXEC ,FORM) FORM))) (,BOUNDP-NAME (k ,VAR) (declare (xargs :guard ,(COMMON-GUARD HASH-TEST VAR TOP-RECOG NIL) :verify-guards t)) (consp (hons-assoc-equal k (nth ,N ,VAR)))) ,@(AND HASHP `((,ACCESSOR?-NAME (K ,VAR) (DECLARE (XARGS :GUARD ,(COMMON-GUARD HASH-TEST VAR TOP-RECOG NIL) :VERIFY-GUARDS T)) (MV (,ACCESSOR-NAME K ,VAR) (,BOUNDP-NAME K ,VAR))))) (,REMOVE-NAME (k ,VAR) (declare (xargs :guard ,(COMMON-GUARD HASH-TEST VAR TOP-RECOG NIL) :verify-guards t)) (update-nth ,N (hons-remove-assoc k (nth ,N ,VAR)) ,VAR)) (,COUNT-NAME (,VAR) (declare (xargs :guard (,TOP-RECOG ,VAR))) (count-keys (nth ,N ,VAR))) (,CLEAR-NAME (,VAR) (declare (xargs :guard (,TOP-RECOG ,VAR))) (update-nth ,N nil ,VAR)) (,INIT-NAME (ht-size rehash-size rehash-threshold ,VAR) (declare (xargs :guard (and (,TOP-RECOG ,VAR) (or (natp ht-size) (not ht-size)) (or (and (rationalp rehash-size) (<= 1 rehash-size)) (not rehash-size)) (or (and (rationalp rehash-threshold) (<= 0 rehash-threshold) (<= rehash-threshold 1)) (not rehash-threshold)))) (ignorable ht-size rehash-size rehash-threshold)) (update-nth ,N nil ,VAR))) (defstobj-field-fns-axiomatic-defs top-recog var (+ n 1) (cdr field-templates) wrld)))) (t (append `((,ACCESSOR-NAME (,VAR) (declare (xargs :guard (,TOP-RECOG ,VAR) :verify-guards t)) (nth ,N ,VAR)) (,UPDATER-NAME (,V-FORMAL ,VAR) (declare (xargs :guard ,(IF (OR (EQ TYPE-TERM T) STOBJ-XARGS) `(,TOP-RECOG ,VAR) (ASSERT$ TYPE-TERM `(AND ,TYPE-TERM (,TOP-RECOG ,VAR)))) :verify-guards t ,@STOBJ-XARGS)) ,(IF STOBJ-FORMAL `(NON-EXEC (UPDATE-NTH ,N ,V-FORMAL ,VAR)) `(UPDATE-NTH ,N ,V-FORMAL ,VAR)))) (defstobj-field-fns-axiomatic-defs top-recog var (+ n 1) (cdr field-templates) wrld))))))))
defstobj-axiomatic-init-fieldsfunction
(defun defstobj-axiomatic-init-fields (field-templates wrld) (cond ((endp field-templates) nil) (t (let* ((field-template (car field-templates)) (type (access defstobj-field-template field-template :type)) (arrayp (and (consp type) (eq (car type) 'array))) (hashp (and (consp type) (eq (car type) 'hash-table))) (stobj-tablep (and (consp type) (eq (car type) 'stobj-table))) (array-size (and arrayp (car (caddr type)))) (init0 (access defstobj-field-template field-template :init)) (creator (get-stobj-creator (if arrayp (cadr type) type) wrld)) (init (if creator `(non-exec (,CREATOR)) (kwote init0)))) (cond (arrayp (cons `(make-list ,ARRAY-SIZE :initial-element ,INIT) (defstobj-axiomatic-init-fields (cdr field-templates) wrld))) ((or hashp stobj-tablep) (cons nil (defstobj-axiomatic-init-fields (cdr field-templates) wrld))) (t (cons init (defstobj-axiomatic-init-fields (cdr field-templates) wrld))))))))
defstobj-creator-deffunction
(defun defstobj-creator-def (creator-name field-templates wrld) `(,CREATOR-NAME nil (declare (xargs :guard t :verify-guards t)) (list ,@(DEFSTOBJ-AXIOMATIC-INIT-FIELDS FIELD-TEMPLATES WRLD))))
defstobj-axiomatic-defsfunction
(defun defstobj-axiomatic-defs (name template wrld) (let ((field-templates (access defstobj-template template :field-templates))) (append (defstobj-component-recognizer-axiomatic-defs name template field-templates wrld) (list* (defstobj-creator-def (access defstobj-template template :creator) field-templates wrld) (defstobj-field-fns-axiomatic-defs (access defstobj-template template :recognizer) name 0 field-templates wrld)))))
put-stobjs-in-and-outs1function
(defun put-stobjs-in-and-outs1 (name field-templates wrld) (cond ((endp field-templates) wrld) (t (let* ((field-template (car field-templates)) (type (access defstobj-field-template field-template :type)) (acc-fn (access defstobj-field-template field-template :accessor-name)) (upd-fn (access defstobj-field-template field-template :updater-name)) (length-fn (access defstobj-field-template field-template :length-name)) (resize-fn (access defstobj-field-template field-template :resize-name)) (other (access defstobj-field-template field-template :other)) (boundp-fn (nth 0 other)) (accessor?-fn (nth 1 other)) (remove-fn (nth 2 other)) (count-fn (nth 3 other)) (clear-fn (nth 4 other)) (init-fn (nth 5 other))) (put-stobjs-in-and-outs1 name (cdr field-templates) (cond ((and (consp type) (eq (car type) 'array)) (let* ((etype (cadr type)) (stobj-flg (if (eq etype 'double-float) :df (and (stobjp etype t wrld) etype)))) (putprop length-fn 'stobjs-in (list name) (putprop resize-fn 'stobjs-in (list nil name) (putprop resize-fn 'stobjs-out (list name) (putprop acc-fn 'stobjs-in (list nil name) (putprop-unless acc-fn 'stobjs-out (list stobj-flg) '(nil) (putprop upd-fn 'stobjs-in (list nil stobj-flg name) (putprop upd-fn 'stobjs-out (list name) wrld))))))))) ((and (consp type) (member-eq (car type) '(hash-table stobj-table))) (let* ((etype (stobj-hash-table-element-type type)) (stobj-flg (if (eq etype 'double-float) :df (and (stobjp etype t wrld) etype)))) (putprop init-fn 'stobjs-in (list nil nil nil name) (putprop init-fn 'stobjs-out (list name) (putprop clear-fn 'stobjs-in (list name) (putprop clear-fn 'stobjs-out (list name) (putprop count-fn 'stobjs-in (list name) (putprop remove-fn 'stobjs-in (list nil name) (putprop remove-fn 'stobjs-out (list name) (putprop boundp-fn 'stobjs-in (list nil name) (putprop acc-fn 'stobjs-in (if (eq (car type) 'hash-table) (list nil name) (list nil name *stobj-table-stobj*)) (putprop-unless acc-fn 'stobjs-out (list stobj-flg) '(nil) (putprop upd-fn 'stobjs-in (if (eq (car type) 'stobj-table) (list nil *stobj-table-stobj* name) (list nil stobj-flg name)) (putprop upd-fn 'stobjs-out (list name) (if (eq (car type) 'hash-table) (putprop accessor?-fn 'stobjs-in (list nil name) wrld) (putprop acc-fn 'stobjs-out (list *stobj-table-stobj*) wrld)))))))))))))))) (t (let ((stobj-flg (if (eq type 'double-float) :df (and (stobjp type t wrld) type)))) (putprop acc-fn 'stobjs-in (list name) (putprop-unless acc-fn 'stobjs-out (list stobj-flg) '(nil) (putprop upd-fn 'stobjs-in (list stobj-flg name) (putprop upd-fn 'stobjs-out (list name) wrld))))))))))))
put-stobjs-in-and-outsfunction
(defun put-stobjs-in-and-outs (name template wrld) (let ((recog-name (access defstobj-template template :recognizer)) (creator-name (access defstobj-template template :creator)) (field-templates (access defstobj-template template :field-templates))) (put-stobjs-in-and-outs1 name field-templates (putprop creator-name 'stobjs-out (list name) (putprop recog-name 'stobjs-in (list name) wrld)))))
defconst-name-alistfunction
(defun defconst-name-alist (lst n) (if (endp lst) nil (cons (cons n (defconst-name (car lst))) (defconst-name-alist (cdr lst) (1+ n)))))
accessor-arrayfunction
(defun accessor-array (name field-names) (let ((len (length field-names))) (compress1 name (cons `(:header :dimensions (,LEN) :maximum-length ,(+ 1 LEN) :default nil :name ,NAME :order :none) (defconst-name-alist field-names 0)))))
put-defstobj-invariant-riskfunction
(defun put-defstobj-invariant-risk (field-templates wrld) (cond ((endp field-templates) wrld) (t (let* ((field-template (car field-templates)) (type (access defstobj-field-template field-template :type))) (put-defstobj-invariant-risk (cdr field-templates) (cond ((eq type t) wrld) (t (let ((updater (access defstobj-field-template field-template :updater-name))) (putprop updater 'invariant-risk updater wrld)))))))))
chk-defstobj-attachmentsfunction
(defun chk-defstobj-attachments (name recog-name recog-ancs ctx wrld state) (let ((bad-attached-fns (attached-fns recog-ancs wrld))) (cond (bad-attached-fns (er soft ctx "The defstobj event for ~x0 is illegal because the stobj recognizer ~ ~x1 would depend on the function~#2~[~/s~] ~&2, which ~#2~[has an ~ attachment~/have attachments~]. See :DOC ~ stobj-attachment-restrictions." name recog-name bad-attached-fns)) (t (value nil)))))
defstobj-fnfunction
(defun defstobj-fn (name args state event-form) (with-ctx-summarized (msg "( DEFSTOBJ ~x0 ...)" name) (let ((event-form (or event-form (list* 'defstobj name args))) (wrld0 (w state))) (er-let* ((wrld1 (chk-acceptable-defstobj name args ctx wrld0 state))) (cond ((eq wrld1 'redundant) (stop-redundant-event ctx state :name name)) (t (enforce-redundancy event-form ctx wrld0 (let* ((template (defstobj-template name args wrld1)) (field-templates (access defstobj-template template :field-templates)) (field-names (strip-accessor-names field-templates)) (defconsts (defstobj-defconsts field-names 0)) (field-const-names (strip-cadrs defconsts)) (ax-def-lst (defstobj-axiomatic-defs name template wrld1)) (raw-def-lst (defstobj-raw-defs name template nil wrld1)) (recog-name (access defstobj-template template :recognizer)) (creator-name (access defstobj-template template :creator)) (names (strip-cars ax-def-lst)) (the-live-var (the-live-var name)) (congruent-to (access defstobj-template template :congruent-to)) (non-memoizable (access defstobj-template template :non-memoizable)) (non-executable (access defstobj-template template :non-executable))) (er-progn (cond ((set-equalp-equal names (strip-cars raw-def-lst)) (value nil)) (t (value (er hard ctx "Defstobj-axiomatic-defs and defstobj-raw-defs are ~ out of sync! They should each define the same ~ set of names. Here are the functions with ~ axiomatic defs that have no raw defs: ~x0. And ~ here are the functions with raw defs but no ~ axiomatic ones: ~x1." (set-difference-equal names (strip-cars raw-def-lst)) (set-difference-equal (strip-cars raw-def-lst) names))))) (revert-world-on-error (pprogn (set-w 'extension wrld1 state) (er-progn (process-embedded-events 'defstobj (table-alist 'acl2-defaults-table wrld1) (or (ld-skip-proofsp state) t) (current-package state) (list 'defstobj name names) (append (pairlis-x1 'defun ax-def-lst) defconsts `((encapsulate nil (set-inhibit-warnings "theory") (in-theory (disable (:executable-counterpart ,CREATOR-NAME)))))) 0 t (f-get-global 'cert-data state) ctx state) (let* ((wrld2 (w state)) (recog-ancs (canonical-ancestors-lst (list recog-name) wrld2))) (er-progn (chk-defstobj-attachments name recog-name recog-ancs ctx wrld2 state) (let* ((congruent-stobj-rep (and congruent-to (congruent-stobj-rep congruent-to wrld2))) (wrld3 (mark-attachment-disallowed recog-ancs name :defstobj (put-defstobj-invariant-risk field-templates (putprop name 'congruent-stobj-rep congruent-stobj-rep (putprop-unless name 'non-memoizable non-memoizable nil (putprop name 'symbol-class :common-lisp-compliant (put-stobjs-in-and-outs name template (putprop name 'stobj (make stobj-property :live-var the-live-var :recognizer recog-name :creator creator-name :names (append (set-difference-eq names (list recog-name creator-name)) field-const-names)) (putprop-x-lst1 names 'stobj-function name (putprop-x-lst1 field-const-names 'stobj-constant name (putprop the-live-var 'stobj-live-var name (putprop the-live-var 'symbol-class :common-lisp-compliant (putprop name 'accessor-names (accessor-array name field-names) wrld2))))))))))) wrld2)) (discriminator (cons 'defstobj (make defstobj-redundant-raw-lisp-discriminator-value :event event-form :recognizer recog-name :creator creator-name :congruent-stobj-rep (or congruent-stobj-rep name) :non-memoizable non-memoizable :non-executable non-executable)))) (install-event name event-form 'defstobj (list* name the-live-var names) nil `(defstobj ,NAME ,THE-LIVE-VAR ,(DEFSTOBJ-RAW-INIT TEMPLATE) ,RAW-DEF-LST ,DISCRIMINATOR ,AX-DEF-LST ,EVENT-FORM) t ctx wrld3 state))))))))))))))))
defabsstobjmacro
(defmacro defabsstobj (&whole event-form name &key foundation recognizer creator corr-fn corr-fn-exists exports protect-default congruent-to non-executable attachable missing-only) (declare (xargs :guard (and (symbolp name) (booleanp protect-default)))) (list 'defabsstobj-fn (list 'quote name) (list 'quote foundation) (list 'quote recognizer) (list 'quote creator) (list 'quote corr-fn) (list 'quote corr-fn-exists) (list 'quote exports) (list 'quote protect-default) (list 'quote congruent-to) (list 'quote non-executable) (list 'quote attachable) (list 'quote missing-only) 'state (list 'quote event-form)))
concrete-stobjfunction
(defun concrete-stobj (st wrld) (let ((absstobj-info (getpropc st 'absstobj-info nil wrld))) (and absstobj-info (let ((st$c (access absstobj-info (getpropc st 'absstobj-info nil wrld) :st$c))) (or (concrete-stobj st$c wrld) st$c)))))
defabsstobj-missing-eventsmacro
(defmacro defabsstobj-missing-events (&whole event-form name &key foundation recognizer creator corr-fn corr-fn-exists exports protect-default congruent-to non-executable attachable) (declare (xargs :guard (symbolp name))) (let ((ctx (list 'quote (msg "( DEFABSSTOBJ-MISSING-EVENTS ~x0 ...)" name)))) (list 'defabsstobj-fn1 (list 'quote name) (list 'quote foundation) (list 'quote recognizer) (list 'quote creator) (list 'quote corr-fn) (list 'quote corr-fn-exists) (list 'quote exports) (list 'quote protect-default) (list 'quote congruent-to) (list 'quote non-executable) (list 'quote attachable) (list 'quote t) ctx 'state (list 'quote event-form) nil nil nil)))
redundant-defabsstobjpfunction
(defun redundant-defabsstobjp (name event-form wrld) (and (getpropc name 'stobj nil wrld) (equal event-form (get-event name wrld))))
absstobj-correspondence-concl-lstfunction
(defun absstobj-correspondence-concl-lst (stobjs-out i st$c corr-fn) (cond ((endp stobjs-out) nil) (t (cons (let ((qi (kwote i))) (fcons-term* (if (eq (car stobjs-out) st$c) corr-fn 'equal) (fcons-term* 'mv-nth qi 'lhs) (fcons-term* 'mv-nth qi 'rhs))) (absstobj-correspondence-concl-lst (cdr stobjs-out) (1+ i) st$c corr-fn)))))
flatten-ands-in-lit!function
(defun flatten-ands-in-lit! (term) (declare (xargs :guard (pseudo-termp term))) (case-match term (('if t1 t2 t3) (cond ((equal t2 *nil*) (union-equal-to-end (flatten-ands-in-lit! (dumb-negate-lit t1)) (flatten-ands-in-lit! t3))) ((equal t3 *nil*) (union-equal-to-end (flatten-ands-in-lit! t1) (flatten-ands-in-lit! t2))) (t (list term)))) (& (cond ((equal term *t*) nil) (t (list term))))))
absstobj-correspondence-formulafunction
(defun absstobj-correspondence-formula (f$a f$c corr-fn formals guard-pre st st$c wrld) (cond ((null formals) `(,CORR-FN (,F$C) (,F$A))) (t (let* ((stobjs-out (stobjs-out f$c wrld)) (lhs (fcons-term f$c (formals f$c wrld))) (rhs (fcons-term f$a formals))) (fcons-term* 'implies (conjoin (cons (fcons-term* corr-fn st$c st) (flatten-ands-in-lit! guard-pre))) (cond ((null (cdr stobjs-out)) (fcons-term* (if (eq (car stobjs-out) st$c) corr-fn 'equal) lhs rhs)) (t (fcons-term* (make-lambda '(lhs rhs) (conjoin (absstobj-correspondence-concl-lst stobjs-out 0 st$c corr-fn))) lhs rhs))))))))
absstobj-preserved-formulafunction
(defun absstobj-preserved-formula (f$a f$c formals guard-pre st st$c st$ap wrld) (cond ((null formals) (fcons-term* st$ap (fcons-term* f$a))) (t (let ((stobjs-out (stobjs-out f$c wrld)) (updated-st-term (fcons-term f$a formals))) (fcons-term* 'implies (conjoin (add-to-set-equal (fcons-term* st$ap st) (flatten-ands-in-lit! guard-pre))) (cond ((null (cdr stobjs-out)) (assert$ (eq (car stobjs-out) st$c) (fcons-term* st$ap updated-st-term))) (t (let ((posn (position st$c stobjs-out))) (assert$ (and posn (not (member-eq st$c (cdr (nthcdr posn stobjs-out))))) (fcons-term* st$ap (fcons-term* 'mv-nth (kwote posn) updated-st-term)))))))))))
other
(defrec absstobj-method (name formals guard-pre guard-post guard-thm guard-thm-p stobjs-in-posn stobjs-in-exec stobjs-in-logic stobjs-out logic exec correspondence preserved protect updater) t)
fn-stobj-updates-pmutual-recursion
(mutual-recursion (defun fn-stobj-updates-p (st fn wrld) (cond ((eq st (getpropc fn 'stobj-function nil wrld)) :once) ((getpropc fn 'recursivep nil wrld) t) ((getpropc fn 'constrainedp nil wrld) t) (t (let ((body (getpropc fn 'unnormalized-body nil wrld))) (assert$ body (stobj-updates-p st body wrld)))))) (defun stobj-updates-p (st term wrld) (cond ((or (variablep term) (fquotep term)) nil) ((flambdap (ffn-symb term)) (flet ((or! (x y) (if x (if y t x) y))) (or! (stobj-updates-listp st (fargs term) wrld) (stobj-updates-p st (lambda-body (ffn-symb term)) wrld)))) ((member-eq (ffn-symb term) '(if return-last)) (let ((temp1 (stobj-updates-p st (fargn term 1) wrld)) (temp2 (stobj-updates-p st (fargn term 2) wrld))) (cond (temp1 (er hard! 'stobj-updates-p "Please contact the ACL2 implementors. Unexpected true ~ result for first argument of ~x0." term)) ((eq temp2 t) t) (t (let ((temp3 (stobj-updates-p st (fargn term 3) wrld))) (cond ((eq temp3 t) t) (t (or temp2 temp3)))))))) (t (assert$ (null (stobj-updates-listp st (fargs term) wrld)) (and (member-eq st (stobjs-out (ffn-symb term) wrld)) (fn-stobj-updates-p st (ffn-symb term) wrld)))))) (defun stobj-updates-listp (st x wrld) (cond ((endp x) nil) (t (flet ((or! (x y) (if x (if y t x) y))) (or! (stobj-updates-p st (car x) wrld) (stobj-updates-listp st (cdr x) wrld)))))))
unprotected-export-pfunction
(defun unprotected-export-p (st$c name wrld) (and (member-eq st$c (stobjs-out name wrld)) (eq t (fn-stobj-updates-p st$c name wrld))))
key-position-from-end-eqfunction
(defun key-position-from-end-eq (key alist) (declare (xargs :guard (and (symbolp key) (alistp alist)))) (cond ((endp alist) nil) ((eq key (caar alist)) (length (cdr alist))) (t (key-position-from-end-eq key (cdr alist)))))
absstobj-logical-skeleton-difference-msgfunction
(defun absstobj-logical-skeleton-difference-msg (old new st-old st-new see-doc old-all new-all) (cond ((endp old) (cond ((endp new) nil) (t (msg "The proposed abstract stobj, ~x0, has additional exports ~ not in the existing abstract stobj, ~x1. ~@2" st-new st-old see-doc)))) ((endp new) (msg "The existing abstract stobj, ~x0, has additional exports not ~ in the proposed abstract stobj, ~x1. ~@2" st-old st-new see-doc)) (t (let* ((old1 (car old)) (new1 (car new)) (logic-old (cadr old1)) (logic-new (cadr new1)) (updater-old (cdddr old1)) (updater-new (cdddr new1))) (cond ((and (equal logic-old logic-new) (or (and (null updater-old) (null updater-new)) (and updater-old updater-new (eql (key-position-from-end-eq updater-old old-all) (key-position-from-end-eq updater-new new-all))))) (absstobj-logical-skeleton-difference-msg (cdr old) (cdr new) st-old st-new see-doc old-all new-all)) (t (msg "The existing abstract stobj, ~x0, has an export ~ with name ~x1 that should correspond to the export ~ with name ~x2 of the proposed abstract stobj, ~x3. ~ However, these exports have non-corresponding ~x4 ~ fields: ~x5 for ~x1 and ~x6 for ~x2. ~@7" st-old (car old1) (car new1) st-new (if (equal logic-old logic-new) :updater :logic) (if (equal logic-old logic-new) updater-old logic-old) (if (equal logic-old logic-new) updater-new logic-new) see-doc)))))))
chk-absstobj-attachmentfunction
(defun chk-absstobj-attachment (st-name impl-name new-tuples ctx wrld see-doc state) (assert$ impl-name (pprogn (observation ctx "Implementation stobj ~x0 is to be attached to proposed ~ attachable stobj ~x1." impl-name st-name) (let ((absstobj-info-at (getpropc impl-name 'absstobj-info nil wrld))) (cond ((null absstobj-info-at) (er soft ctx "Although the event ~x0 was previously executed, the name ~x1 is ~ not the name of an abstract stobj. This should only happen if ~ that name was redefined. The proposed defabsstobj event for ~ name ~x2 cannot be admitted since it specifies, with :ATTACHABLE ~ T and that previous attach-stobj event, that a previous ~ defabsstobj event for name ~x1 should serve as an attachment." `(attach-stobj ,ST-NAME ,IMPL-NAME) impl-name st-name)) (t (let* ((old-tuples (access absstobj-info absstobj-info-at :absstobj-tuples)) (msg (absstobj-logical-skeleton-difference-msg old-tuples new-tuples impl-name st-name see-doc old-tuples new-tuples))) (cond (msg (er soft ctx "Illegal abstract stobj attachment for ~x0: ~x1. ~@2" st-name impl-name msg)) (t (value nil))))))))))
attached-stobjfunction
(defun attached-stobj (st wrld top) (let ((st2 (cdr (assoc-eq st (table-alist 'attach-stobj-table wrld))))) (cond (st2 (attached-stobj st2 wrld nil)) (top nil) (t st))))
translate-absstobj-fieldfunction
(defun translate-absstobj-field (st st-new absstobj-tuple st$c field type protect-default ld-skip-proofsp see-doc ctx wrld) (let* ((field0 field) (field (if (atom field) (list field) field)) (name (car field)) (actual-name (or (car absstobj-tuple) name)) (keyword-lst (cdr field))) (cond ((not (and (symbolp name) (keyword-value-listp keyword-lst) (symbol-listp (odds keyword-lst)))) (er-cmp ctx "Each field of a DEFABSSTOBJ event must be a symbol or a list ~ of the form (symbol :KWD1 val1 :KWD2 val2 ...) where each vali ~ is a symbol, but the field ~x0 is not of this form. ~@1" field0 see-doc)) (t (mv-let (exec exec-p) (let ((exec (cadr (assoc-keyword :exec keyword-lst)))) (cond (exec (mv exec t)) ((eq type :recognizer) (mv (absstobj-name st :recognizer-exec) nil)) (t (mv (absstobj-name name :c) nil)))) (let* ((protect-tail (assoc-keyword :protect keyword-lst)) (protect (if protect-tail (cadr protect-tail) protect-default))) (cond ((and protect-tail (not (member-eq protect '(t nil)))) (er-cmp ctx "Illegal value of :PROTECT, ~x0, in the field for ~x1. ~@2" protect name see-doc)) (t (mv-let (logic logic-p) (let ((logic (cadr (assoc-keyword :logic keyword-lst)))) (cond (logic (mv logic t)) ((eq type :recognizer) (mv (absstobj-name st :recognizer-logic) nil)) (t (mv (absstobj-name name :a) nil)))) (cond ((null wrld) (value-cmp (make absstobj-method :name actual-name :logic logic :exec exec :protect protect))) ((strip-keyword-list '(:logic :exec :correspondence :preserved :guard-thm :protect :updater) keyword-lst) (er-cmp ctx "Unexpected keyword~#0~[~/s~], ~&0, in field ~x1. ~@2" (evens (strip-keyword-list '(:logic :exec :correspondence :preserved :guard-thm :updater) keyword-lst)) field0 see-doc)) ((duplicate-key-in-keyword-value-listp keyword-lst) (er-cmp ctx "Duplicate keyword~#0~[~/s~] ~&0 found in field ~x1.~|~@2" (duplicates (evens keyword-lst)) field0 see-doc)) ((not (function-symbolp exec wrld)) (er-cmp ctx "The :EXEC field ~x0, specified~#1~[~/ (implicitly)~] ~ for ~#2~[defabsstobj :RECOGNIZER~/defabsstobj ~ :CREATOR~/exported~] symbol ~x3, is not a function ~ symbol in the current ACL2 logical world. ~@4" exec (if exec-p 0 1) (case type (:recognizer 0) (:creator 1) (otherwise 2)) name see-doc)) ((and (null protect) (not (member-eq type '(:recognizer :creator))) (not (member-eq ld-skip-proofsp '(include-book include-book-with-locals))) (unprotected-export-p st$c exec wrld)) (er-cmp ctx "The :EXEC field ~x0, specified~#1~[~/ (implicitly)~] ~ for defabsstobj field ~x2, appears capable of ~ modifying the foundational stobj, ~x3, ~ non-atomically; yet :PROTECT T was not specified for ~ this field. ~@4" exec (if exec-p 0 1) name st$c see-doc)) (t (mv-let (guard-thm guard-thm-p) (let ((guard-thm (cadr (assoc-keyword :guard-thm keyword-lst)))) (cond (guard-thm (mv guard-thm t)) (t (mv (absstobj-name name :guard-thm) nil)))) (let* ((exec-formals (formals exec wrld)) (posn-exec (position-eq st$c exec-formals)) (stobjs-in-logic (stobjs-in logic wrld)) (stobjs-in-exec (stobjs-in exec wrld)) (stobjs-out-logic (stobjs-out logic wrld)) (stobjs-out-exec (stobjs-out exec wrld)) (correspondence-required (not (eq type :recognizer))) (preserved-required (and (not (eq type :recognizer)) (member-eq st$c stobjs-out-exec))) (updater-tail (assoc-keyword :updater keyword-lst))) (mv-let (correspondence correspondence-p) (let ((corr (cadr (assoc-keyword :correspondence keyword-lst)))) (cond (corr (mv corr t)) (t (mv (and correspondence-required (absstobj-name name :correspondence)) nil)))) (mv-let (preserved preserved-p) (let ((pres (cadr (assoc-keyword :preserved keyword-lst)))) (cond (pres (mv pres t)) (t (mv (and preserved-required (absstobj-name name :preserved)) nil)))) (cond ((or (and (eq type :recognizer) (or correspondence-p preserved-p guard-thm-p updater-tail (not logic-p) (not exec-p))) (and (eq type :creator) (or updater-tail guard-thm-p))) (er-cmp ctx "The ~@0 for keyword ~x1. ~@2" (cond (updater-tail ":UPDATER field is not allowed") (guard-thm-p ":GUARD-THM field is not allowed") (correspondence-p ":CORRESPONDENCE field is not allowed") (preserved-p ":PRESERVED field is not allowed") ((not logic-p) ":LOGIC field is required") (t ":EXEC field is required")) type see-doc)) ((not (function-symbolp logic wrld)) (er-cmp ctx "The :LOGIC field ~x0, specified~#1~[~/ ~ (implicitly)~] for ~#2~[defabsstobj ~ :RECOGNIZER~/defabsstobj ~ :CREATOR~/exported~] symbol ~x3, is not a ~ function symbol in the current ACL2 ~ logical world. ~@4" logic (if logic-p 0 1) (case type (:recognizer 0) (:creator 1) (otherwise 2)) name see-doc)) ((or (not (eq (symbol-class exec wrld) :common-lisp-compliant)) (not (eq (symbol-class logic wrld) :common-lisp-compliant))) (let* ((lp (not (eq (symbol-class logic wrld) :common-lisp-compliant))) (implicit-p (if lp logic-p exec-p)) (fn (if lp logic exec))) (er-cmp ctx "The~#0~[~/ (implicit)~] ~x1 component of ~ field ~x2, ~x3, is a function symbol but ~ its guards have not yet been verified. ~ ~@4" (if implicit-p 0 1) (if lp :logic :exec) field0 fn see-doc))) ((and (eq type :recognizer) (not (eq exec (get-stobj-recognizer st$c wrld)))) (er-cmp ctx "The~#0~[~/ (implicit)~] :EXEC component, ~ ~x1, of the specified :RECOGNIZER, ~x2, is ~ not the recognizer of the foundational ~ stobj ~x3. ~@4" (if exec-p 0 1) exec name st$c see-doc)) ((and preserved-p (not preserved-required)) (er-cmp ctx "It is illegal to specify :PRESERVED for a ~ field whose :EXEC does not return the ~ foundational stobj. In this case, ~ :PRESERVED ~x0 has been specified for an ~ :EXEC of ~x1, which does not return ~x2. ~ ~@3" preserved exec st$c see-doc)) ((member-eq (or st-new st) exec-formals) (er-cmp ctx "We do not allow the use of the defabsstobj ~ name, ~x0, in the formals of the :EXEC ~ function of a field, in particular, the ~ :EXEC function ~x1 for field ~x2~#3~[ from ~ the attached stobj, ~x4~/~]. ~@5" (or st-new st) exec field0 (if st-new 0 1) st-new see-doc)) ((and (eq type :creator) (not (and (null stobjs-in-logic) (null stobjs-in-exec) (null (cdr stobjs-out-exec)) (eq (car stobjs-out-exec) st$c) (null (cdr stobjs-in-exec)) (eql (length stobjs-out-logic) 1)))) (cond ((or stobjs-in-logic stobjs-in-exec) (er-cmp ctx "The :LOGIC and :EXEC versions of ~ the :CREATOR function must both be ~ functions of no arguments but ~&0 ~ ~#0~[is not such a function~/xare ~ not such functions~]. ~@1" (append (and stobjs-in-logic (list logic)) (and stobjs-in-exec (list exec))) see-doc)) ((or (not (eql (length stobjs-out-logic) 1)) (not (eql (length stobjs-out-exec) 1))) (er-cmp ctx "The :LOGIC and :EXEC versions of ~ the :CREATOR function must both be ~ functions that return a single ~ value, but ~&0 ~#0~[is not such a ~ function~/are not such functions~]. ~ ~ ~@1" (append (and (not (eql (length stobjs-out-logic) 1)) (list logic)) (and (not (eql (length stobjs-out-exec) 1)) (list exec))) see-doc)) (t (er-cmp ctx "The :EXEC version of the :CREATOR ~ function must return a single value ~ that is the stobj ~x0, but ~x1 does ~ not have that property. ~@2" st$c exec see-doc)))) ((and (not (eq type :creator)) (not posn-exec)) (er-cmp ctx "The foundational stobj name, ~x0, is not ~ a known stobj parameter of :EXEC function ~ ~x1 for field ~x2.~|~@3" st$c exec field0 see-doc)) ((and (not (eq type :creator)) (not (equal (length stobjs-in-logic) (length stobjs-in-exec)))) (er-cmp ctx "The :LOGIC and :EXEC functions for a field ~ must have input signatures of the same ~ length. However, this fails for field ~ descriptor ~x0, as the input signatures ~ are as follows.~|~%~x1 ~ (:LOGIC):~|~X25~|~%~x3 ~ (:EXEC):~|~X45~|~%~@6" field0 logic (prettyify-stobj-flags stobjs-in-logic) exec (prettyify-stobj-flags stobjs-in-exec) nil see-doc)) ((and (not (eq type :creator)) (not (equal (length stobjs-out-logic) (length stobjs-out-exec)))) (er-cmp ctx "The output signatures of the :LOGIC and ~ :EXEC functions for an abstract stobj ~ export must have the same length. ~ However, the output signatures are as ~ follows for field descriptor ~x0 of ~ abstract stobj ~x1.~|~%~x2 ~ (:LOGIC):~|~X36~|~%~x4 ~ (:EXEC):~|~X56~|~%~@7" field0 st logic (prettyify-stobj-flags stobjs-out-logic) exec (prettyify-stobj-flags stobjs-out-exec) nil see-doc)) (t (let* ((formals (if (eq type :creator) nil (update-nth posn-exec (or st-new st) exec-formals))) (guard-pre (subcor-var (formals logic wrld) formals (guard logic nil wrld)))) (cond ((member-eq st$c stobjs-in-logic) (er-cmp ctx "the :LOGIC function ~x0 for export ~x1 ~ declares as a stobj the formal ~ parameter, ~x2. This is illegal ~ because ~x2 is the foundational stobj ~ for the proposed abstract stobj, ~x3." logic (or actual-name name) st$c (or st-new st))) (t (value-cmp (make absstobj-method :name actual-name :formals formals :guard-pre guard-pre :guard-post nil :guard-thm guard-thm :guard-thm-p (if type :skip guard-thm-p) :stobjs-in-posn posn-exec :stobjs-in-exec stobjs-in-exec :stobjs-in-logic stobjs-in-logic :stobjs-out (substitute (or st-new st) st$c stobjs-out-exec) :logic logic :exec exec :correspondence correspondence :preserved preserved :protect protect :updater (cadr updater-tail)))))))))))))))))))))))
simple-translate-absstobj-fieldsfunction
(defun simple-translate-absstobj-fields (st st$c fields types protect-default ld-skip-proofsp) (cond ((endp fields) (mv nil nil)) (t (er-let*-cmp ((method (translate-absstobj-field st nil nil st$c (car fields) (car types) protect-default ld-skip-proofsp "" 'defabsstobj nil)) (rest (simple-translate-absstobj-fields st st$c (cdr fields) (cdr types) protect-default ld-skip-proofsp))) (value-cmp (cons method rest))))))
one-way-unify-pfunction
(defun one-way-unify-p (pat term) (or (equal pat term) (mv-let (ans unify-subst) (one-way-unify pat term) (declare (ignore unify-subst)) ans)))
obviously-equal-lambda-argsfunction
(defun obviously-equal-lambda-args (x-formals-tail x-args-tail y-formals y-args) (declare (xargs :guard (and (symbol-listp x-formals-tail) (pseudo-term-listp x-args-tail) (symbol-listp y-formals) (pseudo-term-listp y-args)))) (cond ((endp x-formals-tail) t) (t (let ((posn (position-eq (car x-formals-tail) y-formals))) (and posn (and (equal (car x-args-tail) (nth posn y-args)) (obviously-equal-lambda-args (cdr x-formals-tail) (cdr x-args-tail) y-formals y-args)))))))
obviously-equiv-termsmutual-recursion
(mutual-recursion (defun obviously-equiv-terms (x y iff-flg) (declare (xargs :guard (and (pseudo-termp x) (pseudo-termp y)))) (or (equal x y) (cond ((or (variablep x) (variablep y)) nil) ((or (fquotep x) (fquotep y)) (and iff-flg (fquotep x) (fquotep y) (unquote x) (unquote y))) ((flambda-applicationp x) (and (flambda-applicationp y) (let ((x-fn (ffn-symb x)) (y-fn (ffn-symb y)) (x-args (fargs x)) (y-args (fargs y))) (cond ((equal x-fn y-fn) (obviously-equiv-terms-lst x-args y-args)) (t (let ((x-formals (lambda-formals x-fn)) (x-body (lambda-body x-fn)) (y-formals (lambda-formals y-fn)) (y-body (lambda-body y-fn))) (and (eql (length x-formals) (length y-formals)) (or (and (obviously-equiv-terms (subcor-var x-formals y-formals x-body) y-body iff-flg) (obviously-equiv-terms-lst x-args y-args)) (and (obviously-equiv-terms x-body y-body iff-flg) (obviously-equal-lambda-args x-formals (fargs x) y-formals (fargs y))))))))))) ((not (eq (ffn-symb x) (ffn-symb y))) nil) ((member-eq (ffn-symb x) '(implies iff)) (and (obviously-equiv-terms (fargn x 1) (fargn y 1) t) (obviously-equiv-terms (fargn x 2) (fargn y 2) t))) ((eq (ffn-symb x) 'not) (obviously-equiv-terms (fargn x 1) (fargn y 1) t)) ((eq (ffn-symb x) 'if) (and (obviously-equiv-terms (fargn x 1) (fargn y 1) t) (obviously-equiv-terms (fargn x 3) (fargn y 3) iff-flg) (or (obviously-equiv-terms (fargn x 2) (fargn y 2) iff-flg) (and iff-flg (cond ((equal (fargn x 2) *t*) (obviously-equiv-terms (fargn y 2) (fargn y 1) t)) ((equal (fargn y 2) *t*) (obviously-equiv-terms (fargn x 2) (fargn x 1) t)) (t nil)))))) (t (and (equal (length (fargs x)) (length (fargs y))) (obviously-equiv-terms-lst (fargs x) (fargs y))))))) (defun obviously-equiv-terms-lst (x y) (declare (xargs :guard (and (pseudo-term-listp x) (pseudo-term-listp y)))) (cond ((endp x) t) (t (and (obviously-equiv-terms (car x) (car y) nil) (obviously-equiv-terms-lst (cdr x) (cdr y)))))))
obviously-iff-equiv-termsfunction
(defun obviously-iff-equiv-terms (x y) (declare (xargs :guard (and (pseudo-termp x) (pseudo-termp y)))) (obviously-equiv-terms x y t))
chk-defabsstobj-method-lemmasfunction
(defun chk-defabsstobj-method-lemmas (method st st$c st$ap corr-fn missing wrld state) (let ((correspondence (access absstobj-method method :correspondence)) (preserved (access absstobj-method method :preserved))) (cond ((null correspondence) (assert$ (null preserved) (value (cons missing wrld)))) (t (let* ((formals (access absstobj-method method :formals)) (guard-pre (access absstobj-method method :guard-pre)) (logic (access absstobj-method method :logic)) (exec (access absstobj-method method :exec)) (expected-corr-formula (absstobj-correspondence-formula logic exec corr-fn formals guard-pre st st$c wrld)) (old-corr-formula (formula correspondence nil wrld)) (tuple (cond ((null old-corr-formula) `(,CORRESPONDENCE ,EXPECTED-CORR-FORMULA)) ((obviously-iff-equiv-terms expected-corr-formula old-corr-formula) nil) ((one-way-unify-p old-corr-formula expected-corr-formula) nil) (t `(,CORRESPONDENCE ,EXPECTED-CORR-FORMULA ,@OLD-CORR-FORMULA)))) (missing (cond (tuple (cons tuple missing)) (t missing))) (guard-thm-p (access absstobj-method method :guard-thm-p)) (tuple (cond ((eq guard-thm-p :skip) nil) (t (let* ((expected-guard-thm-formula (make-implication (cons (fcons-term* corr-fn st$c st) (flatten-ands-in-lit! guard-pre)) (conjoin (flatten-ands-in-lit! (guard exec t wrld))))) (taut-p (and (null guard-thm-p) (tautologyp expected-guard-thm-formula wrld))) (guard-thm (access absstobj-method method :guard-thm)) (old-guard-thm-formula (and (not taut-p) (formula guard-thm nil wrld)))) (cond (taut-p nil) ((null old-guard-thm-formula) `(,GUARD-THM ,EXPECTED-GUARD-THM-FORMULA)) ((obviously-iff-equiv-terms expected-guard-thm-formula old-guard-thm-formula) nil) ((one-way-unify-p old-guard-thm-formula expected-guard-thm-formula) nil) (t `(,GUARD-THM ,EXPECTED-GUARD-THM-FORMULA ,@OLD-GUARD-THM-FORMULA))))))) (missing (cond (tuple (cons tuple missing)) (t missing)))) (cond ((null preserved) (value (cons missing wrld))) (t (let* ((expected-preserved-formula (absstobj-preserved-formula logic exec formals guard-pre st st$c st$ap wrld)) (old-preserved-formula (formula preserved nil wrld)) (tuple (cond ((null old-preserved-formula) `(,PRESERVED ,EXPECTED-PRESERVED-FORMULA)) ((obviously-iff-equiv-terms expected-preserved-formula old-preserved-formula) nil) ((one-way-unify-p old-preserved-formula expected-preserved-formula) nil) (t `(,PRESERVED ,EXPECTED-PRESERVED-FORMULA ,@OLD-PRESERVED-FORMULA)))) (missing (cond (tuple (cons tuple missing)) (t missing)))) (value (cons missing wrld))))))))))
chk-defabsstobj-methodfunction
(defun chk-defabsstobj-method (method st st$c st$ap corr-fn congruent-to missing ctx wrld state) (let ((name (access absstobj-method method :name))) (er-let* ((wrld (er-progn (chk-all-but-new-name name ctx 'function wrld state) (chk-just-new-name name nil 'function nil ctx wrld state)))) (cond ((or congruent-to (member-eq (ld-skip-proofsp state) '(include-book include-book-with-locals))) (value (cons missing wrld))) (t (chk-defabsstobj-method-lemmas method st st$c st$ap corr-fn missing wrld state))))))
interspersefunction
(defun intersperse (lst1 lst2) (declare (xargs :guard (and (true-listp lst1) (true-listp lst2) (= (length lst1) (length lst2))))) (cond ((endp lst1) nil) (t (list* (car lst1) (car lst2) (intersperse (cdr lst1) (cdr lst2))))))
sort-absstobj-namesfunction
(defun sort-absstobj-names (names accessors updaters) (let ((lst (intersperse accessors updaters))) (append lst (set-difference-eq names lst))))
chk-acceptable-defabsstobj1function
(defun chk-acceptable-defabsstobj1 (st st$c st$ap corr-fn fields types protect-default congruent-to see-doc ctx wrld state methods missing) (cond ((endp fields) (value (list* (reverse missing) (reverse methods) wrld))) (t (mv-let (erp method) (translate-absstobj-field st nil nil st$c (car fields) (car types) protect-default (ld-skip-proofsp state) see-doc ctx wrld) (cond (erp (er soft erp "~@0" method)) (t (er-let* ((missing/wrld (chk-defabsstobj-method method st st$c st$ap corr-fn congruent-to missing ctx wrld state))) (let ((missing (car missing/wrld)) (wrld (cdr missing/wrld))) (cond ((assoc-eq (access absstobj-method method :name) methods) (er soft ctx "The name ~x0 is introduced more than once by a ~ DEFABSSTOBJ event. ~@1" (access absstobj-method method :name) see-doc)) (t (chk-acceptable-defabsstobj1 st st$c st$ap corr-fn (cdr fields) (cdr types) protect-default congruent-to see-doc ctx wrld state (cons method methods) missing)))))))))))
first-keywordfunction
(defun first-keyword (lst) (declare (xargs :guard (true-listp lst))) (cond ((endp lst) nil) ((keywordp (car lst)) (car lst)) (t (first-keyword (cdr lst)))))
collect-defabsstobj-updatersfunction
(defun collect-defabsstobj-updaters (methods st$c all-methods wrld accessors updaters accessors-exec updaters-exec) (cond ((endp methods) (mv nil (reverse accessors) (reverse updaters) (reverse accessors-exec) (reverse updaters-exec))) (t (let* ((method (car methods)) (updater (access absstobj-method method :updater))) (cond ((null updater) (collect-defabsstobj-updaters (cdr methods) st$c all-methods wrld accessors updaters accessors-exec updaters-exec)) (t (let* ((exec (access absstobj-method method :exec)) (stobjs-out (assert$ exec (stobjs-out exec wrld))) (child (and (consp stobjs-out) (null (cdr stobjs-out)) (not (eq (car stobjs-out) :df)) (car stobjs-out))) (name (access absstobj-method method :name))) (cond ((or (not (stobj-field-accessor-p exec st$c wrld)) (null child)) (mv (msg "The function spec for ~x0 specifies an :UPDATER ~ function, which is only allowed when the specified ~ :EXEC function is a stobj field accessor for the ~ foundational stobj. However, the :EXEC function is ~ ~x1, which ~@2." name exec (cond ((stobj-field-accessor-p exec st$c wrld) (msg "is an accessor of ~x0 for a non-stobj field" st$c)) (t (msg "is not a field accessor of ~x0" st$c)))) nil nil nil nil)) (t (let* ((updater-method (assoc-eq updater all-methods))) (cond ((null updater-method) (mv (msg "In the function spec for ~x0, the :UPDATER ~ keyword has value ~x1. However, there is no ~ function spec for ~x1." name updater) nil nil nil nil)) (t (collect-defabsstobj-updaters (cdr methods) st$c all-methods wrld (cons name accessors) (cons updater updaters) (cons exec accessors-exec) (cons (access absstobj-method updater-method :exec) updaters-exec))))))))))))))
chk-defabsstobj-updaters-1function
(defun chk-defabsstobj-updaters-1 (accessors accessors-exec updaters updaters-exec lst) (cond ((endp updaters-exec) nil) (t (let* ((updater-exec (car updaters-exec)) (accessor-exec (car accessors-exec)) (accessor-tail (member-eq (car accessors-exec) lst)) (actual-updater-exec (cadr accessor-tail))) (assert$ accessor-tail (cond ((eq updater-exec actual-updater-exec) (chk-defabsstobj-updaters-1 (cdr accessors) (cdr accessors-exec) (cdr updaters) (cdr updaters-exec) lst)) (t (msg "The :EXPORTS specify that the :UPDATER for accessor ~x0 ~ is the exported function, ~x1. The :EXEC function for ~ ~x1 is ~x2, but is expected to be ~x3, which is the ~ updater corresponding to the :EXEC function for ~x0, ~ ~x4." (car accessors) (car updaters) updater-exec actual-updater-exec accessor-exec))))))))
chk-defabsstobj-updatersfunction
(defun chk-defabsstobj-updaters (st$c methods wrld) (mv-let (msg accessors updaters accessors-exec updaters-exec) (collect-defabsstobj-updaters methods st$c methods wrld nil nil nil nil) (cond (msg (mv msg nil nil)) (t (let* ((prop (getpropc st$c 'stobj nil wrld)) (msg (chk-defabsstobj-updaters-1 accessors accessors-exec updaters updaters-exec (access stobj-property prop :names)))) (cond (msg (mv msg nil nil)) (t (mv nil accessors updaters))))))))
chk-acceptable-defabsstobjfunction
(defun chk-acceptable-defabsstobj (name st$c recognizer st$ap creator corr-fn corr-fn-exists exports protect-default congruent-to non-executable see-doc ctx wrld state) (cond ((atom exports) (er soft ctx "~x0 requires at least one export. ~@1" 'defabsstobj see-doc)) ((not (stobjp st$c t wrld)) (er soft ctx "The symbol ~x0 is not the name of a stobj in the current ACL2 world. ~ ~ ~@1" st$c see-doc)) ((not (true-listp exports)) (er soft ctx "DEFABSSTOBJ requires the value of its :EXPORTS keyword argument to ~ be a non-empty true list. ~@0" see-doc)) ((first-keyword exports) (er soft ctx "The keyword ~x0 is being specified as an export. This may indicate ~ a parenthesis error, since keywords cannot be exports. ~@1" (first-keyword exports) see-doc)) ((and congruent-to (not (and (symbolp congruent-to) (getpropc congruent-to 'absstobj-info nil wrld)))) (er soft ctx "The :CONGRUENT-TO parameter of a DEFABSSTOBJ must either be nil or ~ the name of an existing abstract stobj, but the value ~x0 is ~ neither. ~@1." congruent-to see-doc)) ((not (booleanp non-executable)) (er soft ctx "DEFABSSTOBJ requires the :NON-EXECUTABLE keyword argument to have a ~ Boolean value. See :DOC defabsstobj.")) ((not (booleanp corr-fn-exists)) (er soft ctx "DEFABSSTOBJ requires the :CORR-FN-EXISTS keyword argument to have a ~ Boolean value. See :DOC defabsstobj.")) ((and (not congruent-to) corr-fn-exists (not (and (symbolp corr-fn) (function-symbolp corr-fn wrld)))) (er soft ctx "Since :CORR-FN-EXISTS is T, the DEFABSSTOBJ event for ~x0 is illegal ~ because the value of :CORR-FN must be a known function symbol, yet ~ ~x1 is not. See :DOC stobj-attachment-restrictions for restrictions ~ on the creator and exported functions when :CORR-FN-EXISTS has value ~ NIL." name corr-fn)) (t (er-progn (chk-all-but-new-name name ctx 'stobj wrld state) (chk-legal-defstobj-name name state) (er-let* ((wrld1 (chk-just-new-name name nil 'stobj nil ctx wrld state)) (wrld2 (chk-just-new-name (the-live-var name) nil 'stobj-live-var nil ctx wrld1 state))) (chk-acceptable-defabsstobj1 name st$c st$ap corr-fn (list* recognizer creator exports) (list* :recognizer :creator nil) protect-default congruent-to see-doc ctx wrld2 state nil nil))))))
defabsstobj-axiomatic-defsfunction
(defun defabsstobj-axiomatic-defs (methods) (cond ((endp methods) nil) (t (cons (let ((method (car methods))) (mv-let (name formals guard-post logic stobjs-in-logic) (mv (access absstobj-method method :name) (access absstobj-method method :formals) (access absstobj-method method :guard-post) (access absstobj-method method :logic) (access absstobj-method method :stobjs-in-logic)) `(,NAME ,FORMALS (declare (xargs :guard ,GUARD-POST ,@(LET ((STOBJS (REMOVE-EQ NIL STOBJS-IN-LOGIC))) (AND STOBJS `(:STOBJS ,STOBJS))))) (,LOGIC ,@FORMALS)))) (defabsstobj-axiomatic-defs (cdr methods))))))
with-inside-absstobj-updatefunction
(defun with-inside-absstobj-update (temp saved name form) (declare (xargs :guard (and (symbolp name) (symbolp temp)))) `(let* ((,TEMP *inside-absstobj-update*) (,SAVED (svref ,TEMP 0))) (declare (type simple-array ,TEMP)) (cond ((eq ,SAVED :ignore) ,FORM) ((eql ,SAVED 0) (setf (svref ,TEMP 0) 1) (our-multiple-value-prog1 ,FORM (setf (svref ,TEMP 0) 0))) ((typep ,SAVED 'fixnum) (incf (the fixnum (svref ,TEMP 0))) (our-multiple-value-prog1 ,FORM (decf (the fixnum (svref ,TEMP 0))))) (t (cond ((eq nil ,SAVED) (setf (svref ,TEMP 0) ',NAME) (our-multiple-value-prog1 ,FORM (setf (svref ,TEMP 0) nil))) (t (push ',NAME (svref ,TEMP 0)) (our-multiple-value-prog1 ,FORM (pop (svref ,TEMP 0)))))))))
defabsstobj-raw-deffunction
(defun defabsstobj-raw-def (method) (let* ((name (access absstobj-method method :name)) (exec (access absstobj-method method :exec)) (protect (access absstobj-method method :protect)) (form0 `(cons ',EXEC args)) (body (cond ((null protect) form0) (t `(with-inside-absstobj-update 'temp 'saved ',NAME ,FORM0))))) (list name '(&rest args) body)))
defabsstobj-raw-defs-recfunction
(defun defabsstobj-raw-defs-rec (methods) (cond ((endp methods) nil) (t (cons (defabsstobj-raw-def (car methods)) (defabsstobj-raw-defs-rec (cdr methods))))))
defabsstobj-raw-defsfunction
(defun defabsstobj-raw-defs (st-name methods) (list* (let* ((method (car methods)) (name (access absstobj-method method :name)) (logic (or (access absstobj-method method :logic) (absstobj-name st-name :recognizer-logic)))) `(,NAME (x) (list 'let (list (list 'y x)) '(cond ((live-stobjp y) t) (t (,LOGIC y)))))) (let* ((method (cadr methods)) (name (access absstobj-method method :name)) (exec (access absstobj-method method :exec))) (assert$ (not (eq exec 'args)) `(,NAME (&rest args) (cons ',EXEC args)))) (defabsstobj-raw-defs-rec (cddr methods))))
expand-recognizerfunction
(defun expand-recognizer (st-name recognizer see-doc ctx state) (let ((recognizer (or recognizer (absstobj-name st-name :recognizer)))) (cond ((symbolp recognizer) (value (list recognizer :logic (absstobj-name st-name :recognizer-logic) :exec (absstobj-name st-name :recognizer-exec)))) ((and (consp recognizer) (keyword-value-listp (cdr recognizer)) (assoc-keyword :logic (cdr recognizer)) (assoc-keyword :exec (cdr recognizer)) (null (cddddr (cdr recognizer)))) (value recognizer)) (t (er soft ctx "Illegal :RECOGNIZER field. ~@0" see-doc)))))
put-absstobjs-in-and-outsfunction
(defun put-absstobjs-in-and-outs (st methods wrld) (cond ((endp methods) wrld) (t (put-absstobjs-in-and-outs st (cdr methods) (mv-let (name posn stobjs-in-exec stobjs-out) (let ((method (car methods))) (mv (access absstobj-method method :name) (access absstobj-method method :stobjs-in-posn) (access absstobj-method method :stobjs-in-exec) (access absstobj-method method :stobjs-out))) (putprop name 'stobjs-in (if posn (update-nth posn st stobjs-in-exec) stobjs-in-exec) (putprop name 'stobjs-out stobjs-out wrld)))))))
method-execfunction
(defun method-exec (name methods) (cond ((endp methods) (er hard 'method-exec "Name ~x0 not found in methods, ~x1." name methods)) ((eq name (access absstobj-method (car methods) :name)) (access absstobj-method (car methods) :exec)) (t (method-exec name (cdr methods)))))
defabsstobj-raw-initfunction
(defun defabsstobj-raw-init (creator-name methods) `(,(METHOD-EXEC CREATOR-NAME METHODS)))
defabsstobj-missing-msgfunction
(defun defabsstobj-missing-msg (missing wrld) (assert$ missing (let* ((tuple (car missing)) (name (car tuple)) (expected-formula (untranslate (cadr tuple) t wrld)) (old-formula (untranslate (cddr tuple) t wrld)) (expected-defthm `(defthm ,NAME ,EXPECTED-FORMULA :rule-classes nil)) (msg (cond (old-formula (msg "~%~Y01[Note discrepancy with existing ~ formula named ~x2:~| ~Y31~|]~%" expected-defthm nil name old-formula)) (t (msg "~%~Y01" expected-defthm nil name old-formula))))) (cond ((endp (cdr missing)) msg) (t (msg "~@0~@1" msg (defabsstobj-missing-msg (cdr missing) wrld)))))))
update-guard-postfunction
(defun update-guard-post (logic-subst methods) (cond ((endp methods) nil) (t (cons (change absstobj-method (car methods) :guard-post (sublis-fn-simple logic-subst (access absstobj-method (car methods) :guard-pre))) (update-guard-post logic-subst (cdr methods))))))
defabsstobj-logic-substfunction
(defun defabsstobj-logic-subst (methods) (cond ((endp methods) nil) (t (acons (access absstobj-method (car methods) :logic) (access absstobj-method (car methods) :name) (defabsstobj-logic-subst (cdr methods))))))
chk-defabsstobj-guardfunction
(defun chk-defabsstobj-guard (method ctx wrld state-vars) (mv-let (ctx msg) (translate-cmp (access absstobj-method method :guard-post) '(nil) t (stobjs-in (access absstobj-method method :name) wrld) ctx wrld state-vars) (cond (ctx (er-cmp ctx "The guard for exported function ~x0 fails to ~ pass a test for being suitably single-threaded. ~ ~ Here is that guard (derived from the guard ~ for function ~x1).~| ~x2~|And here is the ~ error message for the failed test.~| ~@3" (access absstobj-method method :name) (access absstobj-method method :logic) (access absstobj-method method :guard-post) msg)) (t (value-cmp nil)))))
chk-defabsstobj-guards1function
(defun chk-defabsstobj-guards1 (methods msg ctx wrld state-vars) (cond ((endp methods) msg) (t (mv-let (ctx0 msg0) (chk-defabsstobj-guard (car methods) ctx wrld state-vars) (chk-defabsstobj-guards1 (cdr methods) (cond (ctx0 (assert$ msg0 (cond (msg (msg "~@0~|~%~@1" msg msg0)) (t msg0)))) (t msg)) ctx wrld state-vars)))))
chk-defabsstobj-guardsfunction
(defun chk-defabsstobj-guards (methods congruent-to ctx wrld state) (cond (congruent-to (value nil)) (t (let ((msg (chk-defabsstobj-guards1 methods nil ctx wrld (default-state-vars t)))) (cond (msg (er soft ctx "At least one guard of an exported function fails to ~ obey single-threadedness restrictions. See :DOC ~ defabsstobj. See below for details.~|~%~@0~|~%" msg)) (t (value nil)))))))
make-absstobj-tuplesfunction
(defun make-absstobj-tuples (methods) (cond ((endp methods) nil) (t (cons (list* (access absstobj-method (car methods) :name) (access absstobj-method (car methods) :logic) (access absstobj-method (car methods) :exec) (access absstobj-method (car methods) :updater)) (make-absstobj-tuples (cdr methods))))))
put-defabsstobj-invariant-riskfunction
(defun put-defabsstobj-invariant-risk (methods wrld) (cond ((endp methods) wrld) (t (let ((method (car methods))) (put-defabsstobj-invariant-risk (cdr methods) (let ((invariant-risk (getpropc (access absstobj-method method :exec) 'invariant-risk nil wrld))) (cond (invariant-risk (putprop (access absstobj-method method :name) 'invariant-risk invariant-risk wrld)) (t wrld))))))))
congruent-absstobj-tuples-recfunction
(defun congruent-absstobj-tuples-rec (tuples1 tuples2 all-tuples1 all-tuples2) (cond ((endp tuples1) (null tuples2)) (t (let ((x1 (car tuples1)) (x2 (car tuples2))) (and (or (equal (cdr x1) (cdr x2)) (and (eq (cadr x1) (cadr x2)) (eq (caddr x1) (caddr x2)) (let ((up1 (cdddr x1)) (up2 (cdddr x2))) (and up1 up2 (eql (key-position-from-end-eq up1 all-tuples1) (key-position-from-end-eq up2 all-tuples2)))))) (congruent-absstobj-tuples-rec (cdr tuples1) (cdr tuples2) all-tuples1 all-tuples2))))))
congruent-absstobj-tuplesfunction
(defun congruent-absstobj-tuples (tuples1 tuples2) (congruent-absstobj-tuples-rec tuples1 tuples2 tuples1 tuples2))
defabsstobj-methods-for-attachment1function
(defun defabsstobj-methods-for-attachment1 (st st-new absstobj-tuples st$c fields types protect-default see-doc ctx wrld state methods) (cond ((endp fields) (value (list* nil (reverse methods) wrld))) (t (mv-let (erp method) (translate-absstobj-field st st-new (car absstobj-tuples) st$c (car fields) (car types) protect-default (ld-skip-proofsp state) see-doc ctx wrld) (cond (erp (er soft erp "~@0" method)) (t (defabsstobj-methods-for-attachment1 st st-new (cdr absstobj-tuples) st$c (cdr fields) (cdr types) protect-default see-doc ctx wrld state (cons method methods))))))))
defabsstobj-methods-for-attachmentfunction
(defun defabsstobj-methods-for-attachment (name name-new absstobj-tuples st$c recognizer creator exports protect-default see-doc ctx wrld state) (defabsstobj-methods-for-attachment1 name name-new absstobj-tuples st$c (list* recognizer creator exports) (list* :recognizer :creator nil) protect-default see-doc ctx wrld state nil))
defabsstobj-update-ext-gens-1function
(defun defabsstobj-update-ext-gens-1 (methods ext-gens acc) (cond ((endp methods) acc) (t (let ((method (car methods))) (defabsstobj-update-ext-gens-1 (cdr methods) ext-gens (if (member-eq (access absstobj-method method :exec) ext-gens) (cons (access absstobj-method method :name) acc) acc))))))
defabsstobj-update-ext-gensfunction
(defun defabsstobj-update-ext-gens (ext-gens doit names methods wrld) (cond (doit (global-set 'ext-gens (append? names ext-gens) wrld)) ((null ext-gens) wrld) (t (global-set? 'ext-gens (defabsstobj-update-ext-gens-1 methods ext-gens ext-gens) wrld ext-gens))))
fix-export-updaters1function
(defun fix-export-updaters1 (old old-to-new) (cond ((endp old) nil) (t (let* ((field-old (car old)) (updater-old (cadr (assoc-keyword :updater (cdr field-old))))) (cond (updater-old (mv-let (pre post) (split-keyword-alist :updater (cdr field-old)) (cons (cons (car field-old) (append pre (list* :updater (cdr (assoc-eq (cadr post) old-to-new)) (cddr post)))) (fix-export-updaters1 (cdr old) old-to-new)))) (t (cons-with-hint field-old (fix-export-updaters1 (cdr old) old-to-new) (cdr old))))))))
export-namesfunction
(defun export-names (exports) (cond ((endp exports) nil) (t (cons (if (symbolp (car exports)) (car exports) (caar exports)) (export-names (cdr exports))))))
fix-export-updatersfunction
(defun fix-export-updaters (old new) (let ((old-to-new (pairlis$ (export-names old) (export-names new)))) (fix-export-updaters1 old old-to-new)))
absstobj-producer-fnsfunction
(defun absstobj-producer-fns (st-name methods) (cond ((endp methods) nil) ((not (member-eq st-name (access absstobj-method (car methods) :stobjs-out))) (absstobj-producer-fns st-name (cdr methods))) (t (list* (access absstobj-method (car methods) :logic) (access absstobj-method (car methods) :exec) (absstobj-producer-fns st-name (cdr methods))))))
chk-defabsstobj-attachments-ancestorsfunction
(defun chk-defabsstobj-attachments-ancestors (st-name corr-fn-exists corr-fn methods wrld) (let* ((recognizer-method (car methods)) (creator-and-export-methods (cdr methods)) (recognizer-logic (access absstobj-method recognizer-method :logic)) (lst (cons recognizer-logic (if corr-fn-exists (list corr-fn) (absstobj-producer-fns st-name creator-and-export-methods))))) (canonical-ancestors-lst lst wrld)))
chk-defabsstobj-attachmentsfunction
(defun chk-defabsstobj-attachments (name anc corr-fn-exists congruent-to ctx wrld state) (cond (congruent-to (value nil)) (t (let ((bad-attached-fns (attached-fns anc wrld))) (cond (bad-attached-fns (er soft ctx "The proposed defabsstobj event for ~x0 is illegal because ~ ~#1~[there is an ancestor ~&1 of ~s2 that has an ~ attachment~/there are ancestors ~&1 of ~s2 that have ~ attachments~]. See :DOC stobj-attachment-restrictions." name bad-attached-fns (if corr-fn-exists "the correlation or recognizer function" "the recognizer, creator, or some exported function"))) (t (value nil)))))))
put-defabsstobj-attachments-disallowedfunction
(defun put-defabsstobj-attachments-disallowed (name anc corr-fn-exists congruent-to wrld installed-w) (cond (congruent-to wrld) (t (mark-attachment-disallowed anc name (if corr-fn-exists :defabsstobj :defabsstobj-no-corr) wrld installed-w))))
defabsstobj-fn1function
(defun defabsstobj-fn1 (st-name st$c recognizer creator corr-fn corr-fn-exists exports protect-default congruent-to non-executable attachable missing-only ctx state event-form discriminator creator-name-orig absstobj-tuples-new) (let* ((wrld0 (w state)) (st-name-new (if discriminator (cadr event-form) st-name)) (see-doc "See :DOC defabsstobj.") (st$c (or st$c (absstobj-name st-name :c))) (creator (or creator (absstobj-name st-name :creator))) (creator-name (if (consp creator) (car creator) creator)) (corr-fn (or corr-fn (absstobj-name st-name :corr-fn))) (ext-gens-wrld0 (global-val 'ext-gens wrld0))) (cond ((and (not discriminator) (redundant-defabsstobjp st-name event-form wrld0)) (value 'redundant)) (t (er-let* ((recognizer0 (expand-recognizer st-name recognizer see-doc ctx state)) (recognizer (value (if discriminator (cons st-name-new (cdr recognizer0)) recognizer0))) (st$ap (value (cadr (assoc-keyword :logic (cdr recognizer))))) (missing/methods/wrld1 (if discriminator (defabsstobj-methods-for-attachment st-name st-name-new absstobj-tuples-new st$c recognizer creator exports protect-default see-doc ctx wrld0 state) (chk-acceptable-defabsstobj st-name st$c recognizer st$ap creator corr-fn corr-fn-exists exports protect-default congruent-to non-executable see-doc ctx wrld0 state)))) (let* ((missing (car missing/methods/wrld1)) (methods0 (cadr missing/methods/wrld1)) (absstobj-info-cong (and congruent-to (getpropc congruent-to 'absstobj-info nil wrld0))) (absstobj-tuples (make-absstobj-tuples methods0)) (att-name (and (eq attachable t) (assert$ (null discriminator) (attached-stobj st-name wrld0 t)))) (two-passes (or att-name discriminator))) (er-progn (if att-name (assert$ (null discriminator) (chk-absstobj-attachment st-name att-name absstobj-tuples ctx wrld0 see-doc state)) (value nil)) (cond ((and missing-only (not congruent-to)) (value (car missing/methods/wrld1))) ((and congruent-to (not att-name) (not (equal st$c (access absstobj-info absstobj-info-cong :st$c)))) (er soft ctx "The value provided for :congruent-to, ~x0, is illegal, ~ because the foundational stobj associated with ~x0 is ~x1, ~ while the foundational stobj proposed for ~x2 is ~x3. ~@4" congruent-to (access absstobj-info absstobj-info-cong :st$c) st-name st$c see-doc)) ((and congruent-to (not att-name) (not (congruent-absstobj-tuples absstobj-tuples (access absstobj-info absstobj-info-cong :absstobj-tuples)))) (er soft ctx "The value provided for :congruent-to, ~x0, is illegal. ~ ACL2 requires that the :LOGIC, :EXEC, and :UPDATER ~ functions match up perfectly (in the same order), for stobj ~ primitives introduced by the proposed new abstract stobj, ~ ~x1 and the existing stobj to which it is supposed to be ~ congruent, ~x0. Here are the lists of tuples (:LOGIC :EXEC ~ . :UPDATER) for each.~|~%For ~x1 (proposed):~|~Y24~%For ~ ~x0:~|~Y34~%~|~@5" congruent-to st-name (strip-cdrs absstobj-tuples) (strip-cdrs (access absstobj-info absstobj-info-cong :absstobj-tuples)) nil see-doc)) (t (mv-let (msg accessors updaters) (chk-defabsstobj-updaters st$c methods0 wrld0) (cond (msg (er soft ctx "~@0 ~@1" msg see-doc)) (missing-only (value missing)) (t (er-progn (cond ((or (null missing) (member-eq (ld-skip-proofsp state) '(include-book include-book-with-locals))) (value nil)) ((ld-skip-proofsp state) (pprogn (warning$ ctx "defabsstobj" "The following events would have to be ~ admitted, if not for proofs currently ~ being skipped (see :DOC ~ ld-skip-proofsp), before the given ~ defabsstobj event. ~@0~|~@1" see-doc (defabsstobj-missing-msg missing wrld0)) (value nil))) (t (er soft ctx "The following events must be admitted before the ~ given defabsstobj event is admitted. ~@0~|~@1" see-doc (defabsstobj-missing-msg missing wrld0)))) (enforce-redundancy event-form ctx wrld0 (let* ((methods (update-guard-post (defabsstobj-logic-subst methods0) methods0)) (wrld1 (cddr missing/methods/wrld1)) (ax-def-lst (defabsstobj-axiomatic-defs methods)) (raw-def-lst (defabsstobj-raw-defs st-name methods)) (names (strip-cars ax-def-lst)) (the-live-var (the-live-var st-name-new))) (er-progn (cond ((equal names (strip-cars raw-def-lst)) (value nil)) (t (value (er hard ctx "Defabsstobj-axiomatic-defs and ~ defabsstobj-raw-defs are out of sync! ~ We expect them to define the same list ~ of names. Here are the strip-cars of ~ the axiomatic defs: ~x0. And here are ~ the strip-cars of the raw defs: ~x1." names (strip-cars raw-def-lst))))) (revert-world-on-error (pprogn (set-w 'extension wrld1 state) (er-progn (process-embedded-events 'defabsstobj (table-alist 'acl2-defaults-table wrld1) (or (ld-skip-proofsp state) t) (current-package state) (list 'defstobj st-name-new names) (append (pairlis-x1 'defun ax-def-lst) `((encapsulate nil (set-inhibit-warnings "theory") (in-theory (disable (:executable-counterpart ,CREATOR-NAME)))))) 0 t (f-get-global 'cert-data state) ctx state) (let* ((wrld2 (w state)) (anc (and (not congruent-to) (not two-passes) (chk-defabsstobj-attachments-ancestors st-name corr-fn-exists corr-fn methods wrld2)))) (er-progn (if two-passes (value nil) (chk-defabsstobj-attachments st-name anc corr-fn-exists congruent-to ctx wrld2 state)) (let* ((congruent-stobj-rep (and congruent-to (congruent-stobj-rep congruent-to wrld2))) (non-memoizable (getpropc st$c 'non-memoizable nil wrld2)) (wrld3 (put-defabsstobj-invariant-risk methods (putprop st-name-new 'congruent-stobj-rep congruent-stobj-rep (putprop-unless st-name-new 'non-memoizable non-memoizable nil (putprop-unless st-name-new 'non-executablep non-executable nil (putprop st-name-new 'absstobj-info (make absstobj-info :st$c st$c :absstobj-tuples absstobj-tuples) (putprop st-name-new 'symbol-class :common-lisp-compliant (put-absstobjs-in-and-outs st-name-new methods (putprop st-name-new 'stobj (make stobj-property :live-var the-live-var :recognizer (car names) :creator (cadr names) :names (sort-absstobj-names (cddr names) accessors updaters)) (putprop-x-lst1 names 'stobj-function st-name-new (putprop the-live-var 'stobj-live-var st-name-new (putprop the-live-var 'symbol-class :common-lisp-compliant wrld2)))))))))))) (wrld4 (if two-passes wrld3 (put-defabsstobj-attachments-disallowed st-name anc corr-fn-exists congruent-to wrld3 wrld2))) (discriminator1 (or discriminator (cons 'defabsstobj (make defstobj-redundant-raw-lisp-discriminator-value :event event-form :recognizer (car names) :creator creator-name :congruent-stobj-rep (or congruent-stobj-rep st-name-new) :non-memoizable non-memoizable :non-executable non-executable)))) (raw-init-form-new (defabsstobj-raw-init (or creator-name-orig creator-name) methods)) (wrld5 (if att-name wrld4 (defabsstobj-update-ext-gens ext-gens-wrld0 (or discriminator attachable) names methods wrld4)))) (pprogn (set-w 'extension wrld5 state) (er-progn (chk-defabsstobj-guards methods congruent-to ctx wrld5 state) (cond (att-name (pprogn (set-w 'retraction wrld1 state) (let ((kwa (cddr (get-event att-name wrld0)))) (defabsstobj-fn1 att-name (cadr (assoc-keyword :foundation kwa)) (cadr (assoc-keyword :recognizer kwa)) (cadr (assoc-keyword :creator kwa)) :irrelevant :irrelevant (fix-export-updaters (cadr (assoc-keyword :exports kwa)) exports) (cadr (assoc-keyword :protect-default kwa)) (cadr (assoc-keyword :congruent-to kwa)) non-executable nil nil ctx state event-form discriminator1 creator-name absstobj-tuples)))) (t (install-event st-name-new event-form 'defstobj (list* st-name-new the-live-var names) nil `(defabsstobj ,ST-NAME-NEW ,THE-LIVE-VAR ,RAW-INIT-FORM-NEW ,RAW-DEF-LST ,DISCRIMINATOR1 ,AX-DEF-LST) t ctx wrld5 state)))))))))))))))))))))))))))
defabsstobj-fnfunction
(defun defabsstobj-fn (st-name st$c recognizer creator corr-fn corr-fn-exists exports protect-default congruent-to non-executable attachable missing-only state event-form) (with-ctx-summarized (msg "( DEFABSSTOBJ ~x0 ...)" st-name) (cond ((not (booleanp attachable)) (er soft ctx "The value of the :ATTACHABLE keyword for DEFABSSTOBJ must be ~x0 or ~ ~x1. The value ~x2 is thus illegal." t nil attachable)) (t (defabsstobj-fn1 st-name st$c recognizer creator corr-fn corr-fn-exists exports protect-default congruent-to non-executable attachable missing-only ctx state event-form nil nil nil)))))
create-statefunction
(defun create-state nil (declare (xargs :guard t)) (coerce-object-to-state *default-state*))
with-local-statemacro
(defmacro with-local-state (mv-let-form) `(with-local-stobj state ,MV-LET-FORM))
collect-badged-fnsfunction
(defun collect-badged-fns (fns wrld) (cond ((endp fns) nil) ((mv-let (erp val) (ev-fncall-w 'executable-badge (list (car fns) wrld) wrld nil nil nil t nil) (assert$ (not erp) val)) (cons (car fns) (collect-badged-fns (cdr fns) wrld))) (t (collect-badged-fns (cdr fns) wrld))))
collect-macrosfunction
(defun collect-macros (names wrld) (cond ((endp names) nil) ((eq (getpropc (car names) 'macro-args t wrld) t) (collect-macros (cdr names) wrld)) (t (cons (car names) (collect-macros (cdr names) wrld)))))
push-untouchable-fnfunction
(defun push-untouchable-fn (name fn-p state event-form) (with-ctx-summarized (cond ((symbolp name) (msg "( PUSH-UNTOUCHABLE ~x0 ~x1)" name fn-p)) (t "( PUSH-UNTOUCHABLE ...)")) (let ((wrld (w state)) (event-form (or event-form (list 'push-untouchable name fn-p))) (names (if (symbolp name) (list name) name)) (untouchable-prop (cond (fn-p 'untouchable-fns) (t 'untouchable-vars)))) (cond ((not (symbol-listp names)) (er soft ctx "The argument to push-untouchable must be either a non-nil symbol ~ or a non-empty true list of symbols and ~x0 is neither." name)) ((subsetp-eq names (global-val untouchable-prop wrld)) (stop-redundant-event ctx state)) (t (let ((bad1 (if fn-p (collect-never-untouchable-fns-entries names (global-val 'never-untouchable-fns wrld)) nil)) (bad2 (if fn-p (collect-badged-fns names wrld) nil)) (bad3 (and fn-p (collect-macros names wrld)))) (cond (bad1 (er soft ctx "You have tried to make untouchable the ~ function~#0~[~/s~], ~&0. However, ~#0~[this function ~ is~/these functions are~] sometimes introduced into ~ proofs by one or more metatheorems or clause processors ~ having well-formedness guarantees. If you insist on ~ making ~#0~[this name~/these names~] untouchable you ~ must redefine the relevant metafunctions and clause ~ processors so they do not create terms involving ~ ~#0~[it~/them~] and prove and cite appropriate ~ :WELL-FORMEDNESS-GUARANTEE theorems. The following data ~ structure may help you find the relevant events to ~ change. The data structure is an alist pairing each ~ function name above with information about all the ~ metatheorems or clause processors that may introduce ~ that name. The information for each metatheorem or ~ clause processor is the name of the correctness theorem, ~ the name of the metafunction or clause processor ~ verified by that metatheorem, the name of the ~ well-formedness guarantee for that metafunction or ~ clause processor, and analogous information about any ~ hypothesis metafunction involved. All of these events ~ (and possibly their supporting functions and lemmas) ~ must be fixed so that the names you now want to be ~ untouchable are not produced.~%~X12" (strip-cars bad1) bad1 nil)) (bad2 (er soft ctx "You have tried to make untouchable the ~ function~#0~[~/s~], ~&0. However, ~#0~[this function ~ has a badge~/these functions have badges~] (see :DOC ~ apply$). We do not allow a badged function F to be ~ untouchable because (apply$ 'F (list arg1 arg2 ...)) is ~ still a legal term that, however, is a proxy for (F arg1 ~ arg2 ...)." bad2)) (bad3 (er soft ctx "You have tried to make untouchable the macro~#0~[~/s~], ~ ~&0. However, macros are never directly untouchable. ~ To get the effect of an untouchable macro, see :DOC ~ defmacro-untouchable." bad3)) (t (install-event name event-form 'push-untouchable 0 nil nil nil nil (global-set untouchable-prop (union-eq names (global-val untouchable-prop wrld)) wrld) state)))))))))
remove-untouchable-fnfunction
(defun remove-untouchable-fn (name fn-p state event-form) (with-ctx-summarized (cond ((symbolp name) (msg "( REMOVE-UNTOUCHABLE ~x0 ~x1)" name fn-p)) (t "( REMOVE-UNTOUCHABLE ...)")) (let ((wrld (w state)) (event-form (or event-form (list 'remove-untouchable name fn-p))) (names (if (symbolp name) (list name) name)) (untouchable-prop (cond (fn-p 'untouchable-fns) (t 'untouchable-vars)))) (cond ((not (symbol-listp names)) (er soft ctx "The argument to remove-untouchable must be either a non-nil ~ symbol or a non-empty true list of symbols and ~x0 is neither." name)) ((not (intersectp-eq names (global-val untouchable-prop wrld))) (stop-redundant-event ctx state)) (t (let ((old-untouchable-prop (global-val untouchable-prop wrld))) (install-event name event-form 'remove-untouchable 0 nil nil nil nil (global-set untouchable-prop (set-difference-eq old-untouchable-prop names) wrld) state)))))))
def-body-lemmasfunction
(defun def-body-lemmas (def-bodies lemmas) (cond ((endp def-bodies) nil) (t (cons (find-runed-lemma (access def-body (car def-bodies) :rune) lemmas) (def-body-lemmas (cdr def-bodies) lemmas)))))
show-bodiesmacro
(defmacro show-bodies (fn) (declare (xargs :guard (or (symbolp fn) (and (true-listp fn) (eql (length fn) 2) (eq (car fn) 'quote) (symbolp (cadr fn)))))) (let ((fn (if (symbolp fn) fn (cadr fn)))) `(let* ((wrld (w state)) (fn (deref-macro-name ',FN (macro-aliases wrld))) (lemmas (def-body-lemmas (getpropc fn 'def-bodies nil wrld) (getpropc fn 'lemmas nil wrld)))) (cond (lemmas (pprogn (fms "Definitional bodies available for ~x0, current ~ one listed first:~|" (list (cons #\0 fn)) (standard-co state) state nil) (print-info-for-rules (info-for-lemmas lemmas t (ens-maybe-brr state) wrld) (standard-co state) state))) (t (er soft 'show-bodies "There are no definitional bodies for ~x0." fn))))))
set-body-fn1function
(defun set-body-fn1 (rune def-bodies acc) (cond ((null def-bodies) nil) ((equal rune (access def-body (car def-bodies) :rune)) (cons (car def-bodies) (revappend acc (cdr def-bodies)))) (t (set-body-fn1 rune (cdr def-bodies) (cons (car def-bodies) acc)))))
set-body-fnfunction
(defun set-body-fn (fn name-or-rune state event-form) (with-ctx-summarized (cond ((symbolp fn) (msg "( SET-BODY ~x0)" fn)) (t "( SET-BODY ...)")) (let* ((wrld (w state)) (rune (if (symbolp name-or-rune) (list :definition name-or-rune) name-or-rune)) (fn (and (symbolp fn) (deref-macro-name fn (macro-aliases wrld)))) (old-def-bodies (getpropc fn 'def-bodies nil wrld)) (def-bodies (and fn old-def-bodies (cond ((equal rune (access def-body (car old-def-bodies) :rune)) :redundant) (t (set-body-fn1 rune old-def-bodies nil)))))) (cond ((null def-bodies) (er soft ctx "No definitional body was found for function ~x0 with rune ~ ~x1. See :DOC set-body." fn rune)) ((eq def-bodies :redundant) (stop-redundant-event ctx state)) (t (install-event rune event-form 'set-body 0 nil nil nil ctx (putprop fn 'def-bodies def-bodies wrld) state))))))
trace-multiplicityfunction
(defun trace-multiplicity (name state) (let ((stobjs-out (getpropc name 'stobjs-out))) (and stobjs-out (length stobjs-out))))
*1*defpfunction
(defun *1*defp (trace-spec wrld) (let ((fn (car trace-spec))) (not (eq (getpropc fn 'formals t wrld) t))))
trace$-er-msgfunction
(defun trace$-er-msg (fn) (msg "Ignoring request to trace function ~x0, because" fn))
decls-and-docfunction
(defun decls-and-doc (forms) (cond ((endp forms) nil) ((or (stringp (car forms)) (and (consp (car forms)) (eq (caar forms) 'declare))) (cons (car forms) (decls-and-doc (cdr forms)))) (t nil)))
trace$-when-gcondfunction
(defun trace$-when-gcond (gcond form) (if gcond `(when ,GCOND ,FORM) form))
evisceration-stobj-mark-simplefunction
(defun evisceration-stobj-mark-simple (name) (cond ((eq name 'state) *evisceration-state-mark*) (t (cons *evisceration-mark* (stobj-print-name name)))))
stobj-evisceration-alistfunction
(defun stobj-evisceration-alist (user-stobj-alist state) (cond ((endp user-stobj-alist) (list (cons (coerce-state-to-object state) *evisceration-state-mark*))) (t (cons (cons (cdar user-stobj-alist) (evisceration-stobj-mark-simple (caar user-stobj-alist))) (stobj-evisceration-alist (cdr user-stobj-alist) state)))))
trace-evisceration-alistfunction
(defun trace-evisceration-alist (state) (append (world-evisceration-alist state nil) (stobj-evisceration-alist (user-stobj-alist state) state)))
set-trace-evisc-tuplefunction
(defun set-trace-evisc-tuple (val state) (declare (ignore val)) state)
hide-nume-in-rewrite-or-linear-rulefunction
(defun hide-nume-in-rewrite-or-linear-rule (lemma) (cond ((eq (record-type lemma) 'rewrite-rule) (change rewrite-rule lemma :nume '|some-nume|)) ((eq (record-type lemma) 'linear-lemma) (change linear-lemma lemma :nume '|some-nume|)) (t lemma)))
prettyify-brr-gstack-framefunction
(defun prettyify-brr-gstack-frame (frame) (case (access gframe frame :sys-fn) ((rewrite-with-lemma rewrite-quoted-constant-with-lemma) (let* ((args (access gframe frame :args)) (lemma (cadr args)) (geneqv (cddr args))) (change gframe frame :args (list* (car args) (hide-nume-in-rewrite-or-linear-rule lemma) geneqv)))) (add-linear-lemma (let* ((args (access gframe frame :args)) (lemma (cdr args))) (change gframe frame :args (cons (car args) (hide-nume-in-rewrite-or-linear-rule lemma))))) (otherwise frame)))
prettyify-brr-gstackfunction
(defun prettyify-brr-gstack (gstack) (cond ((endp gstack) nil) (t (cons (prettyify-brr-gstack-frame (car gstack)) (prettyify-brr-gstack (cdr gstack))))))
prettyify-brr-statusfunction
(defun prettyify-brr-status (hide-stuff-flg status) (cond ((null status) nil) (t `(make brr-status :entry-code ',(ACCESS BRR-STATUS STATUS :ENTRY-CODE) :brr-monitored-runes ',(ACCESS BRR-STATUS STATUS :BRR-MONITORED-RUNES) :brr-gstack ',(PRETTYIFY-BRR-GSTACK (ACCESS BRR-STATUS STATUS :BRR-GSTACK)) :brr-local-alist ',(LET* ((ALIST0 (ACCESS BRR-STATUS STATUS :BRR-LOCAL-ALIST)) (ALIST1 (COND ((AND HIDE-STUFF-FLG (ASSOC-EQ 'RCNST ALIST0)) (PUT-ASSOC-EQ 'RCNST '|some-rewrite-constant| ALIST0)) (T ALIST0))) (ALIST2 (COND ((AND HIDE-STUFF-FLG (ASSOC-EQ 'LEMMA ALIST1)) (LET ((LEMMA (CDR (ASSOC-EQ 'LEMMA ALIST1)))) (PUT-ASSOC-EQ 'LEMMA (HIDE-NUME-IN-REWRITE-OR-LINEAR-RULE LEMMA) ALIST1))) (T ALIST1))) (ALIST3 (COND ((AND HIDE-STUFF-FLG (ASSOC-EQ 'SAVED-STANDARD-OI ALIST2)) (PUT-ASSOC-EQ 'SAVED-STANDARD-OI '|some-channel| ALIST2)) (T ALIST2)))) ALIST3) :brr-previous-status ,(PRETTYIFY-BRR-STATUS HIDE-STUFF-FLG (ACCESS BRR-STATUS STATUS :BRR-PREVIOUS-STATUS))))))
print-brr-statusfunction
(defun print-brr-status (hide-rcnst-flg) (declare (ignore hide-rcnst-flg)) nil)
chk-trace-options-auxfunction
(defun chk-trace-options-aux (form kwd formals ctx wrld state) (er-let* ((term (translate form '(nil) nil '(state) ctx wrld state))) (let ((vars (set-difference-eq (all-vars term) (append (case kwd ((:entry :cond) '(traced-fn trace-level arglist state)) (:exit '(traced-fn trace-level arglist value values state)) (:hide nil) (otherwise '(state))) formals)))) (cond (vars (er soft ctx "Global variables, such as ~&0, are not allowed for ~ tracing option ~x1, especially without a trust tag. ~ See :DOC trace$." (reverse vars) kwd)) (t (value nil))))))
trace$-value-msgpfunction
(defun trace$-value-msgp (x kwd) (and (consp x) (keywordp (car x)) (or (and (member-eq (car x) '(:fmt :fmt!)) (consp (cdr x)) (null (cddr x))) (er hard 'trace$ "Illegal ~x0 value. A legal ~x0 value starting with a ~ keyword must be of the form (:FMT x). The ~x0 value ~x1 ~ is therefore illegal." kwd x)) (car x)))
chk-trace-optionsfunction
(defun chk-trace-options (fn predefined trace-options formals ctx wrld state) (let ((notinline-tail (assoc-keyword :notinline trace-options)) (multiplicity-tail (assoc-keyword :multiplicity trace-options))) (cond ((and notinline-tail (not (member-eq (cadr notinline-tail) '(t nil :fncall)))) (er soft ctx "The only legal values for trace option :NOTINLINE are ~&0. The ~ value ~x1 is thus illegal." '(t nil :fncall) (cadr notinline-tail))) ((and multiplicity-tail (not (natp (cadr multiplicity-tail)))) (er soft ctx "The value of trace option :MULTIPLICITY must be a non-negative ~ integer value. The value ~x0 is thus illegal." (cadr multiplicity-tail))) ((and predefined (or (eq fn 'return-last) (and notinline-tail (not (eq (cadr notinline-tail) :fncall)) (or (member-eq fn (f-get-global 'program-fns-with-raw-code state)) (member-eq fn (f-get-global 'logic-fns-with-raw-code state)) (not (ttag wrld)))))) (cond ((eq fn 'return-last) (er soft ctx "Due to its special nature, tracing of ~x0 is not allowed." fn)) ((or (member-eq fn (f-get-global 'program-fns-with-raw-code state)) (member-eq fn (f-get-global 'logic-fns-with-raw-code state))) (er soft ctx "The ACL2 built-in function ~x0 has special code that will not be ~ captured properly when creating code for its traced executable ~ counterpart. It is therefore illegal to specify a value for ~ :NOTINLINE other than :FNCALL unless there is an active trust ~ tag. There may be an easy fix, so contact the ACL2 implementors ~ if this error presents a hardship." fn)) (t (er soft ctx "The function ~x0 is built into ACL2. It is therefore illegal to ~ specify a value for :NOTINLINE other than :FNCALL unless there ~ is an active trust tag." fn)))) ((ttag wrld) (value nil)) (t (let* ((cond-tail (assoc-keyword :cond trace-options)) (entry-tail (assoc-keyword :entry trace-options)) (exit-tail (assoc-keyword :exit trace-options)) (evisc-tuple-tail (assoc-keyword :evisc-tuple trace-options))) (er-progn (if cond-tail (chk-trace-options-aux (cadr cond-tail) :cond formals ctx wrld state) (value nil)) (if entry-tail (chk-trace-options-aux (if (trace$-value-msgp (cadr entry-tail) :entry) (cadr (cadr entry-tail)) (cadr entry-tail)) :entry formals ctx wrld state) (value nil)) (if exit-tail (chk-trace-options-aux (if (trace$-value-msgp (cadr exit-tail) :exit) (cadr (cadr exit-tail)) (cadr exit-tail)) :exit formals ctx wrld state) (value nil)) (if (and evisc-tuple-tail (not (member-eq (cadr evisc-tuple-tail) '(:print :no-print)))) (chk-trace-options-aux (cadr evisc-tuple-tail) :evisc-tuple formals ctx wrld state) (value nil))))))))
memoize-off-trace-errorfunction
(defun memoize-off-trace-error (fn ctx) (er hard ctx "Memoized function ~x0 is to be traced or untraced, but its ~ symbol-function differs from the :MEMOIZED-FN field of its memoization ~ hash-table entry. Perhaps the trace or untrace request occurred in ~ the context of ~x1; at any rate, it is illegal." fn ctx))
untrace$-fn1function
(defun untrace$-fn1 (fn state) (f-put-global 'trace-specs (remove1-assoc-eq fn (f-get-global 'trace-specs state)) state))
untrace$-recfunction
(defun untrace$-rec (fns ctx state) (cond ((endp fns) (value nil)) (t (let ((trace-spec (assoc-eq (car fns) (f-get-global 'trace-specs state)))) (cond (trace-spec (pprogn (untrace$-fn1 (car fns) state) (er-let* ((fnlist (untrace$-rec (cdr fns) ctx state))) (value (cons (car fns) fnlist))))) (t (pprogn (warning$ ctx "Trace" "The function ~x0 is not currently traced. Ignoring ~ attempt to apply untrace$ to it." (car fns)) (untrace$-rec (cdr fns) ctx state))))))))
untrace$-fnfunction
(defun untrace$-fn (fns state) (let ((ctx 'untrace$)) (cond ((null fns) (untrace$-rec (strip-cars (f-get-global 'trace-specs state)) ctx state)) ((symbol-listp fns) (untrace$-rec fns ctx state)) (t (er soft ctx "Untrace$ may only be applied to a list of symbols, hence not ~ to the list ~x0." fns)))))
maybe-untrace$-fnfunction
(defun maybe-untrace$-fn (fn state) (prog2$ (or (symbolp fn) (er hard 'untrace$ "Illegal attempt to untrace non-symbol: ~x0" fn)) (if (assoc-eq fn (f-get-global 'trace-specs state)) (untrace$-fn1 fn state) state)))
maybe-untrace$macro
(defmacro maybe-untrace$ (fn) `(maybe-untrace$-fn ',FN state))
trace$-fn-generalfunction
(defun trace$-fn-general (trace-spec ctx state) (let* ((fn (car trace-spec)) (trace-options (cdr trace-spec)) (native (cadr (assoc-keyword :native trace-options))) (wrld (w state)) (stobj-function (and (not (assoc-keyword :def trace-options)) (getpropc fn 'stobj-function nil wrld))) (def (or (cadr (assoc-keyword :def trace-options)) (let ((defun+def (cltl-def-from-name1 fn stobj-function nil wrld))) (cond (defun+def (cdr defun+def)) ((and stobj-function (cltl-def-from-name1 fn stobj-function t wrld)) :macro) (t nil))) (and (getpropc fn 'constrainedp nil wrld) (let ((formals (getpropc fn 'formals t wrld))) (assert$ (not (eq formals t)) (list fn formals (null-body-er fn formals t))))))) (formals-tail (assoc-keyword :formals trace-options)) (formals-default (and (not formals-tail) (atom def) (not native) (getpropc fn 'formals t wrld))) (formals (cond (formals-tail (cadr formals-tail)) ((consp def) (cadr def)) (t formals-default))) (evisc-tuple (cadr (assoc-keyword :evisc-tuple trace-options))) (compile (cadr (assoc-keyword :compile trace-options))) (predefined (getpropc fn 'predefined nil wrld))) (cond ((eq def :macro) (assert$ stobj-function (cond ((getpropc stobj-function 'absstobj-info nil wrld) (er very-soft ctx "~x0 cannot be traced, because it is a macro in raw Lisp, ~ introduced with the defabsstobj event for abstract stobj ~x1." fn stobj-function)) (t (er very-soft ctx "~x0 cannot be traced, because it is a macro in raw Lisp: its ~ introducing defstobj event (for stobj ~x1) was supplied with ~ :INLINE T." fn stobj-function))))) ((eq formals-default t) (cond ((getpropc fn 'macro-body nil wrld) (er very-soft ctx "~x0 is an ACL2 macro, hence cannot be traced in ACL2.~@1" fn (let ((sym (deref-macro-name fn (macro-aliases wrld)))) (cond ((eq sym fn) "") (t (msg " Perhaps you meant instead to trace the ~ corresponding function, ~x0." sym)))))) (t (er very-soft ctx "~@0 this symbol does not have an ACL2 function definition. ~ Consider using option :native, :def, or :formals. See :DOC ~ trace$." (trace$-er-msg fn))))) ((and def (not (equal (cadr def) formals))) (er very-soft ctx "~@0 the formals list, ~x1, does not match the definition's formals ~ ~x2." (trace$-er-msg fn) formals (cadr def))) ((not (symbol-listp formals)) (er very-soft ctx "~@0 the provided formals is not a true list of symbols." (trace$-er-msg fn))) ((and (keywordp evisc-tuple) (not (member-eq evisc-tuple '(:print :no-print)))) (er very-soft ctx "~@0 the only legal keyword values for option :evisc-tuple are ~ :print and :no-print." (trace$-er-msg fn))) ((member-eq fn '(wormhole-eval)) (er very-soft ctx "~@0 it is illegal (for ACL2 implementation reasons) to trace ~x1." (trace$-er-msg fn) fn)) ((and (not native) (equal (symbol-package-name fn) *main-lisp-package-name*)) (er very-soft ctx "~@0 the ACL2 trace$ utility must be used with option :native for ~ function symbols in the main Lisp package, ~x1. See :DOC trace$." (trace$-er-msg fn) *main-lisp-package-name*)) ((and compile native) (er very-soft ctx "~@0 we do not support compilation in trace specs (via keyword ~ :compile) when :native is present, as in trace spec ~x1. Consider ~ removing :compile and performing compilation separately." (trace$-er-msg fn) trace-spec)) (t (mv-let (erp val state) (chk-trace-options fn predefined trace-options formals ctx wrld state) (declare (ignore val)) (if erp (if (or (ttag wrld) (eq fn 'return-last)) (value nil) (er very-soft ctx "It is possible that you can use TRACE! to avoid the above ~ error (but consider that only with great care!). See :DOC ~ trace!.")) (let* ((state (maybe-untrace$-fn fn state)) (new-trace-specs (cons trace-spec (f-get-global 'trace-specs state)))) (cond ((and (not native) (null def)) (er very-soft ctx "ACL2 found no definition for ~x0. Consider supplying the ~ :def trace option. See :DOC trace$." fn)) (t (pprogn (f-put-global 'trace-specs new-trace-specs state) (cond (native (value trace-spec)) (t (value trace-spec)))))))))))))
trace$-fn-simplefunction
(defun trace$-fn-simple (trace-spec ctx state) (trace$-fn-general (list trace-spec) ctx state))
*trace-keywords*constant
(defconst *trace-keywords* '(:cond :entry :exit :compile :def :multiplicity :evisc-tuple :formals :hide :native :notinline))
*trace-keywords-needing-ttag*constant
(defconst *trace-keywords-needing-ttag* '(:native :def :multiplicity))
first-assoc-keywordfunction
(defun first-assoc-keyword (keys x) (declare (xargs :guard (and (keyword-value-listp x) (keyword-listp keys)))) (cond ((endp keys) nil) (t (or (assoc-keyword (car keys) x) (first-assoc-keyword (cdr keys) x)))))
*illegal-trace-spec-fmt-string*constant
(defconst *illegal-trace-spec-fmt-string* "A trace spec must be a symbol or a symbol consed onto an alternating list ~ of the form (:kwd1 val1 :kwd2 val2 ...). The trace spec ~x0 is thus ~ illegal. See :DOC trace$.")
trace$-fnfunction
(defun trace$-fn (trace-spec ctx state) (cond ((symbolp trace-spec) (trace$-fn-simple trace-spec ctx state)) ((and (consp trace-spec) (symbolp (car trace-spec)) (keyword-value-listp (cdr trace-spec))) (cond ((and (not (assoc-keyword :native (cdr trace-spec))) (strip-keyword-list *trace-keywords* (cdr trace-spec))) (let ((bad-keywords (evens (strip-keyword-list *trace-keywords* (cdr trace-spec))))) (er very-soft ctx "The keyword~#0~[~/s~] ~&0 ~#0~[is~/are~] illegal for ~ trace specs. See :DOC trace." bad-keywords))) ((and (not (f-get-global 'retrace-p state)) (first-assoc-keyword *trace-keywords-needing-ttag* (cdr trace-spec)) (not (ttag (w state)))) (er very-soft ctx "The keyword ~x0 cannot be used in a trace spec unless ~ there is an active trust tag. The trace spec ~x1 is ~ thus illegal. Consider using trace! instead. The ~ complete list of keywords that require a trust tag for ~ use in a trace spec is: ~x2." (car (first-assoc-keyword *trace-keywords-needing-ttag* (cdr trace-spec))) trace-spec *trace-keywords-needing-ttag*)) (t (trace$-fn-general trace-spec ctx state)))) (t (er very-soft ctx *illegal-trace-spec-fmt-string* trace-spec))))
trace$-lstfunction
(defun trace$-lst (trace-spec-lst ctx state) (cond ((endp trace-spec-lst) (value nil)) (t (er-let* ((tspec (trace$-fn (car trace-spec-lst) ctx state)) (tspecs (trace$-lst (cdr trace-spec-lst) ctx state))) (value (if tspec (cons tspec tspecs) tspecs))))))
trace$macro
(defmacro trace$ (&rest trace-specs) (cond ((null trace-specs) '(value (f-get-global 'trace-specs state))) (t `(pprogn (if (equal (f-get-global 'trace-co state) *standard-co*) state (fms "**NOTE**: Trace output will continue to go to a file.~|~%" nil *standard-co* state nil)) (if (eql 0 (f-get-global 'ld-level state)) (ld '((trace$-lst ',TRACE-SPECS 'trace$ state)) :ld-verbose nil :ld-user-stobjs-modified-warning :same) (trace$-lst ',TRACE-SPECS 'trace$ state))))))
with-ubt!macro
(defmacro with-ubt! (form) (let ((label 'with-ubt!-label)) `(er-progn (with-output :stack :push :off :all (ld '((deflabel ,LABEL) (with-output :stack :pop ,FORM) (ubt! ',LABEL)) :ld-verbose nil :ld-prompt nil :ld-pre-eval-print nil :ld-post-eval-print nil :ld-error-action :error :ld-user-stobjs-modified-warning :same)) (value :invisible))))
trace!macro
(defmacro trace! (&rest fns) (let ((form `(with-ubt! (with-output :off :all (with-output :on (error warning warning!) (make-event (progn (defttag :trace!) (progn! (er-let* ((specs (trace$ ,@FNS))) (value (list 'value-triple (kwote specs)))))))))))) form))
untrace$macro
(defmacro untrace$ (&rest fns) `(untrace$-fn ',FNS state))
open-trace-file-fnfunction
(defun open-trace-file-fn (filename state) (mv-let (chan state) (open-output-channel filename :character state) (cond (chan (pprogn (if (equal (f-get-global 'trace-co state) *standard-co*) state (close-output-channel (f-get-global 'trace-co state) state)) (f-put-global 'trace-co chan state))) (t (prog2$ (er hard 'open-trace-file "Unable to open file ~s0 for trace output." filename) state)))))
open-trace-filemacro
(defmacro open-trace-file (filename) (declare (xargs :guard (stringp filename))) `(pprogn (close-trace-file-fn t state) (open-trace-file-fn ,FILENAME state)))
close-trace-file-fnfunction
(defun close-trace-file-fn (quiet-p state) (if (equal (f-get-global 'trace-co state) *standard-co*) (if quiet-p state (prog2$ (er hard 'close-trace-file "No change: trace is already written to standard output.~%") state)) (pprogn (close-output-channel (f-get-global 'trace-co state) state) (f-put-global 'trace-co *standard-co* state))))
close-trace-filemacro
(defmacro close-trace-file nil '(close-trace-file-fn nil state))
break-on-errormacro
(defmacro break-on-error (&optional (on 't)) `(if (raw-mode-p state) (er soft 'break-on-error "It is illegal to call ~x0 while in raw-mode. Consider exiting ~ raw-mode and then trying again." 'break-on-error) ,(LET* ((ERROR1-TRACE-FORM '(ERROR1 :ENTRY (:FMT (MSG "[Breaking on error:]")) :EXIT (PROG2$ (MAYBE-PRINT-CALL-HISTORY STATE) (BREAK$)) :COMPILE NIL)) (ER-CMP-FN-TRACE-FORM '(ER-CMP-FN :ENTRY (PPROGN (IO? ERROR NIL STATE (CTX MSG) (ERROR-FMS NIL CTX NIL "~|[Breaking on cmp error:]~|~@0" (LIST (CONS #\0 MSG)) STATE)) (MV :ENTER-BREAK NIL STATE)) :EXIT (PROG2$ (MAYBE-PRINT-CALL-HISTORY STATE) (BREAK$)) :COMPILE NIL)) (ABORT!-TRACE-FORM `(ABORT! :ENTRY (PROGN$ (FMT-ABBREV "~%Breaking on abort to top level." NIL 0 *STANDARD-CO* STATE "~|~%") (MAYBE-PRINT-CALL-HISTORY STATE) (BREAK$)))) (THROW-RAW-EV-FNCALL-STRING "[Breaking on error (entry to ev-fncall-msg)]") (THROW-RAW-EV-FNCALL-TRACE-FORM `(THROW-RAW-EV-FNCALL :DEF (THROW-RAW-EV-FNCALL (VAL) (THROW 'RAW-EV-FNCALL VAL)) :MULTIPLICITY 1 :ENTRY (PROGN$ (FMT-ABBREV "~%ACL2 Error ~@0: ~@1" (LIST (CONS #\0 ,THROW-RAW-EV-FNCALL-STRING) (CONS #\1 (EV-FNCALL-MSG (CAR ARGLIST) (W STATE) (USER-STOBJ-ALIST STATE)))) 0 *STANDARD-CO* STATE "~|~%") (MAYBE-PRINT-CALL-HISTORY STATE) (BREAK$))))) `(LET ((ON ,ON)) (ER-PROGN (CASE ON (:ALL (TRACE! ,ERROR1-TRACE-FORM ,ER-CMP-FN-TRACE-FORM ,ABORT!-TRACE-FORM ,THROW-RAW-EV-FNCALL-TRACE-FORM)) ((T) (TRACE! ,ERROR1-TRACE-FORM ,ER-CMP-FN-TRACE-FORM ,ABORT!-TRACE-FORM (,@THROW-RAW-EV-FNCALL-TRACE-FORM :COND (NOT (F-GET-GLOBAL 'IN-PROVE-FLG STATE))))) ((NIL) (WITH-OUTPUT :OFF WARNING (UNTRACE$ ERROR1 ER-CMP-FN THROW-RAW-EV-FNCALL))) (OTHERWISE (ER SOFT 'BREAK-ON-ERROR "Illegal argument value for break-on-error: ~x0." ON))) (VALUE :INVISIBLE))))))
explore-giant-termmutual-recursion
(mutual-recursion (defun explore-giant-term (term raddr bq-lst i min max) (cond ((>= i max) (mv bq-lst i)) ((variablep term) (mv bq-lst i)) ((fquotep term) (let ((qi (cons-count-bounded-ac term 0 max))) (cond ((< qi min) (mv bq-lst (+ qi i))) (t (mv (cons (cons qi (cons (revappend raddr nil) term)) bq-lst) i))))) ((flambdap (ffn-symb term)) (mv-let (bq-lst1 i1) (explore-giant-term (lambda-body (ffn-symb term)) (cons 3 (cons 1 raddr)) bq-lst (+ 4 (len (lambda-formals (ffn-symb term))) i) min max) (explore-giant-term-lst (fargs term) 2 raddr bq-lst1 i1 min max))) (t (explore-giant-term-lst (fargs term) 2 raddr bq-lst (+ 1 i) min max)))) (defun explore-giant-term-lst (terms n raddr bq-lst i min max) (cond ((endp terms) (mv bq-lst i)) (t (mv-let (bq-lst1 i1) (explore-giant-term (car terms) (cons n raddr) bq-lst i min max) (explore-giant-term-lst (cdr terms) (+ 1 n) raddr bq-lst1 (+ 1 i1) min max))))))
tilde-*-big-constants-phrasefunction
(defun tilde-*-big-constants-phrase (bq-lst) (cond ((endp bq-lst) nil) (t (cons (msg "* ~X01~| accounts for at ~ least ~x2 conses:~|~ ~Y34" `(fetch-addr ',(CADR (CAR BQ-LST)) (@ giant-lambda-object)) nil (car (car bq-lst)) (cddr (car bq-lst)) (evisc-tuple 3 6 nil nil)) (tilde-*-big-constants-phrase (cdr bq-lst))))))
explain-giant-lambda-object-fnfunction
(defun explain-giant-lambda-object-fn (state) (er-let* ((quoted-lambda-obj (read-hons-copy-lambda-object-culprit state)) (lambda-obj (assign giant-lambda-object (unquote quoted-lambda-obj))) (body (value (lambda-object-body lambda-obj)))) (let* ((max (lambda-object-count-max-val)) (qmin (floor max 1000)) (qmax (floor max 2))) (mv-let (bq-lst i) (explore-giant-term body (if (lambda-object-dcl lambda-obj) '(4) '(3)) nil 0 qmin qmax) (let ((bq-lst (merge-sort-car-> bq-lst)) (chan (f-get-global 'standard-co state))) (pprogn (cond ((null lambda-obj) (fms "No giant lambda object has been encountered yet." nil chan state nil)) ((and (consp bq-lst) (null (cdr bq-lst)) (< i qmax)) (fms "The offending lambda object is~%~X01.~%You may retrieve this ~ object with (@ GIANT-LAMBDA-OBJECT).~%~%The reason it is so ~ big is probably due to the fact that at address ~X23 you'll ~ see the quoted constant ~X45, which contains at least ~x6 ~ conses. You can retrieve this constant with ~X73. ~ Alternatively, you can explore the giant lambda object with ~ walkabout (see :DOC walkabout). The walkabout command ~X83 ~ will take you from the top of the lambda object to the large ~ constant.~%~%See :DOC explain-giant-lambda-object for ~ suggestions." (list (cons #\0 lambda-obj) (cons #\1 (evisc-tuple 10 12 (trace-evisceration-alist state) nil)) (cons #\2 (cadr (car bq-lst))) (cons #\3 nil) (cons #\4 (cddr (car bq-lst))) (cons #\5 (evisc-tuple 3 6 nil nil)) (cons #\6 (car (car bq-lst))) (cons #\7 `(fetch-addr ',(CADR (CAR BQ-LST)) (@ giant-lambda-object))) (cons #\8 `(cmds ,@(CADR (CAR BQ-LST))))) chan state nil)) ((and (consp bq-lst) (< i qmax)) (fms "The offending lambda object is~%~X01.~%You may retrieve this ~ object with (@ GIANT-LAMBDA-OBJECT).~%~%This lambda object ~ contains ~x2 large constants (described below) and the body of ~ the lambda itself is small (no more than ~x3 conses not ~ counting the large constants detailed below).~%~%The large ~ constants are sketched below. The addresses, (i1 i2 ... in), ~ shown in the FETCH-ADDR forms are the locations of the ~ constants. Executing the FETCH-ADDR forms will retrieve the ~ indicated constant. Alternatively, if you use walkabout (see ~ :DOC walkabout) to explore the giant lambda object and you are ~ standing at the top of the object and wish to go to the ~ constant at address (i1 i2 ... in), use the walkabout command ~ (cmds i1 i2 ... in).~%~%~*4See :DOC ~ explain-giant-lambda-object for suggestions." (list (cons #\0 lambda-obj) (cons #\1 (evisc-tuple 10 12 (trace-evisceration-alist state) nil)) (cons #\2 (len bq-lst)) (cons #\3 i) (cons #\4 (list "" "~@*~%" "~@*~%" "~@*." (tilde-*-big-constants-phrase bq-lst)))) chan state nil)) ((and (null bq-lst) (>= i qmax)) (fms "The offending lambda object is~%~X01.~%You may retrieve this ~ object with (@ GIANT-LAMBDA-OBJECT).~%~%This lambda object ~ apparently contains no quoted constants with more than ~x2 ~ conses. We say ``apparently'' because we stopped looking when ~ the body's cons-count reached ~x3 conses. This lambda object ~ has a large body and quoted constants apparently don't ~ contribute.~%~%See :DOC explain-giant-lambda-object for ~ suggestions." (list (cons #\0 lambda-obj) (cons #\1 (evisc-tuple 10 12 (trace-evisceration-alist state) nil)) (cons #\2 qmin) (cons #\3 i)) chan state nil)) ((and (consp bq-lst) (>= i qmax)) (fms "The offending lambda object is~%~X01.~%You may retrieve this ~ object with (@ GIANT-LAMBDA-OBJECT).~%~%This lambda object ~ contains at least ~x2 large constant~#5~[~/s~] (described ~ below) and the body of the lambda itself is large too ~ (containing at least ~x3 conses not counting the large ~ constant~#5~[~/s~] detailed below). We stopped looking for ~ large constants when the body's cons-count reached ~x3.~%~%The ~ large constant~#5~[ is~/s are~] sketched below. The ~ address~#5~[~/es~], (i1 i2 ... in), shown in the FETCH-ADDR ~ form~#5~[ is~/s are~] the location~#5~[~/s~] of the ~ constant~#5~[~/s~]. Executing a FETCH-ADDR form will retrieve ~ the indicated constant. Alternatively, if you use walkabout ~ (see :DOC walkabout) to explore the giant lambda object and ~ you are standing at the top of the object and wish to go to ~ the constant at address (i1 i2 ... in), use the walkabout ~ command (cmds i1 i2 ... in).~%~%~*4See :DOC ~ explain-giant-lambda-object for suggestions." (list (cons #\0 lambda-obj) (cons #\1 (evisc-tuple 10 12 (trace-evisceration-alist state) nil)) (cons #\2 (len bq-lst)) (cons #\3 i) (cons #\4 (list "" "~@*~%" "~@*~%and~%" "~@*." (tilde-*-big-constants-phrase bq-lst))) (cons #\5 (if (cdr bq-lst) 1 0))) chan state nil)) (t (fms "The offending lambda object is~%~X01.~%You may retrieve this ~ object with (@ GIANT-LAMBDA-OBJECT).~%~%But the body of this ~ lambda object contains no more than ~x2 conses, so the ~ excessive size is due to the formals and declaration (if ~ any).~%~%See :DOC explain-giant-lambda-object for suggestions." (list (cons #\0 lambda-obj) (cons #\1 (evisc-tuple 10 12 (trace-evisceration-alist state) nil)) (cons #\2 i)) chan state nil))) (value nil)))))))
explain-giant-lambda-objectmacro
(defmacro explain-giant-lambda-object nil '(explain-giant-lambda-object-fn state))
defexec-extract-keyfunction
(defun defexec-extract-key (x keyword result result-p) (declare (xargs :guard (and (keywordp keyword) (keyword-value-listp x)))) (cond ((endp x) (mv nil result result-p)) (t (mv-let (erp result result-p) (defexec-extract-key (cddr x) keyword result result-p) (cond (erp (mv erp nil nil)) ((eq (car x) keyword) (cond (result-p (mv "more than one ~x0 has been specified" nil nil)) (t (mv nil (cadr x) t)))) (t (mv nil result result-p)))))))
parse-defexec-dcls-1function
(defun parse-defexec-dcls-1 (alist guard guard-p hints hints-p measure measure-p ruler-extenders ruler-extenders-p wfrel wfrel-p stobjs stobjs-p dfs dfs-p exec-xargs exec-test exec-default acc) (declare (xargs :guard (symbol-alistp alist))) (cond ((endp alist) (mv nil (cons 'declare (reverse acc)) guard guard-p hints hints-p measure measure-p ruler-extenders ruler-extenders-p wfrel wfrel-p stobjs stobjs-p dfs dfs-p exec-xargs exec-test exec-default)) (t (let* ((decl (car alist)) (sym (car decl)) (x (cdr decl))) (cond ((eq sym 'xargs) (cond ((keyword-value-listp x) (mv-let (erp guard guard-p) (defexec-extract-key x :guard guard guard-p) (cond (erp (mv erp nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) (t (mv-let (erp hints hints-p) (defexec-extract-key x :hints hints hints-p) (cond (erp (mv erp nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) (t (mv-let (erp measure measure-p) (defexec-extract-key x :measure measure measure-p) (cond (erp (mv erp nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) (t (mv-let (erp ruler-extenders ruler-extenders-p) (defexec-extract-key x :ruler-extenders ruler-extenders ruler-extenders-p) (cond (erp (mv erp nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) (t (mv-let (erp wfrel wfrel-p) (defexec-extract-key x :well-founded-relation wfrel wfrel-p) (cond (erp (mv erp nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) (t (mv-let (erp stobjs stobjs-p) (defexec-extract-key x :stobjs stobjs stobjs-p) (cond (erp (mv erp nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) (t (mv-let (erp dfs dfs-p) (defexec-extract-key x :dfs dfs dfs-p) (cond (erp (mv erp nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) (t (parse-defexec-dcls-1 (cdr alist) guard guard-p hints hints-p measure measure-p ruler-extenders ruler-extenders-p wfrel wfrel-p stobjs stobjs-p dfs dfs-p exec-xargs exec-test exec-default (cons decl acc)))))))))))))))))))))))) (t (mv "we found (XARGS . x) where x is not a keyword-value-listp" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)))) ((eq sym 'exec-xargs) (cond ((or exec-xargs exec-test exec-default) (mv "more than one EXEC-XARGS has been specified" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) ((and (keyword-value-listp x) x) (let* ((exec-test (cadr (assoc-keyword :test x))) (x (if exec-test (remove-keyword :test x) x)) (exec-default (cadr (assoc-keyword :default-value x))) (x (if exec-default (remove-keyword :default-value x) x))) (parse-defexec-dcls-1 (cdr alist) guard guard-p hints hints-p measure measure-p ruler-extenders ruler-extenders-p wfrel wfrel-p stobjs stobjs-p dfs dfs-p x exec-test exec-default acc))) (t (mv "we found declaration (EXEC-XARGS . x) where x is not a ~ non-empty keyword-value-listp" nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)))) (t (parse-defexec-dcls-1 (cdr alist) guard guard-p hints hints-p measure measure-p ruler-extenders ruler-extenders-p wfrel wfrel-p stobjs stobjs-p dfs dfs-p x exec-test exec-default (cons (car alist) acc))))))))
fix-exec-xargsfunction
(defun fix-exec-xargs (exec-xargs hints hints-p measure measure-p ruler-extenders ruler-extenders-p wfrel wfrel-p stobjs stobjs-p dfs dfs-p) (declare (xargs :guard (keyword-value-listp exec-xargs))) (let* ((x (if (and hints-p (not (assoc-keyword :hints exec-xargs))) (list* :hints hints exec-xargs) exec-xargs)) (x (if (and measure-p (not (assoc-keyword :measure exec-xargs))) (list* :measure measure x) x)) (x (if (and ruler-extenders-p (not (assoc-keyword :ruler-extenders exec-xargs))) (list* :ruler-extenders ruler-extenders x) x)) (x (if (and wfrel-p (not (assoc-keyword :well-founded-relation exec-xargs))) (list* :well-founded-relation wfrel x) x)) (x (if (and stobjs-p (not (assoc-keyword :stobjs exec-xargs))) (list* :stobjs stobjs x) x)) (x (if (and dfs-p (not (assoc-keyword :dfs exec-xargs))) (list* :dfs dfs x) x))) x))
parse-defexec-dclsfunction
(defun parse-defexec-dcls (dcls-and-strings final guard guard-p hints hints-p measure measure-p ruler-extenders ruler-extenders-p wfrel wfrel-p stobjs stobjs-p dfs dfs-p exec-xargs exec-test exec-default) (cond ((endp dcls-and-strings) (cond ((null guard-p) (mv "no :GUARD has been specified in the XARGS. The MBE proof ~ obligation is actually a guard condition -- we have to prove that ~ the guard ensures that the :LOGIC and :EXEC terms are equivalent ~ and that the guards are satisfied for the :EXEC term. Please ~ specify a :GUARD. Note also that you can delay the verification ~ of the MBE conditions by delaying guard verification, as with ~ :VERIFY-GUARDS NIL" nil nil nil nil nil)) (t (mv nil (reverse final) guard (fix-exec-xargs exec-xargs hints hints-p measure measure-p ruler-extenders ruler-extenders-p wfrel wfrel-p stobjs stobjs-p dfs dfs-p) (or exec-test guard) exec-default)))) (t (let ((x (car dcls-and-strings))) (cond ((stringp x) (parse-defexec-dcls (cdr dcls-and-strings) (cons x final) guard guard-p hints hints-p measure measure-p ruler-extenders ruler-extenders-p wfrel wfrel-p stobjs stobjs-p dfs dfs-p exec-xargs exec-test exec-default)) ((and (consp x) (eq (car x) 'declare) (symbol-alistp (cdr x))) (mv-let (erp decl guard guard-p hints hints-p measure measure-p ruler-extenders ruler-extenders-p wfrel wfrel-p stobjs stobjs-p dfs dfs-p exec-xargs exec-test exec-default) (parse-defexec-dcls-1 (cdr x) guard guard-p hints hints-p measure measure-p ruler-extenders ruler-extenders-p wfrel wfrel-p stobjs stobjs-p dfs dfs-p exec-xargs exec-test exec-default nil) (cond (erp (mv erp nil nil nil nil nil)) (t (parse-defexec-dcls (cdr dcls-and-strings) (cons decl final) guard guard-p hints hints-p measure measure-p ruler-extenders ruler-extenders-p wfrel wfrel-p stobjs stobjs-p dfs dfs-p exec-xargs exec-test exec-default))))) (t (mv (msg "the form ~x0 is neither a string nor a form (declare . x) ~ where x is a symbol-alistp" x) nil nil nil nil nil)))))))
defexecmacro
(defmacro defexec (&whole whole fn formals &rest rest) (let ((dcls-and-strings (butlast rest 1)) (body (car (last rest)))) (mv-let (erp exec-body) (case-match body (('mbe ':logic & ':exec exec-body) (mv nil exec-body)) (('mbe ':exec exec-body ':logic &) (mv nil exec-body)) (('mbe . &) (mv 'mbe nil)) (& (mv t nil))) (cond (erp `(er soft 'defexec "A defexec form must have a body that is a valid call of mbe. ~ See :DOC ~s0." ,(IF (EQ ERP 'MBE) "mbe" "defexec"))) ((not (symbolp fn)) `(er soft 'defexec "The first argument of defexec must be a symbol, but ~x0 is not." ',FN)) ((not (arglistp formals)) `(er soft 'defexec "The second argument of defexec must be legal list of formals, ~ but ~x0 is not." ',FORMALS)) (t (mv-let (erp final-dcls-and-strings guard exec-xargs exec-test exec-default) (parse-defexec-dcls dcls-and-strings nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil) (cond (erp `(er soft 'defexec "Macroexpansion of ~x0 has failed because ~@1." ',WHOLE ',ERP)) (t `(encapsulate nil (local (encapsulate nil (set-ignore-ok t) (set-irrelevant-formals-ok t) (local (defun ,FN ,FORMALS (declare (xargs :verify-guards nil ,@EXEC-XARGS)) (if ,EXEC-TEST ,EXEC-BODY ,EXEC-DEFAULT))) (local (defthm ,(PACKN (LIST FN '-GUARD-IMPLIES-TEST)) (implies ,GUARD ,EXEC-TEST) :rule-classes nil)))) (defun ,FN ,FORMALS ,@FINAL-DCLS-AND-STRINGS ,BODY))))))))))
other
(defrec sar ((lemma . alist) (index . equiv)) nil)
applicable-rewrite-rules1function
(defun applicable-rewrite-rules1 (term geneqv lemmas current-index target-name-or-rune target-index wrld) (declare (xargs :guard (or (null target-index) (integerp target-index)))) (cond ((consp lemmas) (let ((lemma (car lemmas))) (cond ((and (or (null target-name-or-rune) (if (symbolp target-name-or-rune) (equal target-name-or-rune (cadr (access rewrite-rule lemma :rune))) (equal target-name-or-rune (access rewrite-rule lemma :rune)))) (member (access rewrite-rule lemma :subclass) '(backchain abbreviation definition rewrite-quoted-constant)) (or (eq geneqv :none) (geneqv-refinementp (access rewrite-rule lemma :equiv) geneqv wrld))) (mv-let (flg alist) (one-way-unify (if (and (eq (access rewrite-rule lemma :subclass) 'rewrite-quoted-constant) (eql (car (access rewrite-rule lemma :heuristic-info)) 2)) (access rewrite-rule lemma :rhs) (access rewrite-rule lemma :lhs)) term) (cond (flg (if target-index (if (eql target-index current-index) (list (make sar :index current-index :lemma lemma :alist alist :equiv (access rewrite-rule lemma :equiv))) (applicable-rewrite-rules1 term geneqv (cdr lemmas) (1+ current-index) target-name-or-rune target-index wrld)) (cons (make sar :index (if target-name-or-rune nil current-index) :lemma lemma :alist alist :equiv (access rewrite-rule lemma :equiv)) (applicable-rewrite-rules1 term geneqv (cdr lemmas) (1+ current-index) target-name-or-rune target-index wrld)))) (t (applicable-rewrite-rules1 term geneqv (cdr lemmas) current-index target-name-or-rune target-index wrld))))) (t (applicable-rewrite-rules1 term geneqv (cdr lemmas) current-index target-name-or-rune target-index wrld))))) (t nil)))
applicable-linear-rules1function
(defun applicable-linear-rules1 (term lemmas current-index target-name-or-rune target-index) (declare (xargs :guard (or (null target-index) (integerp target-index)))) (cond ((consp lemmas) (let ((lemma (car lemmas))) (cond ((or (null target-name-or-rune) (if (symbolp target-name-or-rune) (equal target-name-or-rune (cadr (access linear-lemma lemma :rune))) (equal target-name-or-rune (access linear-lemma lemma :rune)))) (mv-let (flg alist) (one-way-unify (access linear-lemma lemma :max-term) term) (cond (flg (cond (target-index (cond ((eql target-index current-index) (list (make sar :index current-index :lemma lemma :alist alist))) (t (applicable-linear-rules1 term (cdr lemmas) (1+ current-index) target-name-or-rune target-index)))) (t (cons (make sar :index (if target-name-or-rune nil current-index) :lemma lemma :alist alist) (applicable-linear-rules1 term (cdr lemmas) (1+ current-index) target-name-or-rune target-index))))) (t (applicable-linear-rules1 term (cdr lemmas) current-index target-name-or-rune target-index))))) (t (applicable-linear-rules1 term (cdr lemmas) current-index target-name-or-rune target-index))))) (t nil)))
pc-relieve-hypfunction
(defun pc-relieve-hyp (rune hyp unify-subst type-alist wrld state ens ttree) (cond ((and (ffn-symb-p hyp 'synp) (member-eq (car rune) '(:rewrite :meta :definition :linear))) (mv-let (wonp failure-reason unify-subst ttree) (relieve-hyp-synp rune hyp unify-subst (rewrite-stack-limit wrld) type-alist wrld state nil nil nil nil (make-rcnst ens wrld state :force-info 'weak) nil ttree nil) (declare (ignore failure-reason)) (mv wonp unify-subst ttree))) (t (mv-let (forcep bind-flg) (binding-hyp-p hyp unify-subst wrld) (let ((hyp (if forcep (fargn hyp 1) hyp))) (cond (bind-flg (mv t (cons (cons (fargn hyp 1) (sublis-var unify-subst (fargn hyp 2))) unify-subst) ttree)) (t (mv-let (lookup-hyp-ans unify-subst ttree) (lookup-hyp hyp type-alist wrld unify-subst ttree ens) (cond (lookup-hyp-ans (mv t unify-subst ttree)) ((free-varsp hyp unify-subst) (search-ground-units hyp unify-subst type-alist ens (ok-to-force-ens ens) wrld ttree)) (t (let ((inst-hyp (sublis-var unify-subst hyp))) (mv-let (knownp nilp nilp-ttree) (known-whether-nil inst-hyp type-alist ens (ok-to-force-ens ens) nil wrld ttree) (cond (knownp (mv (not nilp) unify-subst nilp-ttree)) (t (mv-let (not-flg atm) (strip-not hyp) (cond (not-flg (if (equal atm *nil*) (mv t unify-subst ttree) (mv nil unify-subst ttree))) (t (if (if-tautologyp atm) (mv t unify-subst ttree) (mv nil unify-subst ttree)))))))))))))))))))
pc-relieve-hyps1-itermutual-recursion
(mutual-recursion (defun pc-relieve-hyps1-iter (rune hyps unify-subst-lst unify-subst unify-subst0 ttree0 type-alist keep-unify-subst wrld state ens ttree) (mv-let (relieve-hyps1-ans unify-subst1 ttree1) (pc-relieve-hyps1 rune hyps (extend-unify-subst (car unify-subst-lst) unify-subst) unify-subst0 ttree0 type-alist keep-unify-subst wrld state ens ttree) (cond ((or (endp (cdr unify-subst-lst)) relieve-hyps1-ans) (mv relieve-hyps1-ans unify-subst1 ttree1)) (t (pc-relieve-hyps1-iter rune hyps (cdr unify-subst-lst) unify-subst unify-subst0 ttree0 type-alist keep-unify-subst wrld state ens ttree))))) (defun pc-relieve-hyps1 (rune hyps unify-subst unify-subst0 ttree0 type-alist keep-unify-subst wrld state ens ttree) (cond ((null hyps) (mv (not (eq keep-unify-subst :failed)) unify-subst ttree)) (t (mv-let (relieve-hyp-ans new-unify-subst ttree) (pc-relieve-hyp rune (car hyps) unify-subst type-alist wrld state ens ttree) (cond ((eq relieve-hyp-ans :unify-subst-list) (pc-relieve-hyps1-iter rune (cdr hyps) new-unify-subst unify-subst unify-subst0 ttree0 type-alist keep-unify-subst wrld state ens ttree)) ((or relieve-hyp-ans keep-unify-subst) (pc-relieve-hyps1 rune (cdr hyps) new-unify-subst unify-subst0 ttree0 type-alist (if (and keep-unify-subst (not relieve-hyp-ans)) :failed keep-unify-subst) wrld state ens ttree)) (t (mv nil unify-subst0 ttree0))))))))
pc-relieve-hypsfunction
(defun pc-relieve-hyps (rune hyps unify-subst type-alist keep-unify-subst wrld state ens ttree) (pc-relieve-hyps1 rune hyps unify-subst unify-subst ttree type-alist (not (null keep-unify-subst)) wrld state ens ttree))
remove-trivial-litsfunction
(defun remove-trivial-lits (lst type-alist alist wrld ens ttree) (if (consp lst) (mv-let (rest-list ttree) (remove-trivial-lits (cdr lst) type-alist alist wrld ens ttree) (let ((new-lit (sublis-var alist (car lst)))) (if (free-varsp (car lst) alist) (mv (cons new-lit rest-list) ttree) (mv-let (knownp nilp nilp-ttree) (known-whether-nil new-lit type-alist ens (ok-to-force-ens ens) nil wrld ttree) (if (and knownp (not nilp)) (mv rest-list nilp-ttree) (mv (cons new-lit rest-list) ttree)))))) (mv nil ttree)))
unrelieved-hypsfunction
(defun unrelieved-hyps (rune hyps unify-subst type-alist keep-unify-subst wrld state ens ttree) (mv-let (success-flg new-unify-subst new-ttree) (pc-relieve-hyps rune hyps unify-subst type-alist keep-unify-subst wrld state ens ttree) (if success-flg (mv nil new-unify-subst new-ttree) (mv-let (unify-subst ttree) (if keep-unify-subst (mv new-unify-subst new-ttree) (mv unify-subst ttree)) (mv-let (lits ttree) (remove-trivial-lits hyps type-alist unify-subst wrld ens ttree) (mv lits unify-subst ttree))))))
untranslate-subst-abbfunction
(defun untranslate-subst-abb (sub abbreviations state) (declare (xargs :guard (symbol-alistp sub))) (if (consp sub) (cons (list (caar sub) (untrans0 (cdar sub) nil abbreviations)) (untranslate-subst-abb (cdr sub) abbreviations state)) nil))
show-rewrite-linearfunction
(defun show-rewrite-linear (caller index col rune nume show-more subst-hyps subst-hyps-2 unify-subst unify-subst-2 free free-2 rhs rewrite-quoted-constant-form-2p abbreviations term-id-iff ens enabled-only-flg equiv pl-p state) (let ((enabledp (enabled-numep nume ens)) (subst-rhs (sublis-var unify-subst rhs)) (term-id-iff (and (eq caller 'show-rewrites) term-id-iff))) (if (and enabled-only-flg (not enabledp)) state (pprogn (fms "~|~#a~[~/~c0. ~/ ~]~x1~#2~[~/ (disabled)~]" (list (cons #\a (if pl-p 0 (if index 1 2))) (cons #\0 (cons index col)) (cons #\1 (cond (pl-p rune) ((cddr rune) rune) (t (base-symbol rune)))) (cons #\2 (if enabledp 0 1))) (standard-co state) state nil) (let ((fmt-string "~@x~|~ ~ ~ ~#c~[New term~/Conclusion~]: ~Y3t~|~ ~ ~ Hypotheses: ~#b~[<none>~/~Y4t~]~|~ ~#c~[~ ~ Equiv: ~ye~|~/~]~ ~#s~[~/~ ~ Substitution: ~Yat~|~]~ ~#5~[~/~ ~ ~ ~@f variable: ~&6~/~ ~ ~ ~@f variables: ~&6~sn~]~ ~#7~[~/ WARNING: One of the hypotheses is (equivalent to) NIL, ~ and hence will apparently be impossible to relieve.~]~ ~#8~[~/ WARNING: The new term above is only used if it ~ rewrites to a quoted constant!~]~|")) (pprogn (fms fmt-string (list (cons #\x "") (cons #\c (if (eq caller 'show-rewrites) 0 1)) (cons #\3 (untrans0 subst-rhs term-id-iff abbreviations)) (cons #\s (if pl-p 1 0)) (cons #\a (untranslate-subst-abb unify-subst abbreviations state)) (cons #\b (if subst-hyps 1 0)) (cons #\e equiv) (cons #\4 (untrans0-lst subst-hyps t abbreviations)) (cons #\f (if pl-p "Free" "Remaining free")) (cons #\5 (zero-one-or-more (length free))) (cons #\6 free) (cons #\n "") (cons #\7 (if (member-equal *nil* subst-hyps) 1 0)) (cons #\t (term-evisc-tuple nil state)) (cons #\8 (if rewrite-quoted-constant-form-2p 1 0))) (standard-co state) state nil) (cond (show-more (pprogn (cond (pl-p state) (t (fms0 " -- IF ~#c~[REWRITE~/APPLY-LINEAR~] is called ~ with a third argument of t: --" (list (cons #\c (if (eq caller 'show-rewrites) 0 1)))))) (fms fmt-string (list (cons #\x (let ((extra (untranslate-subst-abb (alist-difference-eq unify-subst-2 unify-subst) abbreviations state))) (cond (extra (msg "~ ~ Additional bindings: ~X01" extra (term-evisc-tuple nil state))) (t "")))) (cons #\c (if (eq caller 'show-rewrites) 0 1)) (cons #\3 (untrans0 (sublis-var unify-subst-2 rhs) term-id-iff abbreviations)) (cons #\s (if pl-p 1 0)) (cons #\a (untranslate-subst-abb unify-subst-2 abbreviations state)) (cons #\b (if subst-hyps-2 1 0)) (cons #\e equiv) (cons #\4 (untrans0-lst subst-hyps-2 t abbreviations)) (cons #\f (if pl-p "Free" "Remaining free")) (cons #\5 (if (eql (length free-2) 1) 1 2)) (cons #\6 free-2) (cons #\n (if (null free-2) "[none]" "")) (cons #\7 (if (member-equal *nil* subst-hyps-2) 1 0)) (cons #\t (term-evisc-tuple nil state)) (cons #\8 (if rewrite-quoted-constant-form-2p 1 0))) (standard-co state) state nil))) (t state))))))))
show-rewrites-linearsfunction
(defun show-rewrites-linears (caller app-rules col abbreviations term-id-iff ens type-alist enabled-only-flg pl-p w state) (cond ((null app-rules) state) (t (pprogn (let* ((sar (car app-rules)) (lemma (access sar sar :lemma)) (alist (access sar sar :alist)) (index (access sar sar :index))) (mv-let (hyps result rune) (cond ((eq caller 'show-rewrites) (mv (access rewrite-rule lemma :hyps) (if (and (eq (access rewrite-rule lemma :subclass) 'rewrite-quoted-constant) (eql (car (access rewrite-rule lemma :heuristic-info)) 2)) (access rewrite-rule lemma :lhs) (access rewrite-rule lemma :rhs)) (access rewrite-rule lemma :rune))) (t (mv (access linear-lemma lemma :hyps) (access linear-lemma lemma :concl) (access linear-lemma lemma :rune)))) (mv-let (subst-hyps unify-subst ttree) (unrelieved-hyps rune hyps alist type-alist nil w state ens nil) (declare (ignore ttree)) (let* ((result-and-hyps-vars (union-eq (all-vars result) (all-vars1-lst hyps nil))) (free (reverse (set-difference-assoc-eq result-and-hyps-vars unify-subst))) (rewrite-quoted-constant-form-2p (and (eq caller 'show-rewrites) (eq (access rewrite-rule lemma :subclass) 'rewrite-quoted-constant) (eql (car (access rewrite-rule lemma :heuristic-info)) 2)))) (cond (pl-p (show-rewrite-linear caller index col rune (if (eq caller 'show-rewrites) (access rewrite-rule lemma :nume) (access linear-lemma lemma :nume)) nil subst-hyps nil unify-subst nil free nil result rewrite-quoted-constant-form-2p abbreviations term-id-iff ens enabled-only-flg (and (eq caller 'show-rewrites) (access sar sar :equiv)) t state)) (t (mv-let (show-more subst-hyps-2 unify-subst-2) (cond ((and free subst-hyps) (mv-let (subst-hyps-2 unify-subst-2 ttree) (unrelieved-hyps rune hyps alist type-alist t w state ens nil) (declare (ignore ttree)) (cond ((equal unify-subst-2 unify-subst) (assert$ (equal subst-hyps-2 subst-hyps) (mv nil subst-hyps unify-subst))) (t (mv t subst-hyps-2 unify-subst-2))))) (t (mv nil subst-hyps unify-subst))) (show-rewrite-linear caller index col rune (if (eq caller 'show-rewrites) (access rewrite-rule lemma :nume) (access linear-lemma lemma :nume)) show-more subst-hyps subst-hyps-2 unify-subst unify-subst-2 free (reverse (set-difference-assoc-eq result-and-hyps-vars unify-subst-2)) result rewrite-quoted-constant-form-2p abbreviations term-id-iff ens enabled-only-flg (and (eq caller 'show-rewrites) (access sar sar :equiv)) nil state)))))))) (show-rewrites-linears caller (cdr app-rules) col abbreviations term-id-iff ens type-alist enabled-only-flg pl-p w state)))))
expand-assumptions-1function
(defun expand-assumptions-1 (term) (case-match term (('if a b ''nil) (append (expand-assumptions-1 a) (expand-assumptions-1 b))) ((equality-p a b) (if (or (and (eq equality-p 'eq) (or (and (consp a) (eq (car a) 'quote) (symbolp (cadr a))) (and (consp b) (eq (car b) 'quote) (symbolp (cadr b))))) (and (eq equality-p 'eql) (or (and (consp a) (eq (car a) 'quote) (eqlablep (cadr a))) (and (consp b) (eq (car b) 'quote) (eqlablep (cadr b)))))) (list term (mcons-term* 'equal a b)) (list term))) (& (list term))))
expand-assumptionsfunction
(defun expand-assumptions (x) (declare (xargs :guard (true-listp x))) (if x (append (expand-assumptions-1 (car x)) (expand-assumptions (cdr x))) nil))
hyps-type-alistfunction
(defun hyps-type-alist (assumptions ens wrld state) (forward-chain-top 'show-rewrites (dumb-negate-lit-lst (expand-assumptions assumptions)) nil (ok-to-force-ens ens) nil wrld ens (match-free-override wrld) state))
show-rewrites-linears-fnfunction
(defun show-rewrites-linears-fn (caller rule-id enabled-only-flg ens current-term abbreviations term-id-iff all-hyps geneqv pl-p state) (let ((name (and (symbolp rule-id) rule-id)) (index (and (integerp rule-id) (< 0 rule-id) rule-id)) (rune (and (consp rule-id) (if pl-p (keywordp (car rule-id)) (member-eq (car rule-id) (cond ((eq caller 'show-rewrites) '(:rewrite :rewrite-quoted-constant :definition)) (t :linear)))) rule-id)) (w (w state))) (cond ((and (not pl-p) rule-id (not (or name index rune))) (fms "The rule-id argument to ~s0 must be a name, a positive integer, ~ or a rune representing a rewrite, rewrite-quoted-constant, or ~ definition rule, but ~x1 is none of these.~|" (list (cons #\0 (symbol-name caller)) (cons #\1 rule-id)) (standard-co state) state nil)) ((and (not pl-p) (or (variablep current-term) (and (fquotep current-term) (not (and (eq caller 'show-rewrites) rule-id (eq (car rule-id) :rewrite-quoted-constant)))) (flambdap (ffn-symb current-term)))) (fms "It is only possible to apply ~#0~[rewrite rules to terms that are ~ not variables or applications of lambda expressions~/linear rules ~ for triggers that are not variables, quoted constants, or ~ applications of lambda expressions~]. However, the current term ~ is:~%~ ~ ~y1.~|" (list (cons #\0 (if (eq caller 'show-rewrites) 0 1)) (cons #\1 current-term)) (standard-co state) state (term-evisc-tuple nil state))) ((and (not pl-p) (eq (ffn-symb current-term) 'if) (eq caller 'show-linears)) (fms "It is only possible to apply linear rules for triggers that are ~ applications of function symbols other than IF. However, the ~ current term is~|~ ~ ~y0.~|" (list (cons #\0 current-term)) (standard-co state) state (term-evisc-tuple nil state))) (t (mv-let (flg hyps-type-alist ttree) (hyps-type-alist all-hyps ens w state) (declare (ignore ttree)) (cond (flg (assert$ (not pl-p) (fms "*** Contradiction in the hypotheses! ***~%The S command ~ should complete this goal.~|" nil (standard-co state) state nil))) (t (let ((app-rules (cond ((eq caller 'show-rewrites) (applicable-rewrite-rules1 current-term geneqv (if (quotep current-term) (global-val 'rewrite-quoted-constant-rules w) (getpropc (ffn-symb current-term) 'lemmas nil w)) 1 (or name rune) index w)) (t (applicable-linear-rules1 current-term (getpropc (ffn-symb current-term) 'linear-lemmas nil w) 1 (or name rune) index))))) (cond ((null app-rules) (cond (pl-p state) ((and index (> index 1)) (fms "~|*** There are fewer than ~x0 applicable ~s1 ~ rules. ***~%" (list (cons #\0 index) (cons #\1 (if (eq caller 'show-rewrites) "rewrite" "linear"))) (standard-co state) state nil)) (t (fms "~|*** There are no applicable ~s0 rules. ***~%" (list (cons #\0 (if (eq caller 'show-rewrites) "rewrite" "linear"))) (standard-co state) state nil)))) (t (show-rewrites-linears caller app-rules (floor (length app-rules) 10) abbreviations term-id-iff ens hyps-type-alist enabled-only-flg pl-p w state)))))))))))
show-meta-lemmas1function
(defun show-meta-lemmas1 (lemmas rule-id term wrld ens state) (cond ((endp lemmas) state) (t (pprogn (let* ((lemma (car lemmas)) (rune (and (eq (access rewrite-rule lemma :subclass) 'meta) (access rewrite-rule lemma :rune)))) (cond ((and rune (or (null rule-id) (if (symbolp rule-id) (eq rule-id (base-symbol rune)) (equal rule-id rune)))) (let* ((fn (access rewrite-rule lemma :lhs)) (extendedp (access rewrite-rule lemma :rhs)) (args (meta-fn-args term extendedp ens state))) (mv-let (erp new-term latches) (ev-fncall-meta fn args state) (declare (ignore latches)) (cond ((or erp (equal new-term term) (not (termp new-term wrld))) state) (t (let ((hyp-fn (access rewrite-rule lemma :hyps))) (mv-let (erp hyp latches) (if hyp-fn (ev-fncall-meta hyp-fn (meta-fn-args term extendedp ens state) state) (mv nil *t* nil)) (declare (ignore latches)) (cond ((or erp (not (termp hyp wrld))) state) (t (fms "~Y01~|~ ~ ~ New term: ~Y2t~|~ ~ ~ Hypothesis: ~Y3t~|~ ~ ~ Equiv: ~y4~|" (list (cons #\0 rune) (cons #\1 nil) (cons #\2 new-term) (cons #\3 (untranslate hyp nil wrld)) (cons #\4 (access rewrite-rule lemma :equiv)) (cons #\t (term-evisc-tuple nil state))) (standard-co state) state nil)))))))))) (t state))) (show-meta-lemmas1 (cdr lemmas) rule-id term wrld ens state)))))
show-meta-lemmasfunction
(defun show-meta-lemmas (term rule-id ens state) (cond ((and (nvariablep term) (not (fquotep term)) (not (flambdap (ffn-symb term)))) (let ((wrld (w state))) (show-meta-lemmas1 (getpropc (ffn-symb term) 'lemmas nil wrld) rule-id term wrld ens state))) (t state)))
decoded-type-set-from-tp-rulefunction
(defun decoded-type-set-from-tp-rule (tp unify-subst wrld ens) (mv-let (ts type-alist ttree) (type-set-with-rule1 unify-subst (access type-prescription tp :vars) (ok-to-force-ens ens) nil nil nil ens wrld (access type-prescription tp :basic-ts) nil nil nil nil) (declare (ignore type-alist ttree)) (decode-type-set ts)))
show-type-prescription-rulefunction
(defun show-type-prescription-rule (rule unify-subst type-alist abbreviations wrld ens state) (let ((rune (access type-prescription rule :rune)) (nume (access type-prescription rule :nume)) (hyps (access type-prescription rule :hyps))) (pprogn (fms "~x1~#2~[~/ (disabled)~]" (list (cons #\1 rune) (cons #\2 (if (enabled-numep nume ens) 0 1))) (standard-co state) state nil) (let ((fmt-string "~ ~ Type: ~Y01~|~ ~ ~ Hypotheses: ~#b~[<none>~/~Y4t~]~|~ ~ ~ Substitution: ~Yat~|~ ~#5~[~/~ ~ ~ Remaining free variable: ~&6~/~ ~ ~ Remaining free variables: ~&6~sn~]~ ~#7~[~/ WARNING: One of the hypotheses is (equivalent to) NIL, ~ and hence will apparently be impossible to relieve.~]~|")) (mv-let (subst-hyps unify-subst ttree) (unrelieved-hyps rune hyps unify-subst type-alist nil wrld state ens nil) (declare (ignore ttree)) (let ((free (reverse (set-difference-assoc-eq (all-vars1-lst hyps nil) unify-subst)))) (fms fmt-string (list (cons #\a (untranslate-subst-abb unify-subst abbreviations state)) (cons #\b (if subst-hyps 1 0)) (cons #\0 (decoded-type-set-from-tp-rule rule unify-subst wrld ens)) (cons #\1 nil) (cons #\4 (untrans0-lst subst-hyps t abbreviations)) (cons #\5 (zero-one-or-more (length free))) (cons #\6 free) (cons #\n "") (cons #\7 (if (member-eq nil subst-hyps) 1 0)) (cons #\t (term-evisc-tuple nil state))) (standard-co state) state nil)))))))
show-type-prescription-rules1function
(defun show-type-prescription-rules1 (rules term rule-id type-alist abbreviations wrld ens state) (cond ((endp rules) state) (t (pprogn (mv-let (unify-ans unify-subst) (cond ((or (null rule-id) (let ((rune (access type-prescription (car rules) :rune))) (if (symbolp rule-id) (eq rule-id (base-symbol rune)) (equal rule-id rune)))) (one-way-unify (access type-prescription (car rules) :term) term)) (t (mv nil nil))) (cond (unify-ans (show-type-prescription-rule (car rules) unify-subst type-alist abbreviations wrld ens state)) (t state))) (show-type-prescription-rules1 (cdr rules) term rule-id type-alist abbreviations wrld ens state)))))
show-type-prescription-rulesfunction
(defun show-type-prescription-rules (term rule-id abbreviations all-hyps ens state) (cond ((and (nvariablep term) (not (fquotep term)) (not (flambdap (ffn-symb term)))) (let ((wrld (w state))) (mv-let (flg hyps-type-alist ttree) (hyps-type-alist all-hyps ens wrld state) (declare (ignore ttree)) (cond (flg (fms "*** Contradiction in the hypotheses! ***~%The S command ~ should complete this goal.~|" nil (standard-co state) state nil)) (t (show-type-prescription-rules1 (getpropc (ffn-symb term) 'type-prescriptions nil wrld) term rule-id hyps-type-alist abbreviations wrld ens state)))))) (t (fms "Type-prescription rules are associated with function symbols ~ (other than IF). The current term, ~x0, is therefore not ~ suitable for listing associated type-prescription rules.~|" (list (cons #\0 term)) (standard-co state) state nil))))
pl2-fnfunction
(defun pl2-fn (form rule-id caller state) (let ((ens (ens-maybe-brr state)) (wrld (w state))) (er-let* ((term (translate form t t nil caller wrld state))) (cond ((not (or (symbolp rule-id) (and (consp rule-id) (keywordp (car rule-id))))) (er soft caller "The rule-id supplied to ~x0 must be a symbol or a rune, but ~x1 ~ is neither. See :DOC ~x0." caller rule-id)) (t (mv-let (flg term1) (cond ((or (variablep term) (flambdap (ffn-symb term))) (mv t (remove-guard-holders term wrld))) (t (mv nil term))) (cond ((or (variablep term1) (flambdap (ffn-symb term1))) (er soft caller "~@0 must represent a term that is not a variable or a ~ LET (or LAMBDA application). But ~x1 does not meet ~ this requirement." (case caller (pl (msg "A non-symbol argument of ~x0" caller)) (pl2 (msg "The first argument of ~x0" caller)) (otherwise (er hard 'pl2-fn "Implementation error: Unexpected case! ~ ~ Please contact the ACL2 implementors."))) form)) (t (let ((term term1)) (pprogn (cond (flg (fms "+++++++++~%**NOTE**:~%Instead showing ~ rules for the following term, which is ~ much more likely to be encountered ~ during proofs:~|~% ~y0+++++++++~%" (list (cons #\0 (untranslate term1 nil wrld))) (standard-co state) state nil)) (t state)) (show-rewrites-linears-fn 'show-rewrites rule-id nil ens term nil nil nil :none t state) (show-meta-lemmas term rule-id ens state) (show-rewrites-linears-fn 'show-linears rule-id nil ens term nil nil nil :none t state) (show-type-prescription-rules term rule-id nil nil ens state) (value :invisible)))))))))))
pl-fnfunction
(defun pl-fn (name0 state) (cond ((symbolp name0) (let* ((wrld (w state)) (ens (ens-maybe-brr state)) (name (deref-macro-name name0 (macro-aliases wrld)))) (cond ((eq name 'quote) (print-info-for-rules (info-for-lemmas (global-val 'rewrite-quoted-constant-rules wrld) t ens wrld) (standard-co state) state)) ((function-symbolp name wrld) (print-info-for-rules (append (info-for-lemmas (getpropc name 'lemmas nil wrld) t ens wrld) (info-for-linear-lemmas (getpropc name 'linear-lemmas nil wrld) t ens wrld) (info-for-type-prescriptions (getpropc name 'type-prescriptions nil wrld) t ens wrld) (info-for-forward-chaining-rules (getpropc name 'forward-chaining-rules nil wrld) t ens wrld) (info-for-eliminate-destructors-rules (getpropc name 'eliminate-destructors-rules nil wrld) t ens wrld) (info-for-induction-rules (getpropc name 'induction-rules nil wrld) t ens wrld)) (standard-co state) state)) (t (er soft 'pl "If the argument to PL is a symbol, then it must be a function ~ symbol in the current world, the symbol QUOTE, or else a macro ~ that is associated with a function symbol (see :DOC ~ add-macro-alias).~@0" (cond ((getpropc name0 'macro-body) (msg " Since ~x0 is a macro without such association, ~ consider applying PL to a call (~x0 ...); see :DOC pl." name0)) (t ""))))))) (t (pl2-fn name0 nil 'pl state))))
acl2-defaults-table-local-ctx-pfunction
(defun acl2-defaults-table-local-ctx-p (state) (let ((wrld (w state))) (or (global-val 'include-book-path wrld) (f-get-global 'certify-book-info state) (in-encapsulatep (global-val 'embedded-event-lst wrld) nil))))
change-include-book-dirfunction
(defun change-include-book-dir (keyword dir0 caller state) (declare (xargs :guard (state-p state) :mode :program)) (let* ((ctx (if dir0 (cons caller keyword) (msg "~x0" (list caller keyword)))) (bang-p (member-eq caller '(add-include-book-dir! delete-include-book-dir!))) (dir (and dir0 (sysfile-to-filename dir0 state)))) (cond ((not (if dir (member-eq caller '(add-include-book-dir add-include-book-dir!)) (member-eq caller '(delete-include-book-dir delete-include-book-dir!)))) (cond ((and (null dir) (member-eq caller '(add-include-book-dir add-include-book-dir!))) (er soft ctx "It is illegal to call ~x0 with a directory argument of nil." caller)) (t (er soft ctx "Internal error: Illegal call of change-include-book-dir: ~ ~x0 is ~x1 but ~x2 is ~x3 (expected ~v4)." 'dir dir 'caller caller (if dir '(add-include-book-dir add-include-book-dir!) '(delete-include-book-dir delete-include-book-dir!)))))) ((not (keywordp keyword)) (er soft ctx "The first argument of ~x0 must be a keyword other than ~ :SYSTEM, but ~x1 is not." caller keyword)) ((and dir (not (stringp dir))) (er soft ctx "The second argument of ~x0 must be a string or ~ of the form (:keyword . string), but ~x1 is not." caller dir)) (t (let* ((dir (and dir (maybe-add-separator (extend-pathname (cbd) dir state)))) (wrld (w state)) (fname (project-dir-lookup keyword (project-dir-alist wrld) nil)) (raw-p (raw-include-book-dir-p state))) (cond ((and fname (not (equal fname dir))) (er soft ctx "Illegal call of ~x0: it associates ~x1 with ~x2, yet ~x1 ~ is already bound to a different value, ~x3, in the ~ project-dir-alist (see :DOC project-dir-alist)." caller keyword dir fname)) (t (state-global-let* ((inhibit-output-lst (cons 'summary (@ inhibit-output-lst))) (modifying-include-book-dir-alist t)) (mv-let (old alt) (cond (raw-p (cond (bang-p (mv (f-get-global 'raw-include-book-dir!-alist state) (f-get-global 'raw-include-book-dir-alist state))) (t (mv (f-get-global 'raw-include-book-dir-alist state) (f-get-global 'raw-include-book-dir!-alist state))))) (bang-p (mv (table-alist 'include-book-dir!-table wrld) (cdr (assoc-eq :include-book-dir-alist (table-alist 'acl2-defaults-table wrld))))) (t (mv (cdr (assoc-eq :include-book-dir-alist (table-alist 'acl2-defaults-table wrld))) (table-alist 'include-book-dir!-table wrld)))) (let ((old-pair (assoc-eq keyword old)) (alt-pair (assoc-eq keyword alt))) (cond ((and dir (not (absolute-pathname-string-p dir t (os wrld)))) (er soft ctx "The second argument of ~x0 must represent a ~ directory, in particular ending with character ~ '~s1', but ~x2 does not." caller *directory-separator-string* dir)) ((and dir (equal (cdr old-pair) dir)) (stop-redundant-event ctx state)) ((if dir (or old-pair alt-pair) alt-pair) (mv-let (other-add other-delete) (cond (bang-p (mv 'add-include-book-dir 'delete-include-book-dir)) (t (mv 'add-include-book-dir! 'delete-include-book-dir!))) (cond ((null dir) (er soft ctx "The keyword ~x0 was previously bound to ~ directory ~x1 by a call of ~x2. Perhaps ~ you intended to call ~x3 instead of ~x4." keyword (cdr alt-pair) other-add other-delete caller)) (alt-pair (er soft ctx "The keyword ~x0 was previously bound to ~ directory ~x1 by a call of ~x2. To bind ~ ~x0 with ~x3 first evaluate ~x4." keyword (cdr alt-pair) other-add caller (list other-delete keyword))) (t (er soft ctx "The keyword ~x0 was previously bound to ~ directory ~x1. If you intend to ~ override the old setting with directory ~ ~x2, first evaluate ~x3." keyword (cdr old-pair) dir (list (cond (bang-p 'delete-include-book-dir!) (t 'delete-include-book-dir)) keyword)))))) ((and (null dir) (null (cdr old-pair))) (stop-redundant-event ctx state)) (t (let ((new (cond (dir (acons keyword dir old)) (t (remove1-assoc-eq keyword old))))) (er-progn (cond (raw-p (pprogn (cond (bang-p (f-put-global 'raw-include-book-dir!-alist new state)) (t (f-put-global 'raw-include-book-dir-alist new state))) (value nil))) ((not bang-p) (table-fn 'acl2-defaults-table (list :include-book-dir-alist (kwote new)) state (list 'table 'acl2-defaults-table ':include-book-dir-alist (kwote new)))) (dir (table-fn 'include-book-dir!-table (list keyword (kwote dir)) state (list 'table 'include-book-dir!-table keyword (kwote dir)))) (t (table-fn 'include-book-dir!-table (list nil (kwote new) :clear) state (list 'table 'include-book-dir!-table nil (kwote new) :clear)))) (value new)))))))))))))))
add-custom-keyword-hint-fnfunction
(defun add-custom-keyword-hint-fn (key uterm1 uterm2 state) (declare (xargs :guard (state-p state) :mode :program)) (let ((world (w state)) (ctx 'add-custom-keyword-hint) (allowed-gvars '(val keyword-alist id clause world stable-under-simplificationp hist pspv ctx state)) (allowed-cvars '(val world ctx state))) (er-let* ((term1 (translate-simple-or-error-triple uterm1 ctx world state)) (term2 (translate uterm2 *error-triple-sig* nil '(state) ctx world state))) (cond ((not (keywordp key)) (er soft ctx "The first argument of add-custom-keyword-hint must be a keyword ~ and ~x0 is not!" key)) ((member-eq key *hint-keywords*) (er soft ctx "It is illegal to use the name of a primitive hint, ~e.g., ~x0, as ~ a custom keyword hint." key)) ((assoc-eq key (table-alist 'custom-keywords-table (w state))) (er soft ctx "It is illegal to use the name of an existing custom keyword hint, ~ e.g., ~x0. Use remove-custom-keyword-hint first to remove the ~ existing custom keyword hint of that name." key)) ((not (subsetp-eq (all-vars term1) allowed-gvars)) (er soft ctx "The second argument of add-custom-keyword-hint must be a term ~ whose free variables are among ~%~Y01, but you provided the term ~ ~x2, whose variables include~%~Y31." allowed-gvars nil uterm1 (reverse (set-difference-eq (all-vars term1) allowed-gvars)))) ((not (subsetp-eq (all-vars term2) allowed-cvars)) (er soft ctx "The :checker argument of add-custom-keyword-hint must be a term ~ whose free variables are among ~%~Y01, but you provided the term ~ ~x2, whose variables include~%~Y31." allowed-cvars nil uterm2 (reverse (set-difference-eq (all-vars term2) allowed-cvars)))) (t (state-global-let* ((inhibit-output-lst (cons 'summary (@ inhibit-output-lst)))) (let ((val (list uterm1 uterm2))) (er-progn (table-fn 'custom-keywords-table (list (kwote key) (kwote val)) state (list 'table 'custom-keywords-table (kwote key) (kwote val))) (table-fn 'custom-keywords-table 'nil state '(table custom-keywords-table))))))))))
reset-prehistorymacro
(defmacro reset-prehistory (&whole event-form &optional pflg) (declare (xargs :guard (member-eq pflg '(t nil)))) (list 'reset-prehistory-fn (list 'quote pflg) 'state (list 'quote event-form)))
disable-ubtmacro
(defmacro disable-ubt (&whole event-form &optional (arg ':disable-ubt)) (list 'reset-prehistory-fn (or arg :disable-ubt) 'state (list 'quote event-form)))
reset-kill-ringfunction
(defun reset-kill-ring (n state) (declare (xargs :guard (or (eq n t) (natp n)))) (let ((n (if (eq n t) (length (f-get-global 'undone-worlds-kill-ring state)) n))) (if n (pprogn (f-put-global 'undone-worlds-kill-ring (make-list n) state) (value :invisible)) (value (f-get-global 'undone-worlds-kill-ring state)))))
reset-prehistory-fnfunction
(defun reset-prehistory-fn (pflg state event-form) (with-ctx-summarized (if (and (consp event-form) (eq (car event-form) 'disable-ubt)) (if (cdr event-form) (msg "( DISABLE-UBT ...)") (msg "( DISABLE-UBT)")) (msg "( RESET-PREHISTORY ~x0 ...)" pflg)) (cond ((not (or (member-eq pflg '(t nil :disable-ubt)) (msgp pflg))) (er soft ctx "The optional argument of ~x0 must be the default, which is ~ ~x1, or an expression whose evaluation result satisfies ~x2 ~ (see :DOC msgp). But that argument has evaluated to ~x3." 'disable-ubt :disable-ubt 'msgp pflg)) ((and (not (eq pflg t)) (or (f-get-global 'certify-book-info state) (eq (f-get-global 'ld-skip-proofsp state) 'include-book) (f-get-global 'skip-reset-prehistory state))) (pprogn (observation ctx "~x0 events with pflg not equal to ~x1 ~ are skipped when ~@2. See :DOC ~ reset-prehistory." 'reset-prehistory t (cond ((f-get-global 'certify-book-info state) "certifying books") ((eq (f-get-global 'ld-skip-proofsp state) 'include-book) "including books or during the second pass ~ of an encapsulate") (t "state global 'skip-reset-prehistory has a ~ non-nil value"))) (value :skipped))) (t (let* ((wrld (w state)) (event-form (or event-form (list 'reset-prehistory pflg))) (next-absolute-command-number (next-absolute-command-number wrld)) (old-info (global-val 'command-number-baseline-info wrld)) (new-info (if (or (eq pflg :disable-ubt) (msgp pflg)) (change command-number-baseline-info old-info :permanent-p (cons next-absolute-command-number (if (eq pflg :disable-ubt) nil pflg))) (change command-number-baseline-info old-info :permanent-p pflg :current next-absolute-command-number)))) (er-let* ((val (install-event (if (or (eq pflg :disable-ubt) (msgp pflg)) :disable-ubt :new-prehistory-set) event-form 'reset-prehistory 0 nil nil nil ctx (global-set 'command-number-baseline-info new-info wrld) state))) (er-progn (reset-kill-ring t state) (value val))))))))
memoize-table-chk-commutative-msgfunction
(defun memoize-table-chk-commutative-msg (str fn val wrld) (declare (xargs :guard (and (symbolp fn) (not (eq (getpropc fn 'formals t wrld) t)) (symbol-alistp val)))) (let ((commutative (cdr (assoc-eq :commutative val)))) (cond ((null commutative) nil) ((not (eql (len (getpropc fn 'formals t wrld)) 2)) (msg "~@0~x1 is not a binary function symbol, so it is illegal to ~ specify a non-nil value of :commutative (here, ~x2) for ~ memoization of this function." str fn commutative)) ((not (symbolp commutative)) (msg "~@0Attempted to memoize ~x1 with a non-symbolp value of ~ :commutative, ~x2." str fn commutative)) (t (let ((thm (getpropc commutative 'theorem nil wrld))) (cond ((null thm) (msg "~@0The theorem ~x1 specified for :commutative ~ memoization of ~x2 does not exist." str commutative fn)) ((case-match thm (('equal (!fn x y) (!fn y x)) (cond ((and (variablep x) (variablep y) (not (eq x y))) t) (t nil))) (& nil)) nil) (t (msg "~@0The theorem ~x1 specified for :commutative ~ memoization of ~x2 does not have the expected ~ form. See :DOC memoize." str commutative fn))))))))
non-memoizable-stobjsfunction
(defun non-memoizable-stobjs (stobjs-in wrld) (cond ((endp stobjs-in) nil) ((getpropc (car stobjs-in) 'non-memoizable nil wrld) (cons (car stobjs-in) (non-memoizable-stobjs (cdr stobjs-in) wrld))) (t (non-memoizable-stobjs (cdr stobjs-in) wrld))))
filter-absstobjsfunction
(defun filter-absstobjs (lst wrld abs conc) (cond ((endp lst) (mv (reverse abs) (reverse conc))) ((getpropc (car lst) 'absstobj-info nil wrld) (filter-absstobjs (cdr lst) wrld (cons (car lst) abs) conc)) (t (filter-absstobjs (cdr lst) wrld abs (cons (car lst) conc)))))
remove-stobjs-in-by-positionfunction
(defun remove-stobjs-in-by-position (lst stobjs-in) (declare (xargs :guard (and (true-listp lst) (true-listp stobjs-in) (eql (length lst) (length stobjs-in))))) (cond ((endp lst) nil) ((car stobjs-in) (remove-stobjs-in-by-position (cdr lst) (cdr stobjs-in))) (t (cons (car lst) (remove-stobjs-in-by-position (cdr lst) (cdr stobjs-in))))))
add-suffix-to-fnfunction
(defun add-suffix-to-fn (sym suffix) (declare (xargs :guard (and (symbolp sym) (stringp suffix)))) (if (equal (symbol-package-name sym) *main-lisp-package-name*) (intern (concatenate 'string (symbol-name sym) suffix) "ACL2") (add-suffix sym suffix)))
fsubcor-varmutual-recursion
(mutual-recursion (defun fsubcor-var (vars terms form) (declare (xargs :guard (and (symbol-listp vars) (pseudo-term-listp terms) (equal (length vars) (length terms)) (pseudo-termp form)))) (cond ((variablep form) (subcor-var1 vars terms form)) ((fquotep form) form) (t (fcons-term (ffn-symb form) (fsubcor-var-lst vars terms (fargs form)))))) (defun fsubcor-var-lst (vars terms forms) (declare (xargs :guard (and (symbol-listp vars) (pseudo-term-listp terms) (equal (length vars) (length terms)) (pseudo-term-listp forms)))) (cond ((endp forms) nil) (t (cons (fsubcor-var vars terms (car forms)) (fsubcor-var-lst vars terms (cdr forms)))))))
print-gv-substitute-p1mutual-recursion
(mutual-recursion (defun print-gv-substitute-p1 (bound term alist acc) (cond ((variablep term) (let ((pair (assoc-eq term acc))) (cond ((null pair) (acons term nil acc)) ((null (cdr pair)) (if (eql (cons-count-bounded-ac (cdr (assoc-eq term alist)) 0 bound) bound) t (put-assoc-eq term t acc))) (t acc)))) ((fquotep term) acc) (t (print-gv-substitute-p1-lst bound (fargs term) alist acc)))) (defun print-gv-substitute-p1-lst (bound termlist alist acc) (cond ((endp termlist) acc) (t (let ((acc (print-gv-substitute-p1 bound (car termlist) alist acc))) (cond ((eq acc t) t) (t (print-gv-substitute-p1-lst bound (cdr termlist) alist acc))))))))
print-gv-substitute-pfunction
(defun print-gv-substitute-p (substitute tguard vars args) (cond ((natp substitute) (not (eq (print-gv-substitute-p1 substitute tguard (pairlis$ vars args) nil) t))) (t substitute)))
print-gv-formfunction
(defun print-gv-form (guard-fn guard tguard vars args ignorable substitute ctx state) (let ((wrld (w state))) (er-let* ((tguard (if (and substitute (null tguard)) (translate guard '(nil) nil t ctx wrld state) (value tguard)))) (cond ((print-gv-substitute-p substitute tguard vars args) (assert$ tguard (value (untranslate (fsubcor-var vars args tguard) t wrld)))) (t (let ((guard (if tguard (untranslate tguard t wrld) guard))) (value `(flet ((,GUARD-FN ,VARS ,@(AND IGNORABLE `((DECLARE (IGNORABLE ,@VARS)))) ,GUARD)) (,GUARD-FN ,@(UNTRANSLATE-LST ARGS NIL WRLD))))))))))
print-gv-conjunctfunction
(defun print-gv-conjunct (guard-fn formals conjuncts args index len-all-conjuncts fn substitute ctx state) (cond ((endp conjuncts) (er soft ctx "It is surprising that ~x0 yields no conjunct of the guard of ~x1 ~ that evaluates to ~x2. Sorry! Try ~x0 without the :conjunct ~ keyword argument." 'print-gv fn nil)) (t (let* ((conjunct (car conjuncts)) (alist (restrict-alist-to-all-vars (pairlis$ formals args) conjunct)) (f1 (strip-cars alist)) (a1 (strip-cdrs alist))) (er-let* ((form (print-gv-form guard-fn nil conjunct f1 a1 nil substitute ctx state))) (mv-let (erp stobjs-out/replaced-val state) (trans-eval-default-warning form ctx state t) (cond (erp (value (msg "Evaluation causes an error:~|~x0" conjunct))) ((cdr stobjs-out/replaced-val) (print-gv-conjunct guard-fn formals (cdr conjuncts) args (1+ index) len-all-conjuncts fn substitute ctx state)) (t (value (msg "Showing guard conjunct (#~x0 of ~x1) that ~ evaluates to nil:~|~%~x2." index len-all-conjuncts form))))))))))
print-gv1function
(defun print-gv1 (info conjunct substitute ctx state) (cond ((not (or (booleanp substitute) (natp substitute))) (er soft 'print-gv "The :substitute keyword argument of PRINT-GV must evaluate to T, ~ NIL, or a natural number." substitute)) (t (let* ((fn (nth 0 info)) (guard (nth 1 info)) (wrld (nth 4 info)) (guard-fn (add-suffix-to-fn fn "{GUARD}"))) (revert-world (pprogn (set-w! wrld state) (let ((formals (formals fn wrld)) (args (apply-user-stobj-alist-or-kwote (user-stobj-alist state) (nth 3 info) nil))) (if conjunct (let ((conjuncts (flatten-ands-in-lit (guard fn nil wrld)))) (print-gv-conjunct guard-fn formals conjuncts args 1 (length conjuncts) fn substitute ctx state)) (print-gv-form guard-fn guard nil formals args t substitute ctx state)))))))))
print-gv-fnfunction
(defun print-gv-fn (evisc-tuple conjunct substitute state) (prog2$ (wormhole 'ev-fncall-guard-er-wormhole '(lambda (whs) (set-wormhole-entry-code whs :enter)) nil `(er-progn (let ((info (wormhole-data (f-get-global 'wormhole-status state)))) (cond ((null info) (pprogn (fms "There is no guard violation to debug.~|~%" nil (standard-co state) state nil) (value nil))) (t (er-let* ((val (print-gv1 info ',CONJUNCT ',SUBSTITUTE 'print-gv state))) (pprogn (fms ,(IF CONJUNCT "~@0~|~%" "~x0~|~%") (list (cons #\0 val)) (standard-co state) state ',EVISC-TUPLE) (value nil)))))) (value :q)) :ld-prompt nil :ld-missing-input-ok nil :ld-always-skip-top-level-locals nil :ld-pre-eval-filter :all :ld-pre-eval-print nil :ld-post-eval-print :command-conventions :ld-evisc-tuple nil :ld-error-triples t :ld-error-action :error :ld-query-control-alist nil :ld-verbose nil) (value :invisible)))
set-print-gv-defaults-fnfunction
(defun set-print-gv-defaults-fn (state evisc-tuple evisc-tuple-p conjunct conjunct-p substitute substitute-p) (declare (xargs :guard t :mode :program)) (cond ((and (null evisc-tuple-p) (null conjunct-p) (null substitute-p)) (value (f-get-global 'print-gv-defaults state))) (t (let ((ctx 'set-print-gv-defaults)) (cond ((not (or (null evisc-tuple) (eq evisc-tuple :restore) (standard-evisc-tuplep evisc-tuple))) (er soft ctx "Illegal evisc-tuple: ~x0" evisc-tuple)) ((not (or (booleanp conjunct) (eq conjunct :restore))) (er soft ctx "Illegal value for :conjunct (must be Boolean): ~x0" conjunct)) ((not (or (booleanp substitute) (natp substitute) (eq substitute :restore))) (er soft ctx "Illegal value for :conjunct (must be Boolean or a natural ~ number): ~x0" substitute)) (t (let* ((alist (f-get-global 'print-gv-defaults state)) (alist (cond ((not evisc-tuple-p) alist) ((eq evisc-tuple :restore) (remove1-assoc-eq :evisc-tuple alist)) (t (put-assoc-eq :evisc-tuple evisc-tuple alist)))) (alist (cond ((not conjunct-p) alist) ((eq conjunct :restore) (remove1-assoc-eq :conjunct alist)) (t (put-assoc-eq :conjunct conjunct alist)))) (alist (cond ((not substitute-p) alist) ((eq substitute :restore) (remove1-assoc-eq :substitute alist)) (t (put-assoc-eq :substitute substitute alist))))) (pprogn (f-put-global 'print-gv-defaults alist state) (value alist)))))))))
set-print-gv-defaultsmacro
(defmacro set-print-gv-defaults (&key (evisc-tuple 'nil evisc-tuple-p) (conjunct 'nil conjunct-p) (substitute 'nil substitute-p)) `(set-print-gv-defaults-fn state ,EVISC-TUPLE ,EVISC-TUPLE-P ,CONJUNCT ,CONJUNCT-P ,SUBSTITUTE ,SUBSTITUTE-P))
print-gv-evisc-tuplemacro
(defmacro print-gv-evisc-tuple nil '(evisc-tuple nil nil (world-evisceration-alist state nil) nil))
print-gv-defaultmacro
(defmacro print-gv-default (key) (declare (xargs :guard (member-eq key '(:evisc-tuple :conjunct :substitute)))) (let* ((name (symbol-name key)) (key-p (intern (concatenate 'string name "-P") "ACL2")) (default (if (eq key :evisc-tuple) '(print-gv-evisc-tuple) nil))) `(cond (,KEY-P ,(INTERN NAME "ACL2")) (t '(let ((pair (assoc-eq ,KEY (f-get-global 'print-gv-defaults state)))) (if pair (cdr pair) ,DEFAULT))))))
print-gvmacro
(defmacro print-gv (&key (evisc-tuple 'nil evisc-tuple-p) (conjunct 'nil conjunct-p) (substitute 'nil substitute-p)) `(print-gv-fn ,(PRINT-GV-DEFAULT :EVISC-TUPLE) ,(PRINT-GV-DEFAULT :CONJUNCT) ,(PRINT-GV-DEFAULT :SUBSTITUTE) state))
disable-iprint-arfunction
(defun disable-iprint-ar (state) (cond ((iprint-enabledp state) (let* ((iprint-ar (f-get-global 'iprint-ar state)) (last-index (aref1 'iprint-ar iprint-ar 0))) (pprogn (f-put-global 'iprint-ar (compress1 'iprint-ar (acons 0 (list last-index) (if (eql (caar iprint-ar) 0) (cdr iprint-ar) iprint-ar))) state) (mv t state)))) (t (mv nil state))))
enable-iprint-arfunction
(defun enable-iprint-ar (state) (cond ((not (iprint-enabledp state)) (let* ((iprint-ar (f-get-global 'iprint-ar state)) (last-index (car (aref1 'iprint-ar iprint-ar 0)))) (pprogn (f-put-global 'iprint-ar (compress1 'iprint-ar (acons 0 last-index (if (eql (caar iprint-ar) 0) (cdr iprint-ar) iprint-ar))) state) (mv t state)))) (t (mv nil state))))
*iprint-actions*constant
(defconst *iprint-actions* '(t nil :reset :reset-enable :same))
set-iprint-fn1function
(defun set-iprint-fn1 (x state) (cond ((eq x :same) (mv nil state)) ((null x) (mv-let (result state) (disable-iprint-ar state) (cond (result (mv "Iprinting has been disabled." state)) (t (mv "Iprinting remains disabled." state))))) ((eq x t) (mv-let (result state) (enable-iprint-ar state) (cond (result (mv "Iprinting has been enabled." state)) (t (mv "Iprinting remains enabled." state))))) ((member-eq x '(:reset :reset-enable)) (pprogn (f-put-global 'iprint-ar (compress1 'iprint-ar (init-iprint-ar (f-get-global 'iprint-hard-bound state) (eq x :reset-enable))) state) (mv (cond ((eq x :reset-enable) "Iprinting has been reset and enabled.") (t "Iprinting has been reset and disabled.")) state))) (t (mv (er hard 'set-iprint-fn1 "Implementation error! Please contact the ACL2 implementors.") state))))
init-iprint-fal+function
(defun init-iprint-fal+ (sym ctx state) (mv-let (msg state) (init-iprint-fal sym state) (cond (msg (observation ctx "~@0" msg)) (t state))))
set-iprint-fnfunction
(defun set-iprint-fn (action0 share share-p soft-bound soft-bound-p hard-bound hard-bound-p ctx state) (cond ((not (member-eq action0 *iprint-actions*)) (er soft ctx "Unknown option, ~x0. The legal iprint actions are ~&1." action0 *iprint-actions*)) (t (let ((action (cond ((or share-p hard-bound-p) (case action0 ((t) :reset-enable) ((nil) :reset) ((:same) (if (iprint-enabledp state) :reset-enable :reset)) (otherwise (assert$ (member-eq action0 '(:reset :reset-enable)) action0)))) (t action0)))) (cond ((not (symbolp share)) (er soft ctx "The :share argument for iprinting must be a symbol, but ~x0 is not." share)) ((and soft-bound-p (not (posp soft-bound))) (er soft ctx "The :SOFT-BOUND argument of SET-IPRINT must be a positive ~ integer, but ~x0 is not." soft-bound)) ((and hard-bound-p (not (posp hard-bound))) (er soft ctx "The :HARD-BOUND argument of SET-IPRINT must be a positive ~ integer, but ~x0 is not." hard-bound)) (t (pprogn (cond ((not (eq action action0)) (warning$ 'set-iprint "Iprint" "Converting SET-IPRINT action from ~x0 to ~ ~x1, as required by use of keyword :SHARE ~ or :HARD-BOUND. See :DOC set-iprint." action0 action)) (t state)) (pprogn (cond (soft-bound-p (pprogn (f-put-global 'iprint-soft-bound soft-bound state) (observation ctx "The soft-bound for ~ iprinting has been set to ~ ~x0." soft-bound))) (t state)) (cond (hard-bound-p (pprogn (f-put-global 'iprint-hard-bound hard-bound state) (observation ctx "The hard-bound for ~ iprinting has been set to ~ ~x0." hard-bound))) (t state)) (cond ((eq share :same) (if (member-eq action '(:reset :reset-enable)) (init-iprint-fal+ :same ctx state) state)) ((eq share nil) (init-iprint-fal+ share ctx state)) (t (init-iprint-fal+ share ctx state))) (mv-let (msg state) (set-iprint-fn1 action state) (pprogn (cond (msg (observation ctx "~@0" msg)) (t state)) (value :invisible)))))))))))
set-iprintmacro
(defmacro set-iprint (&optional (action ':reset action-p) &key (share ':same share-p) (soft-bound '1 soft-bound-p) (hard-bound '1 hard-bound-p)) (declare (xargs :guard t)) `(mv-let (action action-p share share-p soft-bound soft-bound-p hard-bound hard-bound-p) (mv ,ACTION ,ACTION-P ,SHARE ,SHARE-P ,SOFT-BOUND ,SOFT-BOUND-P ,HARD-BOUND ,HARD-BOUND-P) (er-let* ((action (if action-p (value action) (acl2-query :set-iprint '("Action" :t t :nil nil :reset :reset :reset-enable :reset-enable :same :same :q :q :? ("reply with :Q to quit, or else with one of the ~ options to set-iprint, which are ~&0 (see :DOC ~ set-iprint)" :t t :nil nil :reset :reset :reset-enable :reset-enable :same :same :q :q)) (list (cons #\0 *iprint-actions*)) state)))) (cond ((eq action :q) (silent-error state)) (t (set-iprint-fn action share share-p soft-bound soft-bound-p hard-bound hard-bound-p 'set-iprint state))))))
*evisc-tuple-sites*constant
(defconst *evisc-tuple-sites* '(:term :ld :trace :abbrev :gag-mode :brr))
set-brr-evisc-tuple1function
(defun set-brr-evisc-tuple1 (val state) (f-put-global 'brr-evisc-tuple val state))
set-site-evisc-tuplefunction
(defun set-site-evisc-tuple (site evisc-tuple ctx state) (declare (xargs :guard (and (member-eq site *evisc-tuple-sites*) (or (null evisc-tuple) (eq evisc-tuple :default) (and (eq site :gag-mode) (eq evisc-tuple t)) (standard-evisc-tuplep evisc-tuple)) (state-p state)))) (case site (:term (f-put-global 'term-evisc-tuple evisc-tuple state)) (:abbrev (f-put-global 'abbrev-evisc-tuple evisc-tuple state)) (:gag-mode (f-put-global 'gag-mode-evisc-tuple evisc-tuple state)) (:ld (f-put-global 'ld-evisc-tuple (if (eq evisc-tuple :default) nil evisc-tuple) state)) (:trace (set-trace-evisc-tuple (if (eq evisc-tuple :default) nil evisc-tuple) state)) (:brr (set-brr-evisc-tuple1 evisc-tuple state)) (otherwise (prog2$ (er hard ctx "Implementation Error: Unrecognized keyword, ~x0. ~ Expected evisc-tuple site: ~v1" site *evisc-tuple-sites*) state))))
chk-evisc-tuplefunction
(defun chk-evisc-tuple (evisc-tuple ctx state) (cond ((or (null evisc-tuple) (eq evisc-tuple :default) (standard-evisc-tuplep evisc-tuple)) (value nil)) (t (er soft ctx "Illegal evisc-tuple argument, ~x0. See :DOC set-evisc-tuple." evisc-tuple))))
set-evisc-tuple-lstfunction
(defun set-evisc-tuple-lst (keys evisc-tuple acc ctx state) (cond ((endp keys) (value (reverse acc))) (t (pprogn (set-site-evisc-tuple (car keys) evisc-tuple ctx state) (set-evisc-tuple-lst (cdr keys) evisc-tuple (cons (car keys) acc) ctx state)))))
set-evisc-tuple-fn1function
(defun set-evisc-tuple-fn1 (keys all-keys evisc-tuple acc ctx state) (declare (xargs :guard (and (symbol-listp keys) (symbol-listp all-keys) (standard-evisc-tuplep evisc-tuple) (symbol-listp acc) (state-p state)))) (cond ((endp keys) (let ((lst (reverse acc))) (set-evisc-tuple-lst lst evisc-tuple nil ctx state))) (t (er-let* ((ans (acl2-query :set-evisc-tuple '("Do you wish to set ~s0?" :y t :n nil :all :all :rest :rest :q :q :abort :abort :? ("reply with REST to set ~s0 and all remaining ~ evisc-tuples, ALL to set all evisc-tuples, Q to set only ~ the evisc-tuples already specified, or ABORT to quit ~ without setting any evisc-tuples at all; or reply with Y ~ or N to set or not to set (respectively) ~s0 before ~ considering whether to set other evisc-tuples" :y t :n nil :all :all :rest :rest :q :q :abort :abort)) (list (cons #\0 (string-append (symbol-name (car keys)) "-EVISC-TUPLE"))) state))) (case ans ((:rest :all :q) (let ((lst (case ans (:rest keys) (:all all-keys) (:q (reverse acc))))) (set-evisc-tuple-lst lst evisc-tuple nil ctx state))) (:abort (value nil)) (otherwise (set-evisc-tuple-fn1 (cdr keys) all-keys evisc-tuple (if ans (cons (car keys) acc) acc) ctx state)))))))
iprint-virginpfunction
(defun iprint-virginp (state) (and (not (iprint-enabledp state)) (let* ((iprint-ar (f-get-global 'iprint-ar state)) (bound (default 'iprint-ar iprint-ar))) (and (null bound) (int= 0 (iprint-last-index* iprint-ar))))))
set-evisc-tuple-fnfunction
(defun set-evisc-tuple-fn (evisc-tuple iprint iprint-p sites sites-p state) (let ((ctx 'set-evisc-tuple) (fail-string "The legal values for :SITES are :ALL and either members ~ or subsets of the list ~x0. The :SITES ~x1 is thus ~ illegal. See :DOC set-evisc-tuple.")) (cond ((eq evisc-tuple t) (cond ((null sites) (er soft ctx "The :SITES argument is required for set-evisc-tuple when a ~ value of T is specified, in which case :SITES should ~ specify :TRACE and/or :GAG-MODE.~ ~ See :DOC ~ set-evisc-tuple.")) ((not (or (and (true-listp sites) (subsetp-eq sites *evisc-tuple-sites*)) (member-eq sites *evisc-tuple-sites*))) (er soft ctx fail-string *evisc-tuple-sites* sites)) (t (let ((sites (if (symbolp sites) (list sites) sites))) (cond ((not (subsetp-eq sites '(:trace :gag-mode))) (er soft ctx "You have called set-evisc-tuple with an ~ `evisc-tuple' of T. The only :SITES for which ~ this is legal are :TRACE and :GAG-MODE, but you ~ have supplied ~&0." sites)) (t (pprogn (cond ((member-eq :trace sites) (set-trace-evisc-tuple t state)) (t state)) (cond ((member-eq :gag-mode sites) (f-put-global 'gag-mode-evisc-tuple t state)) (t state)) (value sites)))))))) (t (er-progn (chk-evisc-tuple evisc-tuple ctx state) (cond (iprint-p (set-iprint-fn iprint :same nil nil nil nil nil ctx state)) ((not (iprint-virginp state)) (value nil)) (t (set-iprint))) (cond ((null sites-p) (set-evisc-tuple-fn1 *evisc-tuple-sites* *evisc-tuple-sites* evisc-tuple nil ctx state)) ((eq sites :all) (set-evisc-tuple-lst *evisc-tuple-sites* evisc-tuple nil ctx state)) ((and (true-listp sites) (subsetp-eq sites *evisc-tuple-sites*)) (set-evisc-tuple-lst sites evisc-tuple nil ctx state)) ((member-eq sites *evisc-tuple-sites*) (set-evisc-tuple-lst (list sites) evisc-tuple nil ctx state)) (t (er soft ctx fail-string *evisc-tuple-sites* sites))))))))
set-evisc-tuplemacro
(defmacro set-evisc-tuple (evisc-tuple &key (iprint 'nil iprint-p) (sites 'nil sites-p)) `(set-evisc-tuple-fn ,EVISC-TUPLE ,IPRINT ,IPRINT-P ,SITES ,SITES-P state))
top-levelmacro
(defmacro top-level (form &rest declares) `(mv-let (erp val state) (ld '((pprogn (f-put-global 'top-level-errorp nil state) (value :invisible)) (with-output :off :all :on error (defun top-level-fn (state) (declare (xargs :mode :program :stobjs state) (ignorable state)) ,@DECLARES ,FORM)) (ld '((pprogn (f-put-global 'top-level-errorp t state) (value :invisible)) (top-level-fn state) (pprogn (f-put-global 'top-level-errorp nil state) (value :invisible))) :ld-post-eval-print :command-conventions :ld-error-action :return :ld-error-triples t :ld-user-stobjs-modified-warning :same) (with-output :off :all :on error (ubt! 'top-level-fn))) :ld-pre-eval-print nil :ld-post-eval-print nil :ld-error-action :error :ld-error-triples t :ld-verbose nil :ld-prompt nil :ld-user-stobjs-modified-warning :same) (declare (ignore erp val)) (mv (@ top-level-errorp) :invisible state)))
necc-name-args-instancefunction
(defun necc-name-args-instance (ilks) (declare (xargs :guard (true-listp ilks) :mode :logic)) (cond ((endp ilks) nil) ((eq (car ilks) :fn) (cons 'equal (necc-name-args-instance (cdr ilks)))) ((eq (car ilks) :expr) (cons t (necc-name-args-instance (cdr ilks)))) (t (cons nil (necc-name-args-instance (cdr ilks))))))
defwarrant-eventsfunction
(defun defwarrant-events (fn formals bdg) (declare (xargs :mode :program)) (let* ((name (warrant-name fn)) (rule-name (apply$-rule-name fn)) (necc-name (intern-in-package-of-symbol (coerce (append (coerce (symbol-name name) 'list) '(#\- #\N #\E #\C #\C)) 'string) fn))) (cond ((eq (access apply$-badge bdg :ilks) t) `(,(MAKE-APPLY$-WARRANT-DEFUN-SK FN FORMALS BDG NIL) (in-theory (disable ,(DEFINITION-RULE-NAME NAME))) (defthm ,RULE-NAME (implies (force (,(WARRANT-NAME FN))) (and (equal (badge ',FN) ',BDG) (equal (apply$ ',FN args) ,(IF (EQL (ACCESS APPLY$-BADGE BDG :OUT-ARITY) 1) `(,FN ,@(SUCCESSIVE-CADRS FORMALS 'ARGS)) `(MV-LIST ',(ACCESS APPLY$-BADGE BDG :OUT-ARITY) (,FN ,@(SUCCESSIVE-CADRS FORMALS 'ARGS))))))) :hints (("Goal" :use ,NECC-NAME :expand ((:free (x) (hide (badge x)))) :in-theory (e/d (badge apply$) (,NECC-NAME ,FN))))))) (t (let* ((hyp-list (tameness-conditions (access apply$-badge bdg :ilks) 'args)) (hyp (if (null (cdr hyp-list)) (car hyp-list) `(and ,@HYP-LIST)))) `(,(MAKE-APPLY$-WARRANT-DEFUN-SK FN FORMALS BDG NIL) (in-theory (disable ,(DEFINITION-RULE-NAME NAME))) (defthm ,RULE-NAME (and (implies (force (,(WARRANT-NAME FN))) (equal (badge ',FN) ',BDG)) (implies (and (force (,(WARRANT-NAME FN))) ,HYP) (equal (apply$ ',FN args) ,(IF (EQL (ACCESS APPLY$-BADGE BDG :OUT-ARITY) 1) `(,FN ,@(SUCCESSIVE-CADRS FORMALS 'ARGS)) `(MV-LIST ',(ACCESS APPLY$-BADGE BDG :OUT-ARITY) (,FN ,@(SUCCESSIVE-CADRS FORMALS 'ARGS))))))) :hints (("Goal" :use ((:instance ,NECC-NAME (args ',(NECC-NAME-ARGS-INSTANCE (ACCESS APPLY$-BADGE BDG :ILKS)))) (:instance ,NECC-NAME)) :expand ((:free (x) (hide (badge x)))) :in-theory (e/d (badge apply$) (,NECC-NAME)))))))))))
translate-defattach-helpersfunction
(defun translate-defattach-helpers (kwd-value-lst name-tree ctx wrld state) (cond ((endp kwd-value-lst) (value nil)) (t (let ((key (car kwd-value-lst)) (val (cadr kwd-value-lst))) (er-let* ((rest (translate-defattach-helpers (cddr kwd-value-lst) name-tree ctx wrld state)) (tval (cond ((assoc-eq key rest) (er soft ctx "The key ~x0 occurs more than once in the same context ~ for a defattach event." key)) ((or (and (member-eq key '(:otf-flg :hints)) (assoc-eq :instructions rest)) (and (eq key :instructions) (or (assoc-eq :otf-flg rest) (assoc-eq :hints rest)))) (er soft ctx "The combination of :INSTRUCTIONS and either :HINTS or ~ :OTF-FLG is illegal for the same context in a defattach ~ event.")) (t (case key (:hints (translate-hints+ name-tree val (default-hints wrld) ctx wrld state)) (:instructions (translate-instructions val ctx state)) (:otf-flg (value val)) (:attach (cond ((member-eq val '(t nil)) (value val)) (t (er soft ctx "The only legal values for keyword :ATTACH in ~ a defattach event are ~&0. The value ~x1 is ~ thus illegal." '(t nil) val)))) (otherwise (value (er hard ctx "Implementation error: Should already have ~ checked keys in process-defattach-args1.")))))))) (value (cons (cons key tval) rest)))))))
*defattach-keys*constant
(defconst *defattach-keys* '(:hints :instructions :otf-flg :attach))
defattach-unknown-constraints-errorfunction
(defun defattach-unknown-constraints-error (name ctx state) (er soft ctx "Attachment is disallowed in this context, because the function ~x0 has ~ unknown-constraints. See :DOC partial-encapsulate." name))
intersection-domainsfunction
(defun intersection-domains (a1 a2) (declare (xargs :guard (and (symbol-alistp a1) (symbol-alistp a2)))) (if (consp a1) (if (assoc-eq (caar a1) a2) (cons (caar a1) (intersection-domains (cdr a1) a2)) (intersection-domains (cdr a1) a2)) nil))
process-defattach-args1function
(defun process-defattach-args1 (args ctx wrld state erasures explicit-erasures attachment-alist helper-alist-lst skip-checks system-ok) (cond ((endp args) (value (list erasures explicit-erasures attachment-alist helper-alist-lst))) (t (let ((arg (car args)) (see-doc " See :DOC defattach.") (ld-skip-proofsp (ld-skip-proofsp state)) (skip-checks-t (eq skip-checks t)) (unless-ttag (msg " (unless :SKIP-CHECKS T is specified with an active trust ~ tag)")) (not-boot-strap-p (not (f-get-global 'boot-strap-flg state)))) (case-match arg ((f g . kwd-value-lst) (er-let* ((helper-alist (cond ((or (eq ld-skip-proofsp 'include-book) (eq ld-skip-proofsp 'include-book-with-locals) (eq ld-skip-proofsp 'initialize-acl2)) (value nil)) ((or (not (keyword-value-listp kwd-value-lst)) (strip-keyword-list *defattach-keys* kwd-value-lst)) (er soft ctx "Each specified attachment must be of the form (F ~ G . LST), where LST is an alternating list of ~ keywords and values (see :DOC ~ keyword-value-listp) whose keys are without ~ duplicates, such that each key is ~v1. The LST ~ specified for the attachment to ~x0 is not of ~ this form.~@2" f *defattach-keys* see-doc)) (t (translate-defattach-helpers kwd-value-lst (cons "DEFATTACH guard obligation for attaching to" f) ctx wrld state))))) (cond ((not (function-symbolp f wrld)) (er soft ctx "Attachment is only legal for function symbols, but ~x0 ~ is not a known function symbol.~@1~@2" f see-doc (let ((f1 (deref-macro-name f (macro-aliases wrld)))) (cond ((not (eq f1 f)) (msg " NOTE: You may have intended to use ~x0 ~ instead of ~x1, which is a macro alias ~ for the function symbol ~x0." f1 f)) ((getpropc f 'macro-body nil wrld) (msg " NOTE: ~x0 is a macro, not a function ~ symbol." f)) (t ""))))) ((or (untouchable-fn-p f wrld (f-get-global 'temp-touchable-fns state)) (untouchable-fn-p g wrld (f-get-global 'temp-touchable-fns state))) (er soft ctx "The function symbol~#0~[ ~&0 is~/s ~&0 are~] ~ untouchable. See :DOC remove-untouchable." (append (and (untouchable-fn-p f wrld (f-get-global 'temp-touchable-fns state)) (list f)) (and (untouchable-fn-p g wrld (f-get-global 'temp-touchable-fns state)) (list g))))) ((and (not skip-checks-t) (not (logicp f wrld))) (cond ((null g) (er soft ctx "You must specify :SKIP-CHECKS T in order to use ~ defattach with :PROGRAM mode functions, such as ~ ~x0.~@1" f see-doc)) (t (er soft ctx "Only function symbols in :LOGIC mode may have ~ attachments~@0, but ~x1 is in :PROGRAM mode.~@2" unless-ttag f see-doc)))) ((and (member-eq f *unattachable-primitives*) not-boot-strap-p) (er soft ctx "It is illegal to add or remove an attachment to the ~ function symbol ~x0 because it is given special ~ treatment by the ACL2 implementation." f)) ((and not-boot-strap-p (not system-ok) (getpropc f 'predefined)) (er soft ctx "The function symbol ~x0 is built into ACL2. Thus, to ~ add or remove an attachment to this symbol it is ~ required to specify :SYSTEM-OK T in your defattach ~ event." f)) ((and (warrant-function-namep f wrld) (not (eq g 'true-apply$-warrant))) (er soft ctx "The only attachment legal for the warrant function ~x0 ~ is ~x1. The attachment of ~x2 to ~x0 is thus illegal." f 'true-apply$-warrant g)) (t (let ((at-alist (attachment-alist f wrld))) (cond ((eq (car at-alist) :attachment-disallowed) (let* ((at-alist (if (symbolp (cdr at-alist)) (attachment-alist (cdr at-alist) wrld) at-alist)) (pair (assert$ (eq (car at-alist) :attachment-disallowed) (assert$ (consp (cdr at-alist)) (cadr at-alist)))) (rule-name (assert$ (consp pair) (car pair))) (rule-class (cdr pair))) (if (member-eq rule-class '(:meta :clause-processor)) (let ((meta-fn (if (eq rule-class :meta) "meta" "clause-processor"))) (er soft ctx "It is illegal to attach to the function ~ symbol ~x0 because it is a common ancestor ~ of the evaluator and ~@1 functions of the ~ ~x2 rule, ~x3. See :DOC ~ evaluator-restrictions and see :DOC ~ transparent-functions." f meta-fn rule-class rule-name)) (assert$ (member-eq rule-class '(:defstobj :defabsstobj :defabsstobj-no-corr)) (er soft ctx "It is illegal to attach to the function symbol ~ ~x0 because it is an ancestor of ~@1 of ~ the ~s2stobj ~x3. See :DOC ~ stobj-attachment-restrictions." f (case rule-class (:defstobj "the recognizer") (:defabsstobj "the recognizer or correlation ~ function") (otherwise "the recognizer, creator, or an ~ exported function")) (if (eq rule-class :defstobj) "" "abstract ") rule-name))))) (t (let* ((erasures (cond ((consp at-alist) (append at-alist erasures)) (t erasures))) (constraint-lst-etc (getpropc f 'constraint-lst-etc '(t) wrld)) (attach-pair (assoc-eq :attach helper-alist))) (cond ((and (not skip-checks-t) (unknown-constraints-p (car constraint-lst-etc))) (defattach-unknown-constraints-error f ctx state)) ((null g) (cond (helper-alist (er soft ctx "The function symbol ~x0 has been associated ~ with NIL in a defattach event, yet keyword ~ argument~#1~[ ~&1 has~/s ~&1 have~] been ~ supplied for this association, which is ~ illegal.~@2" f (strip-cars helper-alist) see-doc)) (t (pprogn (cond ((null at-alist) (warning$ ctx "Attachment" "The function symbol ~x0 does not ~ currently have an attachment, so the ~ directive to remove its attachment ~ will have no effect." f)) (t (assert$ (consp at-alist) state))) (process-defattach-args1 (cdr args) ctx wrld state erasures (cons f explicit-erasures) attachment-alist helper-alist-lst skip-checks system-ok))))) ((and (or (null attach-pair) (cdr attach-pair)) (not (and skip-checks-t (eq (getpropc f 'non-executablep nil wrld) :program))) (or (equal constraint-lst-etc '(t)) (not (getpropc f 'constrainedp nil wrld)))) (er soft ctx "It is illegal to attach to function symbol ~x0, ~ because it ~@1.~@2" f (let ((pair (assoc-eq f *primitive-formals-and-guards*))) (cond (pair "is a built-in primitive") ((getpropc f 'defchoose-axiom nil wrld) "was introduced with DEFCHOOSE") (t "was introduced with DEFUN"))) see-doc)) ((not (symbolp g)) (er soft ctx "Only a function symbol may be attached to a ~ function symbol. The proposed attachment of ~ ~x0 to ~x1 is thus illegal, since ~x0 is not a ~ symbol.~@2" g f see-doc)) ((not (function-symbolp g wrld)) (er soft ctx "Only a function symbol may be attached to a ~ function symbol. The proposed attachment of ~ ~x0 to ~x1 is thus illegal, since ~x0 is not a ~ known function symbol.~@2~@3" g f see-doc (let ((g1 (deref-macro-name g (macro-aliases wrld)))) (cond ((not (eq g1 g)) (msg " NOTE: You may have intended to ~ use ~x0 instead of ~x1, which is ~ a macro alias for the function ~ symbol ~x0." g1 g)) ((getpropc g 'macro-body nil wrld) (msg " NOTE: ~x0 is a macro, not a ~ function symbol." g)) (t ""))))) ((and (not skip-checks-t) (not (logicp g wrld))) (er soft ctx "Attachments must be function symbols in :LOGIC ~ mode~@0, but ~x1 is in :PROGRAM mode.~@2" unless-ttag g see-doc)) ((and (not skip-checks-t) (not (eq (symbol-class g wrld) :common-lisp-compliant))) (er soft ctx "Attachments must be guard-verified function ~ symbols~@0, but ~x1 has not had its guard ~ verified. You may wish to use the macro ~x2 in ~ community book books/misc/defattach-bang.~@3" unless-ttag g 'defattach! see-doc)) ((not (and (equal (stobjs-in f wrld) (stobjs-in g wrld)) (equal (stobjs-out f wrld) (stobjs-out g wrld)))) (er soft ctx "Attachments must preserve signatures, but the ~ signatures differ for ~x0 and ~x1.~@2" f g see-doc)) ((eq f g) (er soft ctx "It is illegal to attach a function to itself, ~ such as ~x0.~@1" f see-doc)) ((and (not skip-checks-t) (eq (canonical-sibling f wrld) (canonical-sibling g wrld))) (er soft ctx "The function ~x0 is an illegal attachment for ~ ~x1~@2, because the two functions were ~ introduced in the same event.~@3" g f unless-ttag see-doc)) (t (process-defattach-args1 (cdr args) ctx wrld state erasures explicit-erasures (cons (cons f g) attachment-alist) (cons helper-alist helper-alist-lst) skip-checks system-ok))))))))))) (& (er soft ctx "Each tuple supplied to a defattach event must be of the ~ form (f g . kwd-value-lst). The tuple ~x0 is thus ~ illegal.~@1" arg see-doc)))))))
duplicate-keysp-eqfunction
(defun duplicate-keysp-eq (alist) (declare (xargs :guard (symbol-alistp alist))) (cond ((endp alist) nil) ((assoc-eq (caar alist) (cdr alist)) (car alist)) (t (duplicate-keysp-eq (cdr alist)))))
split-at-first-keywordfunction
(defun split-at-first-keyword (args) (declare (xargs :guard (true-listp args))) (cond ((endp args) (mv nil nil)) ((keywordp (car args)) (mv nil args)) (t (mv-let (alist kwd-value-lst) (split-at-first-keyword (cdr args)) (mv (cons (car args) alist) kwd-value-lst)))))
maybe-remove1-eqfunction
(defun maybe-remove1-eq (x lst) (declare (xargs :guard (if (symbolp x) (true-listp lst) (symbol-listp lst)))) (if (member-eq x lst) (remove1-eq x lst) lst))
filter-for-attachmentfunction
(defun filter-for-attachment (attachment-alist helpers-lst attach-by-default aa hl attach-nil-lst) (cond ((endp attachment-alist) (mv aa hl attach-nil-lst)) (t (let ((pair (assoc-eq :attach (car helpers-lst)))) (cond ((if pair (cdr pair) attach-by-default) (filter-for-attachment (cdr attachment-alist) (cdr helpers-lst) attach-by-default (cons (car attachment-alist) aa) (cons (car helpers-lst) hl) (maybe-remove1-eq (caar attachment-alist) attach-nil-lst))) (t (filter-for-attachment (cdr attachment-alist) (cdr helpers-lst) attach-by-default aa hl (add-to-set-eq (caar attachment-alist) attach-nil-lst))))))))
*defattach-keys-extended*constant
(defconst *defattach-keys-extended* (append *defattach-keys* '(:skip-checks :system-ok)))
process-defattach-argsfunction
(defun process-defattach-args (args ctx state) (let ((msg "Illegal arguments for defattach. See :DOC defattach. Note ~ that if the first argument is a symbol, then there should be ~ only two arguments, both of them symbols. Consider instead ~ executing ")) (cond ((null args) (er soft ctx "Defattach must specify at least one attachment. See :DOC ~ defattach.")) ((symbolp (car args)) (cond ((and (not (keywordp (car args))) (consp (cdr args)) (symbolp (cadr args)) (not (keywordp (cadr args)))) (cond ((null (cddr args)) (process-defattach-args `((,(CAR ARGS) ,(CADR ARGS))) ctx state)) ((and (true-listp args) (member-eq (caddr args) '(:skip-checks :system-ok))) (er soft ctx "~@0the form:~|~%~y1." msg `(defattach (,(CAR ARGS) ,(CADR ARGS)) ,@(CDDR ARGS)))) ((and (true-listp args) (eql (length args) 4) (eq (caddr args) :attach)) (er soft ctx "~@0the form:~|~%~y1." msg `(defattach (,@ARGS)))) (t (er soft ctx "~@0one of the following two forms:~|~%~y1~ ~ or~|~y2." msg `(defattach (,(CAR ARGS) ,(CADR ARGS)) ,@(CDDR ARGS)) `(defattach (,(CAR ARGS) ,(CADR ARGS) ,@(CDDR ARGS))))))) (t (er soft ctx "Illegal defattach form. If the first argument is a symbol, then ~ there must be exactly two arguments, both of which are ~ non-keyword symbols. See :DOC defattach.")))) (t (mv-let (args constraint-kwd-alist) (split-at-first-keyword args) (cond ((not (symbol-alistp args)) (er soft ctx "Illegal arguments for defattach, ~x0. See :DOC defattach." args)) ((duplicate-keysp-eq args) (er soft ctx "A defattach event must specify attachments for distinct ~ function symbols, but ~x0 is associated with a value more than ~ once. See :DOC defattach." (car (duplicate-keysp-eq args)))) ((or (not (keyword-value-listp constraint-kwd-alist)) (strip-keyword-list *defattach-keys-extended* constraint-kwd-alist)) (er soft ctx "Illegal defattach argument list. The tail following the ~ specified pairs of function symbols should be an alternating ~ list of keywords and values (see :DOC keyword-value-listp) ~ whose keys are without duplicates and all belong to the list ~ ~x0. That tail is, however, ~x1. See :DOC defattach." *defattach-keys-extended* constraint-kwd-alist)) (t (let* ((wrld (w state)) (ld-skip-proofsp (ld-skip-proofsp state)) (skip-checks-tail (assoc-keyword :skip-checks constraint-kwd-alist)) (skip-checks (cadr skip-checks-tail)) (constraint-kwd-alist (if skip-checks-tail (remove-keyword :skip-checks constraint-kwd-alist) constraint-kwd-alist)) (system-ok-tail (assoc-keyword :system-ok constraint-kwd-alist)) (system-ok (cadr system-ok-tail)) (constraint-kwd-alist (if system-ok-tail (remove-keyword :system-ok constraint-kwd-alist) constraint-kwd-alist))) (cond ((and skip-checks (not (eq skip-checks t)) (not (eq skip-checks :cycles))) (er soft ctx "Illegal value for :SKIP-CHECKS (must be ~x0, ~x1, or ~ ~x2): ~x3." t nil :cycles skip-checks)) ((and skip-checks (not (or (f-get-global 'boot-strap-flg state) (ttag wrld)))) (er soft ctx "It is illegal to specify a non-nil value of :SKIP-CHECKS ~ for defattach unless there is an active trust tag.")) ((not (booleanp system-ok)) (er soft ctx "Illegal value for :SKIP-CHECKS (must be ~x0 or ~x1): ~x2." t nil system-ok)) (t (er-let* ((tuple (process-defattach-args1 args ctx wrld state nil nil nil nil skip-checks system-ok)) (constraint-helpers (cond ((or (eq ld-skip-proofsp 'include-book) (eq ld-skip-proofsp 'include-book-with-locals) (eq ld-skip-proofsp 'initialize-acl2)) (value nil)) (t (translate-defattach-helpers constraint-kwd-alist "DEFATTACH constraint proof obligation" ctx wrld state))))) (let ((erasures (nth 0 tuple)) (explicit-erasures (nth 1 tuple)) (attachment-alist (nth 2 tuple)) (helper-alist-lst (nth 3 tuple)) (attach-by-default (let ((pair (assoc-eq :attach constraint-helpers))) (if pair (cdr pair) t)))) (mv-let (attachment-alist-exec helper-alist-lst-exec attach-nil-lst) (filter-for-attachment attachment-alist helper-alist-lst attach-by-default nil nil (global-val 'attach-nil-lst wrld)) (value (list constraint-helpers erasures explicit-erasures (merge-sort-symbol-alistp attachment-alist) attachment-alist-exec helper-alist-lst-exec skip-checks attach-nil-lst)))))))))))))))
prove-defattach-guards1function
(defun prove-defattach-guards1 (i n attachment-alist-tail attachment-alist helpers-lst ctx ens wrld state ttree) (cond ((null attachment-alist-tail) (pprogn (io? event nil state (n) (fms "This concludes the ~#0~[guard proof~/~n1 guard proofs~].~%" (list (cons #\0 (cond ((= n 1) 0) (t 1))) (cons #\1 n)) (proofs-co state) state nil)) (value ttree))) (t (let* ((f (caar attachment-alist-tail)) (g (cdar attachment-alist-tail)) (goal (sublis-fn-simple attachment-alist (fcons-term* 'implies (sublis-var (pairlis$ (formals f wrld) (formals g wrld)) (guard f nil wrld)) (guard g nil wrld)))) (helper-alist (car helpers-lst)) (otf-flg (cdr (assoc-eq :otf-flg helper-alist))) (hints (cdr (assoc-eq :hints helper-alist))) (instructions (cdr (assoc-eq :instructions helper-alist))) (ugoal (untranslate goal t wrld))) (pprogn (io? event nil state (ugoal n i) (fms "The~#0~[~/ ~n1 (and last)~/ ~n1~] guard proof obligation ~ is~|~%~y2." (list (cons #\0 (cond ((int= n 1) (assert$ (= i 1) 0)) ((int= i n) 1) (t 2))) (cons #\1 (list i)) (cons #\2 ugoal)) (proofs-co state) state (term-evisc-tuple nil state))) (er-let* ((ttree1 (cond (instructions (proof-builder nil ugoal goal nil instructions wrld state)) (t (prove goal (make-pspv ens wrld state :displayed-goal ugoal :otf-flg otf-flg) hints ens wrld ctx state))))) (prove-defattach-guards1 (1+ i) n (cdr attachment-alist-tail) attachment-alist (cdr helpers-lst) ctx ens wrld state (cons-tag-trees ttree1 ttree))))))))
prove-defattach-guardsfunction
(defun prove-defattach-guards (attachment-alist helpers-lst ctx ens wrld state) (let ((n (length attachment-alist))) (assert$ (and attachment-alist (int= n (length helpers-lst))) (pprogn (cond ((int= n 1) state) (t (io? event nil state (n) (fms "~%We first consider the ~n0 guard proof ~ obligations.~%" (list (cons #\0 n)) (proofs-co state) state nil)))) (prove-defattach-guards1 1 n attachment-alist attachment-alist helpers-lst ctx ens wrld state nil)))))
true-apply$-warrantfunction
(defun true-apply$-warrant nil (declare (xargs :guard t :mode :logic)) t)
defattach-constraint-recfunction
(defun defattach-constraint-rec (alist full-alist proved-fnl-insts-alist constraint event-names new-entries seen wrld) (cond ((endp alist) (mv constraint event-names new-entries)) ((and (eq (cdar alist) 'true-apply$-warrant) (warrant-function-namep (caar alist) wrld)) (defattach-constraint-rec (cdr alist) full-alist proved-fnl-insts-alist constraint event-names new-entries seen wrld)) (t (mv-let (name x origins) (constraint-info (caar alist) wrld) (declare (ignore origins)) (cond ((unknown-constraints-p x) (mv x name nil)) (t (let ((key (or name (caar alist)))) (cond ((member-eq key seen) (defattach-constraint-rec (cdr alist) full-alist proved-fnl-insts-alist constraint event-names new-entries seen wrld)) (t (let* ((ev (and x (event-responsible-for-proved-constraint key full-alist proved-fnl-insts-alist))) (instantiable-fns (and x (cond (name (instantiable-ffn-symbs-lst x wrld nil nil)) (t (instantiable-ffn-symbs x wrld nil nil))))) (constraint-alist (and x (restrict-alist instantiable-fns full-alist))) (seen (cons key seen))) (cond ((null x) (defattach-constraint-rec (cdr alist) full-alist proved-fnl-insts-alist constraint event-names new-entries seen wrld)) (ev (defattach-constraint-rec (cdr alist) full-alist proved-fnl-insts-alist constraint (add-to-set ev event-names) new-entries seen wrld)) (t (defattach-constraint-rec (cdr alist) full-alist proved-fnl-insts-alist (if name (conjoin (cons constraint (sublis-fn-lst-simple constraint-alist x))) (conjoin2 constraint (sublis-fn-simple constraint-alist x))) event-names (cons (make proved-functional-instances-alist-entry :constraint-event-name key :restricted-alist constraint-alist :behalf-of-event-name 0) new-entries) seen wrld)))))))))))))
defattach-constraintfunction
(defun defattach-constraint (attachment-alist proved-fnl-insts-alist wrld ctx state) (mv-let (goal event-names new-entries) (defattach-constraint-rec attachment-alist attachment-alist proved-fnl-insts-alist *t* nil nil nil wrld) (cond ((unknown-constraints-p goal) (defattach-unknown-constraints-error event-names ctx state)) (t (value (list* goal event-names new-entries))))))
prove-defattach-constraintfunction
(defun prove-defattach-constraint (goal event-names attachment-alist helper-alist ctx ens wrld state) (assert$ (not (unknown-constraints-p goal)) (let ((constraint-bypass-string " Note that we are bypassing constraints that have been proved ~ when processing ~#0~[previous events~/events including ~&1~/the ~ event~#1~[~/s~] ~&1~].")) (cond ((equal goal *t*) (pprogn (io? event nil state (attachment-alist event-names constraint-bypass-string) (fms "~%The attachment~#0~[ trivially satisfies~/s trivially ~ satisfy~] the required constraints.~@1~|~%" (list (cons #\0 attachment-alist) (cons #\1 (cond ((null event-names) "") ((member 0 event-names) (cond ((null (cdr event-names)) (msg constraint-bypass-string 0 event-names)) (t (msg constraint-bypass-string 1 (remove 0 event-names))))) (t (msg constraint-bypass-string 2 event-names))))) (proofs-co state) state nil)) (value nil))) (t (let ((ugoal (untranslate goal t wrld)) (otf-flg (cdr (assoc-eq :otf-flg helper-alist))) (hints (cdr (assoc-eq :hints helper-alist))) (instructions (cdr (assoc-eq :instructions helper-alist)))) (pprogn (io? event nil state (attachment-alist event-names constraint-bypass-string ugoal) (fms "~%We now prove that the attachment~#0~[ satisfies~/s ~ satisfy~] the required constraint.~@1~|The goal to prove ~ is~|~%~y2." (list (cons #\0 attachment-alist) (cons #\1 (cond ((null event-names) "") ((member 0 event-names) (cond ((null (cdr event-names)) (msg constraint-bypass-string 0 event-names)) (t (msg constraint-bypass-string 1 (remove 0 event-names))))) (t (msg constraint-bypass-string 2 event-names)))) (cons #\2 ugoal)) (proofs-co state) state nil)) (er-let* ((ttree (cond (instructions (proof-builder nil ugoal goal nil instructions wrld state)) (t (prove goal (make-pspv ens wrld state :displayed-goal ugoal :otf-flg otf-flg) hints ens wrld ctx state))))) (value ttree)))))))))
attachment-component-ownerfunction
(defun attachment-component-owner (g path) (if path (car path) g))
defattach-component-has-ownerfunction
(defun defattach-component-has-owner (g g0 comps) (cond ((endp comps) nil) (t (let ((path (access attachment-component (car comps) :path))) (or (eq g (attachment-component-owner g0 path)) (defattach-component-has-owner g g0 (cdr comps)))))))
defattach-merge-into-componentfunction
(defun defattach-merge-into-component (g0 ext-succ0 comps0 ext-succ1 g1 ord-anc1 ext-anc1 path1) (cond ((endp comps0) (mv nil nil)) (t (let* ((comp0 (car comps0)) (path0 (access attachment-component comp0 :path)) (ext-anc0 (access attachment-component comp0 :ext-anc)) (ord-anc0 (access attachment-component comp0 :ord-anc)) (new-path (cond ((or (member-eq g1 ext-anc0) (and (null path1) (member-eq g1 ord-anc0))) (append path1 (cons g1 path0))) (t (let ((h (or (intersection1-eq ext-anc0 ext-succ1) (intersection1-eq ord-anc0 ext-succ1)))) (and h (append path1 (list* g1 h path0)))))))) (cond ((null new-path) (defattach-merge-into-component g0 ext-succ0 (cdr comps0) ext-succ1 g1 ord-anc1 ext-anc1 path1)) ((or (member-eq g0 ord-anc1) (member-eq g0 ext-anc1)) (mv 'loop (cons g0 new-path))) (t (let ((h1 (or (intersection1-eq ext-succ0 ord-anc1) (intersection1-eq ext-succ0 ext-anc1)))) (cond (h1 (mv 'loop (list* g0 h1 new-path))) (t (mv nil (make attachment-component :ord-anc ord-anc1 :ext-anc ext-anc1 :path new-path)))))))))))
defattach-merge-componentsfunction
(defun defattach-merge-components (g0 ext-succ0 comps0 ext-succ1 g1 comps1 flg extended-comps0) (cond ((endp comps1) (mv flg extended-comps0)) ((defattach-component-has-owner (attachment-component-owner g1 (access attachment-component (car comps1) :path)) g0 comps0) (defattach-merge-components g0 ext-succ0 comps0 ext-succ1 g1 (cdr comps1) flg extended-comps0)) (t (mv-let (flg1 new-comp) (let ((comp1 (car comps1))) (defattach-merge-into-component g0 ext-succ0 comps0 ext-succ1 g1 (access attachment-component comp1 :ord-anc) (access attachment-component comp1 :ext-anc) (access attachment-component comp1 :path))) (cond ((eq flg1 'loop) (mv flg1 new-comp)) (new-comp (defattach-merge-components g0 ext-succ0 comps0 ext-succ1 g1 (cdr comps1) t (cons new-comp extended-comps0))) (t (defattach-merge-components g0 ext-succ0 comps0 ext-succ1 g1 (cdr comps1) flg extended-comps0)))))))
defattach-mergefunction
(defun defattach-merge (r0 r1) (let ((g0 (access attachment r0 :g)) (ext-succ0 (access attachment r0 :ext-succ)) (comps0 (access attachment r0 :components)) (ext-succ1 (access attachment r1 :ext-succ)) (g1 (access attachment r1 :g)) (comps1 (access attachment r1 :components))) (mv-let (flg val) (defattach-merge-components g0 ext-succ0 comps0 ext-succ1 g1 comps1 nil comps0) (cond ((eq flg 'loop) (mv flg val)) ((null flg) (mv nil r0)) (t (mv t (change attachment r0 :components val)))))))
defattach-merge-lstfunction
(defun defattach-merge-lst (r lst changedp) (declare (xargs :measure (acl2-count lst))) (cond ((endp lst) (mv changedp r)) (t (mv-let (flg r) (defattach-merge r (car lst)) (cond ((eq flg 'loop) (mv flg r)) (t (defattach-merge-lst r (cdr lst) (or flg changedp))))))))
defattach-merge-lst-lstfunction
(defun defattach-merge-lst-lst (to-do done changedp) (cond ((endp to-do) (mv changedp done)) (t (mv-let (flg r) (defattach-merge-lst (car to-do) (cdr to-do) changedp) (cond ((eq flg 'loop) (mv flg r)) (t (mv-let (flg r) (defattach-merge-lst r done flg) (cond ((eq flg 'loop) (mv flg r)) (t (defattach-merge-lst-lst (cdr to-do) (cons r done) (or changedp flg)))))))))))
defattach-loop-error-msgfunction
(defun defattach-loop-error-msg (loop end) (cond ((endp loop) "") (t (let ((h1 (car loop)) (h2 (if (cdr loop) (cadr loop) end))) (msg "~x0 is an extended ancestor of ~x1.~|~@2" h1 h2 (defattach-loop-error-msg (cdr loop) end))))))
defattach-loop-errorfunction
(defun defattach-loop-error (loop ctx state) (er soft ctx "The proposed defattach event is illegal because the following is a ~ loop in the resulting extended ancestor relation. See :DOC ~ defattach.~|~%~@0" (defattach-loop-error-msg loop (car loop))))
defattach-closefunction
(defun defattach-close (records ctx state) (mv-let (flg records) (defattach-merge-lst-lst records nil nil) (cond ((eq flg 'loop) (defattach-loop-error records ctx state)) ((eq flg nil) (value records)) (t (defattach-close records ctx state)))))
defattach-erase-componentsfunction
(defun defattach-erase-components (components canonical-erased-fs) (cond ((endp components) (mv nil nil)) (t (let ((comp (car components))) (mv-let (changedp cdr-comps) (defattach-erase-components (cdr components) canonical-erased-fs) (cond ((intersectp-eq (access attachment-component comp :path) canonical-erased-fs) (mv t cdr-comps)) (changedp (mv t (cons comp cdr-comps))) (t (mv nil components))))))))
defattach-erase-pfunction
(defun defattach-erase-p (record erasures canonical-erased-fs) (let* ((pairs (access attachment record :pairs)) (removed-pairs (intersection-equal erasures pairs))) (cond (removed-pairs (mv t (set-difference-equal pairs removed-pairs))) ((member-eq (access attachment record :g) canonical-erased-fs) (mv t pairs)) (t (mv nil nil)))))
defattach-erase1function
(defun defattach-erase1 (records attachments erasures canonical-erased-fs acc-recs) (cond ((endp records) (mv acc-recs attachments)) (t (mv-let (flg new-attachments) (defattach-erase-p (car records) erasures canonical-erased-fs) (cond (flg (defattach-erase1 (cdr records) (append new-attachments attachments) erasures canonical-erased-fs acc-recs)) (t (let* ((comps (access attachment (car records) :components)) (rec (mv-let (changedp comps) (defattach-erase-components comps canonical-erased-fs) (assert$ comps (cond (changedp (change attachment (car records) :components comps)) (t (car records))))))) (defattach-erase1 (cdr records) attachments erasures canonical-erased-fs (cons rec acc-recs)))))))))
defattach-erasefunction
(defun defattach-erase (records attachments erasures wrld) (let ((canonical-erased-fs (collect-canonical-siblings (strip-cars erasures) wrld nil nil))) (defattach-erase1 records attachments erasures canonical-erased-fs nil)))
collect-ext-ancfunction
(defun collect-ext-anc (f records) (cond ((endp records) nil) ((member-eq f (access attachment (car records) :ext-succ)) (cons (access attachment (car records) :g) (collect-ext-anc f (cdr records)))) (t (collect-ext-anc f (cdr records)))))
extend-attachment-componentsfunction
(defun extend-attachment-components (comps g0 ext-succ f g) (cond ((endp comps) (mv nil nil)) (t (mv-let (flg cdr-comps) (extend-attachment-components (cdr comps) g0 ext-succ f g) (cond ((eq flg 'loop) (mv flg cdr-comps)) (t (let* ((comp (car comps)) (path (access attachment-component comp :path))) (cond ((eq f (attachment-component-owner g0 path)) (cond ((member-eq g ext-succ) (mv 'loop (list* g0 g path))) (t (let ((ext-anc (access attachment-component comp :ext-anc))) (cond ((member-eq g ext-anc) (cond (flg (mv t (cons comp cdr-comps))) (t (mv nil comps)))) (t (mv t (cons (change attachment-component comp :ext-anc (cons g ext-anc)) cdr-comps)))))))) (flg (mv t (cons comp cdr-comps))) (t (mv nil comps))))))))))
component-path-extensionfunction
(defun component-path-extension (f comps) (cond ((endp comps) nil) ((let ((path (access attachment-component (car comps) :path))) (and (eq (car path) f) path))) ((or (member-eq f (access attachment-component (car comps) :ext-anc)) (member-eq f (access attachment-component (car comps) :ord-anc))) (cons f (access attachment-component (car comps) :path))) (t (component-path-extension f (cdr comps)))))
extend-attachment-recordfunction
(defun extend-attachment-record (pair f-canon g-canon rec) (let ((ext-succ (access attachment rec :ext-succ)) (g-field (access attachment rec :g)) (comps (access attachment rec :components))) (cond ((eq g-canon g-field) (let ((pairs (access attachment rec :pairs)) (path (component-path-extension f-canon comps))) (assert$ (not (member-equal pair pairs)) (cond (path (mv 'loop (cons g-canon path))) ((member-eq f-canon ext-succ) (mv 'found (change attachment rec :pairs (cons pair pairs)))) (t (mv 'found (change attachment rec :pairs (cons pair pairs) :ext-succ (cons f-canon ext-succ)))))))) (t (mv-let (flg new-comps) (extend-attachment-components comps g-field ext-succ f-canon g-canon) (cond ((eq flg 'loop) (mv 'loop new-comps)) (flg (mv t (change attachment rec :components new-comps))) (t (mv nil rec))))))))
update-attachment-records1function
(defun update-attachment-records1 (pair f-canon g-canon records) (cond ((endp records) (mv nil nil)) (t (mv-let (flg recs) (update-attachment-records1 pair f-canon g-canon (cdr records)) (cond ((eq flg 'loop) (mv 'loop recs)) (t (mv-let (flg2 rec) (extend-attachment-record pair f-canon g-canon (car records)) (cond ((eq flg2 'loop) (mv 'loop rec)) ((or flg flg2) (mv (if (or (eq flg 'found) (eq flg2 'found)) 'found t) (cons rec recs))) (t (mv nil records))))))))))
update-attachment-recordsfunction
(defun update-attachment-records (pair f-canon g-canon records wrld ctx state) (mv-let (flg recs) (update-attachment-records1 pair f-canon g-canon records) (cond ((eq flg 'loop) (defattach-loop-error recs ctx state)) ((eq flg 'found) (value recs)) (t (let* ((ext-succ (siblings f-canon wrld)) (ord-anc (canonical-ancestors g-canon wrld nil)) (ext-anc (collect-ext-anc g-canon records)) (h (or (intersection1-eq ord-anc ext-succ) (intersection1-eq ext-anc ext-succ)))) (cond (h (defattach-loop-error (list g-canon h) ctx state)) (t (value (cons (make attachment :ext-succ ext-succ :g g-canon :components (list (make attachment-component :ord-anc ord-anc :ext-anc ext-anc :path nil)) :pairs (list pair)) recs)))))))))
attachment-recordsfunction
(defun attachment-records (attachments records wrld ctx state) (cond ((endp attachments) (value records)) (t (let ((pair (car attachments))) (cond ((warrant-function-namep (car pair) wrld) (assert$ (eq (cdr pair) 'true-apply$-warrant) (attachment-records (cdr attachments) records wrld ctx state))) (t (let ((f-canon (canonical-sibling (car pair) wrld)) (g-canon (canonical-sibling (cdr pair) wrld))) (er-let* ((records (update-attachment-records pair f-canon g-canon records wrld ctx state))) (attachment-records (cdr attachments) records wrld ctx state)))))))))
chk-defattach-loopfunction
(defun chk-defattach-loop (attachments erasures wrld ctx state) (let ((records (global-val 'attachment-records wrld))) (mv-let (records attachments) (cond (erasures (defattach-erase records attachments erasures wrld)) (t (mv records attachments))) (cond ((null attachments) (value records)) (t (er-let* ((records (attachment-records attachments records wrld ctx state))) (defattach-close records ctx state)))))))
defaxiom-supporter-msg-listfunction
(defun defaxiom-supporter-msg-list (symbols wrld) (cond ((endp symbols) nil) (t (let ((prop (getpropc (car symbols) 'defaxiom-supporter nil wrld))) (cond (prop (cons (msg "function symbol ~x0 supports defaxiom ~x1" (car symbols) prop) (defaxiom-supporter-msg-list (cdr symbols) wrld))) (t (defaxiom-supporter-msg-list (cdr symbols) wrld)))))))
defattach-global-stobjs-msgfunction
(defun defattach-global-stobjs-msg (attachment-alist-exec wrld state) (cond ((endp attachment-alist-exec) nil) (t (let* ((f (caar attachment-alist-exec)) (g (cdar attachment-alist-exec)) (gs-f (getpropc f 'global-stobjs nil wrld)) (gs-f-reads (car gs-f)) (gs-f-writes (cdr gs-f)) (gs-g (getpropc g 'global-stobjs nil wrld)) (gs-g-reads (car gs-g)) (gs-g-writes (cdr gs-g))) (cond ((and (subsetp-eq gs-g-writes gs-f-writes) (subsetp-eq gs-g-reads (append gs-f-writes gs-f-reads))) (defattach-global-stobjs-msg (cdr attachment-alist-exec) wrld state)) (t (msg "The attachment of ~x0 to ~x1 restricts stobjs bound ~ by WITH-GLOBAL-STOBJ under calls of ~x0, according to ~ the :GLOBAL-STOBJS keyword (default nil) in the ~ signature introducing ~x1. But this restriction is ~ violated for stobj~#2~[~/s~] ~&2: ~@3" g f (append (set-difference-eq gs-g-writes gs-f-writes) (set-difference-eq gs-g-reads (append gs-f-writes gs-f-reads))) (let* ((upd (set-difference-eq gs-g-writes gs-f-writes)) (st (if upd (car (set-difference-eq gs-g-writes gs-f-writes)) (car (set-difference-eq gs-g-reads (append gs-f-writes gs-f-reads))))) (path (path-to-with-global-stobj st (list g) upd wrld nil nil))) (with-global-stobj-illegal-path-msg "the attempt is to attach" (msg ", yet that stobj is not specified~@0 by the ~ :GLOBAL-STOBJS keyword of ~x1" (if upd " for updating" "") f) path st upd wrld)))))))))
find-transparentfunction
(defun find-transparent (lst wrld) (cond ((endp lst) nil) ((transparent-fn-p (canonical-sibling (car lst) wrld) wrld) (car lst)) (t (find-transparent (cdr lst) wrld))))
chk-defattach-transparentfunction
(defun chk-defattach-transparent (attachment-alist-sorted explicit-erasures ctx wrld state) (let* ((attached-fns (strip-cars attachment-alist-sorted)) (tr (or (find-transparent attached-fns wrld) (find-transparent explicit-erasures wrld)))) (cond ((null tr) (value nil)) ((and attached-fns explicit-erasures) (er soft ctx "When a defattach event specifies a transparent function symbol to ~ be attached or unattached, then it is illegal for that same event ~ to specify both an attachment and an erasure. The proposed ~ defattach event for transparent function symbol ~x0 is thus ~ illegal. See :DOC defattach." tr)) (t (let ((siblings (siblings tr wrld)) (fns (or attached-fns explicit-erasures))) (cond ((equal fns siblings) (value nil)) ((first-non-member-eq fns siblings) (er soft ctx "The function symbol ~x0 was introduced as transparent, ~ but both ~x0 and ~x1 are specified for ~ ~#2~[un~/~]attachment in a proposed defattach event ~ even though ~x1 was not introduced in the same ~ encapsulate event as ~x0. This is illegal; see :DOC ~ defattach." tr (first-non-member-eq fns siblings) (if explicit-erasures 0 1))) ((first-non-member-eq siblings fns) (er soft ctx "A proposed defattach event ~#0~[un~/~]attaches to ~x1 ~ but not to ~x2, even though ~x1 and ~x2 are transparent ~ function symbols that were introduced in the same ~ encapsulate event. This is illegal; see :DOC defattach." (if explicit-erasures 0 1) tr (first-non-member-eq siblings fns))) (t (value nil))))))))
chk-acceptable-defattachfunction
(defun chk-acceptable-defattach (args proved-fnl-insts-alist ctx wrld state) (er-let* ((tuple (er-progn (chk-non-local-in-non-trivial-encapsulate "Defattach events" nil ctx wrld state) (process-defattach-args args ctx state)))) (let* ((constraint-helper-alist (nth 0 tuple)) (erasures (nth 1 tuple)) (explicit-erasures (nth 2 tuple)) (attachment-alist-sorted (nth 3 tuple)) (attachment-alist-exec (nth 4 tuple)) (guard-helpers-lst (nth 5 tuple)) (skip-checks (nth 6 tuple)) (attach-nil-lst (nth 7 tuple)) (skip-checks-t (eq (nth 6 tuple) t)) (ens (ens state)) (ld-skip-proofsp (ld-skip-proofsp state)) (defaxiom-supporter-msg-list (and (not skip-checks-t) (defaxiom-supporter-msg-list (strip-cars attachment-alist-sorted) wrld))) (defattach-global-stobjs-msg (and (not (member-eq (ld-skip-proofsp state) '(include-book include-book-with-locals))) (defattach-global-stobjs-msg attachment-alist-exec wrld state)))) (cond (defaxiom-supporter-msg-list (er soft ctx "It is illegal for supporters of DEFAXIOM events to receive ~ attachments, but ~*0. See :DOC defattach." `("impossible" "~@*" "~@*, and " "~@*, " ,DEFAXIOM-SUPPORTER-MSG-LIST))) (defattach-global-stobjs-msg (er soft ctx "~@0~@1" defattach-global-stobjs-msg *see-doc-with-global-stobj*)) (t (er-progn (chk-defattach-transparent attachment-alist-sorted explicit-erasures ctx wrld state) (er-let* ((records (cond (skip-checks (value :skipped)) (t (chk-defattach-loop attachment-alist-sorted erasures wrld ctx state)))) (goal/event-names/new-entries (cond ((and (not skip-checks-t) attachment-alist-sorted) (defattach-constraint attachment-alist-sorted proved-fnl-insts-alist wrld ctx state)) (t (value nil)))) (goal (value (car goal/event-names/new-entries))) (event-names (value (cadr goal/event-names/new-entries))) (new-entries (value (cddr goal/event-names/new-entries))) (ttree1 (cond ((or skip-checks-t ld-skip-proofsp (null attachment-alist-exec)) (value nil)) (t (prove-defattach-guards attachment-alist-exec guard-helpers-lst ctx ens wrld state)))) (ttree2 (er-progn (chk-assumption-free-ttree ttree1 ctx state) (cond ((and (not skip-checks-t) (not ld-skip-proofsp) attachment-alist-sorted) (prove-defattach-constraint goal event-names attachment-alist-sorted constraint-helper-alist ctx ens wrld state)) (t (value nil)))))) (er-progn (chk-assumption-free-ttree ttree2 ctx state) (value (list erasures explicit-erasures attachment-alist-sorted attachment-alist-exec new-entries (cons-tag-trees ttree1 ttree2) records skip-checks attach-nil-lst))))))))))
attachment-cltl-cmdfunction
(defun attachment-cltl-cmd (erasures alist) (cons 'attachment (append erasures alist)))
chk-meta-fn-attachments-lstfunction
(defun chk-meta-fn-attachments-lst (name lst-lst ctx wrld state) (let* ((lst (car lst-lst)) (rule-class (car lst)) (meta-fn-lst (cadr lst)) (ev-anc (caddr lst)) (extra-anc (cadddr lst)) (ev-fns (cadddr (cdr lst)))) (er-let* ((val1 (chk-meta-fn-attachments name rule-class meta-fn-lst ev-anc extra-anc ev-fns nil ctx wrld state))) (cond ((null (cdr lst-lst)) (value val1)) (t (er-let* ((val2 (chk-meta-fn-attachments-lst name (cdr lst-lst) ctx wrld state))) (value (cond ((null val1) val2) ((null val2) val1) (t (cons (union-eq (car val1) (car val2)) (union-eq (cdr val1) (cdr val2))))))))))))
put-defattach-props-tr-meta-anc-removalsfunction
(defun put-defattach-props-tr-meta-anc-removals (fns name wrld wrld0) (cond ((endp fns) wrld) (t (let* ((fn (car fns)) (constrainedp (getpropc fn 'constrainedp nil wrld0)) (names (assert$ (weak-transparent-rec-p constrainedp) (access transparent-rec constrainedp :names))) (new-names (assert$ (member-eq name names) (remove1 name names)))) (put-defattach-props-tr-meta-anc-removals (cdr fns) name (putprop fn 'constrainedp (change transparent-rec constrainedp :names new-names) wrld) wrld0)))))
put-defattach-props-tr-meta-anc-additionsfunction
(defun put-defattach-props-tr-meta-anc-additions (fns name wrld wrld0) (cond ((endp fns) wrld) (t (let* ((fn (car fns)) (constrainedp (getpropc fn 'constrainedp nil wrld0)) (names (assert$ (weak-transparent-rec-p constrainedp) (access transparent-rec constrainedp :names))) (new-names (assert$ (not (member-eq name names)) (cons name names)))) (put-defattach-props-tr-meta-anc-additions (cdr fns) name (putprop fn 'constrainedp (change transparent-rec constrainedp :names new-names) wrld) wrld0)))))
put-defattach-props-tr-meta-ancfunction
(defun put-defattach-props-tr-meta-anc (name tr-meta-anc-old tr-meta-anc-new wrld wrld0) (let* ((wrld1 (put-defattach-props-tr-meta-anc-removals (set-difference-eq tr-meta-anc-old tr-meta-anc-new) name wrld wrld0))) (put-defattach-props-tr-meta-anc-additions (set-difference-eq tr-meta-anc-new tr-meta-anc-old) name wrld1 wrld0)))
put-defattach-props-common-anc-removalsfunction
(defun put-defattach-props-common-anc-removals (fns name wrld wrld0) (cond ((endp fns) wrld) (t (let* ((fn (car fns)) (prop (getpropc fn 'attachment nil wrld0)) (new-alist (assert$ (and (consp prop) (eq (car prop) :attachment-disallowed) (assoc-eq name (cdr prop))) (remove1-assoc-eq name (cdr prop))))) (put-defattach-props-common-anc-removals (cdr fns) name (putprop fn 'attachment (and new-alist (cons :attachment-disallowed new-alist)) wrld) wrld0)))))
put-defattach-props-common-anc-additionsfunction
(defun put-defattach-props-common-anc-additions (fns new-pair wrld wrld0) (cond ((endp fns) wrld) (t (let* ((fn (car fns)) (prop (getpropc fn 'attachment nil wrld0)) (alist (if (null prop) nil (assert$ (and (consp prop) (eq (car prop) :attachment-disallowed)) (cdr prop))))) (put-defattach-props-common-anc-additions (cdr fns) new-pair (putprop fn 'attachment (list* :attachment-disallowed new-pair alist) wrld) wrld0)))))
put-defattach-props-common-ancfunction
(defun put-defattach-props-common-anc (name common-anc-old common-anc-new rule-class wrld wrld0) (let* ((wrld1 (put-defattach-props-common-anc-removals (set-difference-eq common-anc-old common-anc-new) name wrld wrld0)) (only-new (set-difference-eq common-anc-new common-anc-old))) (cond (only-new (put-defattach-props-common-anc-additions only-new (cons name rule-class) wrld1 wrld0)) (t wrld1))))
put-defattach-props-namesfunction
(defun put-defattach-props-names (names ctx wrld wrld0 state) (cond ((endp names) (value wrld)) (t (let* ((name (car names)) (prop (getpropc name 'evaluator-check-inputs nil wrld0)) (tr-meta-anc-old (car prop)) (common-anc-old (cadr prop))) (er-let* ((pair (chk-meta-fn-attachments-lst name (cddr prop) ctx wrld0 state))) (let* ((tr-meta-anc-new (car pair)) (common-anc-new (cdr pair)) (wrld1 (put-defattach-props-tr-meta-anc name tr-meta-anc-old tr-meta-anc-new wrld wrld0)) (rule-class (if (cdr (cddr prop)) t (car (car (cddr prop))))) (wrld2 (put-defattach-props-common-anc name common-anc-old common-anc-new rule-class wrld1 wrld0)) (wrld3 (assert$ tr-meta-anc-new (putprop name 'evaluator-check-inputs (list* tr-meta-anc-new common-anc-new (cddr prop)) wrld2)))) (put-defattach-props-names (cdr names) ctx wrld3 wrld0 state)))))))
put-defattach-propsfunction
(defun put-defattach-props (fn ctx wrld state) (revert-world-on-error (pprogn (set-w 'extension wrld state) (let* ((prop (getpropc fn 'constrainedp nil wrld)) (names (assert$ (weak-transparent-rec-p prop) (access transparent-rec prop :names)))) (put-defattach-props-names names ctx wrld wrld state)))))
defattach-fnfunction
(defun defattach-fn (args state event-form) (with-ctx-summarized (case-match args (((x y)) (msg "( DEFATTACH (~x0 ~x1))" x y)) (((x y . &)) (msg "( DEFATTACH (~x0 ~x1 ...))" x y)) (((x y) . &) (msg "( DEFATTACH (~x0 ~x1) ...)" x y)) (((x y . &) . &) (msg "( DEFATTACH (~x0 ~x1 ...) ...)" x y)) ((x y) (msg "( DEFATTACH ~x0 ~x1)" x y)) ((x y . &) (msg "( DEFATTACH ~x0 ~x1 ...)" x y)) (& (msg "( DEFATTACH ...)"))) (let* ((wrld (w state)) (proved-fnl-insts-alist (global-val 'proved-functional-instances-alist wrld))) (er-let* ((tuple (chk-acceptable-defattach args proved-fnl-insts-alist ctx wrld state))) (let* ((erasures (strip-cars (nth 0 tuple))) (explicit-erasures (nth 1 tuple)) (attachment-alist-sorted (nth 2 tuple)) (attachment-alist-exec (nth 3 tuple)) (new-entries (nth 4 tuple)) (ttree (nth 5 tuple)) (records (nth 6 tuple)) (skip-checks (nth 7 tuple)) (attach-nil-lst (nth 8 tuple)) (attachment-fns (strip-cars attachment-alist-sorted)) (wrld0 (global-set? 'attach-nil-lst attach-nil-lst wrld (global-val 'attach-nil-lst wrld))) (wrld1 (putprop-x-lst1 erasures 'attachment nil wrld0)) (wrld2 (cond (attachment-fns (putprop-x-lst1 (cdr attachment-fns) 'attachment (car attachment-fns) (putprop (car attachment-fns) 'attachment attachment-alist-sorted wrld1))) (t wrld1))) (wrld3 (cond (new-entries (global-set 'proved-functional-instances-alist (append new-entries proved-fnl-insts-alist) wrld2)) (t wrld2))) (wrld4 (cond (skip-checks wrld3) (t (global-set 'attachment-records records wrld3)))) (cltl-cmd (attachment-cltl-cmd (set-difference-assoc-eq erasures attachment-alist-exec) attachment-alist-exec)) (fn-tr (assert$ (or (consp attachment-alist-sorted) (consp explicit-erasures)) (let ((fn-canon (canonical-sibling (or (caar attachment-alist-sorted) (car explicit-erasures)) wrld))) (and (transparent-fn-p fn-canon wrld) fn-canon))))) (er-let* ((wrld5 (if fn-tr (put-defattach-props fn-tr ctx wrld4 state) (value wrld4)))) (pprogn (let ((implicit-erasures (set-difference-eq erasures explicit-erasures))) (cond (implicit-erasures (observation ctx "The pre-existing attachment~#0~[ ~ is~/s are~] being removed for ~ function~#0~[~/s~] ~&0~@1~@2." implicit-erasures (cond (explicit-erasures (msg ", in addition to the ~ association~#0~[~/s~] ~ with nil provided ~ explicitly for ~&0" explicit-erasures)) (t "")) (cond (attachment-fns (msg ", before adding the ~ requested ~ attachment~#0~[~/s~]" attachment-fns)) (t "")))) (t state))) (install-event :attachments-recorded event-form 'defattach 0 ttree cltl-cmd nil ctx wrld5 state))))))))
defattach-systemmacro
(defmacro defattach-system (&whole form &rest args) (cond ((and (symbolp (car args)) (eql (length args) 2) (symbolp (cadr args))) `(local (defattach (,(CAR ARGS) ,(CADR ARGS)) :system-ok t))) ((symbolp (car args)) (er hard 'defattach-system "When the first argument of a defattach-system call is a symbol, ~ there must be exactly two arguments, both of them symbols. The ~ call ~x0 is thus illegal." form)) ((member-eq :system-ok args) (er hard 'defattach-system "The argument :system-ok is illegal for a defattach-system call. ~ Consider instead using defattach or removing :system-ok." form)) (t `(local (defattach ,@ARGS :system-ok t)))))
chk-return-last-entryfunction
(defun chk-return-last-entry (key val wrld) (declare (xargs :guard (plist-worldp wrld) :mode :program)) (cond ((or (ttag wrld) (global-val 'boot-strap-flg wrld)) (and (symbolp key) key (or (symbolp val) (and (consp val) (symbolp (car val)) (car val) (null (cdr val)))) (not (member-eq key '(progn mbe1-raw ec-call1-raw with-guard-checking1-raw))) (or (null val) (let ((val2 (if (symbolp val) val (car val)))) (getpropc val2 'macro-body nil wrld))) t)) (t nil)))
chk-return-last-entry-codafunction
(defun chk-return-last-entry-coda (key val wrld) (declare (xargs :guard (plist-worldp wrld) :mode :program)) (cond ((or (ttag wrld) (global-val 'boot-strap-flg wrld)) (cond ((member-eq key '(progn mbe1-raw ec-call1-raw with-guard-checking1-raw)) (msg "Note that the proposed key ~x0 for ~x1 is illegal because ~ it is given special treatment." key 'return-last-table)) ((and val (let ((val2 (if (symbolp val) val (car val)))) (and (not (getpropc val2 'macro-body nil wrld)) (msg "~|Note that the proposed value ~x0 for key ~x1 ~ in ~x2 is illegal because ~x3 is not the name ~ of a macro known to ACL2. See :DOC return-last ~ and (for the above point made explicitly) see ~ :DOC return-last-table." val key 'return-last-table val2))))) (t nil))) (t (msg "~|The error is simply that it is illegal to modify the ~ table, ~x0, unless there is an active trust tag. See :DOC ~ return-last and see :DOC return-last-table." 'return-last-table))))
other
(set-table-guard return-last-table (chk-return-last-entry key val world) :topic return-last :show t :coda (chk-return-last-entry-coda key val world))
defmacro-lastmacro
(defmacro defmacro-last (fn &key raw (top-level-ok 't)) (declare (xargs :guard (and (symbolp fn) (symbolp raw)))) (let ((raw (or raw (add-suffix fn "-RAW")))) `(progn (defmacro ,FN (x y) (list 'return-last (list 'quote ',RAW) x y)) (table return-last-table ',RAW ',(IF TOP-LEVEL-OK FN (LIST FN))))))
*fmt-control-defaults*constant
(defconst *fmt-control-defaults* (append *print-control-defaults* `((write-for-read t) (fmt-hard-right-margin ,*FMT-HARD-RIGHT-MARGIN-DEFAULT* set-fmt-hard-right-margin) (fmt-soft-right-margin ,*FMT-SOFT-RIGHT-MARGIN-DEFAULT* set-fmt-soft-right-margin) (iprint-soft-bound ,*IPRINT-SOFT-BOUND-DEFAULT*) (iprint-hard-bound ,*IPRINT-HARD-BOUND-DEFAULT*) (ppr-flat-right-margin ,(CDR (ASSOC-EQ 'PPR-FLAT-RIGHT-MARGIN *INITIAL-GLOBAL-TABLE*))) (current-package "ACL2") (iprint-ar (f-get-global 'iprint-ar state) set-iprint-ar) (evisc-hitp-without-iprint nil))))
*fixed-fmt-controls*constant
(defconst *fixed-fmt-controls* '(iprint-ar evisc-hitp-without-iprint))
fmt-control-bindings1function
(defun fmt-control-bindings1 (alist fmt-control-defaults-tail rawp) (cond ((endp fmt-control-defaults-tail) nil) (t (cons (let* ((trip (car fmt-control-defaults-tail)) (var (car trip))) (list* var `(let ((pair (assoc-eq ',VAR ,ALIST))) (cond (pair ,(COND ((MEMBER-EQ VAR *FIXED-FMT-CONTROLS*) `(ER HARD 'FMT-CONTROL-BINDINGS "The binding of ~x0 is illegal in ~ this context." ',VAR)) (T '(CDR PAIR)))) (t ,(CADR TRIP)))) (and (null rawp) (cddr trip)))) (fmt-control-bindings1 alist (cdr fmt-control-defaults-tail) rawp)))))
drop-cddrsfunction
(defun drop-cddrs (lst) (declare (xargs :guard (true-list-listp lst))) (cond ((endp lst) nil) (t (cons (list (caar lst) (cadar lst)) (drop-cddrs (cdr lst))))))
*fmt-control-defaults-raw*constant
(defconst *fmt-control-defaults-raw* (drop-cddrs *fmt-control-defaults*))
fmt-control-bindingsfunction
(defun fmt-control-bindings (alist rawp) (cond (alist (fmt-control-bindings1 alist *fmt-control-defaults* rawp)) (rawp *fmt-control-defaults-raw*) (t *fmt-control-defaults*)))
set-iprint-arfunction
(defun set-iprint-ar (iprint-ar state) (f-put-global 'iprint-ar (compress1 'iprint-ar iprint-ar) state))
override-global-evisc-tablefunction
(defun override-global-evisc-table (evisc-tuple state) (let ((evisc-table (table-alist 'evisc-table (w state)))) (cond ((null evisc-table) evisc-tuple) ((consp evisc-tuple) (cons (append (car evisc-tuple) (pairlis$ (strip-cars evisc-table) nil)) (cdr evisc-tuple))) (t (evisc-tuple nil nil (pairlis$ (strip-cars evisc-table) nil) nil)))))
block-iprint-arfunction
(defun block-iprint-ar (state) (let* ((iprint-ar (f-get-global 'iprint-ar state)) (elt-0 (aref1 'iprint-ar iprint-ar 0))) (pprogn (f-put-global 'iprint-ar (compress1 'iprint-ar (acons 0 (if (integerp elt-0) (cons elt-0 t) (if (cdr elt-0) elt-0 (cons (car elt-0) t))) (if (eql (caar iprint-ar) 0) (cdr iprint-ar) iprint-ar))) state) (mv t state))))
channel-to-stringmacro
(defmacro channel-to-string (form channel-var &optional extra-var fmt-controls outside-loop-p) (declare (xargs :guard (and (symbol-listp form) (symbolp channel-var) (symbolp extra-var) (symbolp fmt-controls) (not (eq 'result extra-var)) (not (eq 'state extra-var))))) (let* ((form0 (if (member-eq 'evisc-tuple form) `(let ((evisc-tuple (override-global-evisc-table evisc-tuple state))) ,FORM) form)) (body0 `(mv?-let (,@(AND EXTRA-VAR (LIST EXTRA-VAR)) state) ,FORM0 (mv-let (erp result state) (get-output-stream-string$ ,CHANNEL-VAR state) (mv nil (and (not erp) ,(IF EXTRA-VAR `(CONS ,EXTRA-VAR RESULT) 'RESULT)) state)))) (body1 (cond (outside-loop-p `(unwind-protect (state-free-global-let* ,(FMT-CONTROL-BINDINGS FMT-CONTROLS T) (progn (block-iprint-ar state) ,BODY0)) (when (open-output-channel-p ,CHANNEL-VAR :character state) (close-output-channel ,CHANNEL-VAR state)) (f-put-global 'iprint-ar (compress1 'iprint-ar (f-get-global 'iprint-ar state)) state))) (t `(acl2-unwind-protect "channel-to-string" (state-global-let* ,(FMT-CONTROL-BINDINGS FMT-CONTROLS NIL) (pprogn (mv-let (result state) (block-iprint-ar state) (declare (ignore result)) state) ,BODY0)) (pprogn (f-put-global 'iprint-ar (compress1 'iprint-ar (f-get-global 'iprint-ar state)) state) (cond ((open-output-channel-p ,CHANNEL-VAR :character state) (close-output-channel ,CHANNEL-VAR state)) (t state))) (f-put-global 'iprint-ar (compress1 'iprint-ar (f-get-global 'iprint-ar state)) state))))) (body `(mv-let (,CHANNEL-VAR state) (open-output-channel :string :character state) (cond (,CHANNEL-VAR ,BODY1) (t ,(COND (OUTSIDE-LOOP-P "ERROR: Failed to open string output channel to ~ report an error.") (T '(ER SOFT 'CHANNEL-TO-STRING "Implementation error: Unable to open a ~ channel to a string.")))))))) `(with-local-state (mv-let (erp result state) (with-live-state ,BODY) (declare (ignore erp)) ,(COND (EXTRA-VAR `(MV (CAR RESULT) (CDR RESULT))) (T 'RESULT))))))
*fmt-control-defaults-keys*constant
(defconst *fmt-control-defaults-keys* (strip-cars *fmt-control-defaults*))
fms-to-string-fnfunction
(defun fms-to-string-fn (str alist evisc-tuple fmt-control-alist) (declare (xargs :guard (and (stringp str) (character-alistp alist) (standard-evisc-tuplep evisc-tuple) (alistp fmt-control-alist) (alist-keys-subsetp fmt-control-alist *fmt-control-defaults-keys*)))) (channel-to-string (fms str alist chan-do-not-use-elsewhere state evisc-tuple) chan-do-not-use-elsewhere nil fmt-control-alist))
fms-to-stringmacro
(defmacro fms-to-string (str alist &key evisc-tuple fmt-control-alist) `(fms-to-string-fn ,STR ,ALIST ,EVISC-TUPLE ,FMT-CONTROL-ALIST))
fms!-to-string-fnfunction
(defun fms!-to-string-fn (str alist evisc-tuple fmt-control-alist) (declare (xargs :guard (and (stringp str) (character-alistp alist) (standard-evisc-tuplep evisc-tuple) (alistp fmt-control-alist) (alist-keys-subsetp fmt-control-alist *fmt-control-defaults-keys*)))) (channel-to-string (fms! str alist chan-do-not-use-elsewhere state evisc-tuple) chan-do-not-use-elsewhere nil fmt-control-alist))
fms!-to-stringmacro
(defmacro fms!-to-string (str alist &key evisc-tuple fmt-control-alist) `(fms!-to-string-fn ,STR ,ALIST ,EVISC-TUPLE ,FMT-CONTROL-ALIST))
fmt-to-string-fnfunction
(defun fmt-to-string-fn (str alist evisc-tuple fmt-control-alist) (declare (xargs :guard (and (stringp str) (character-alistp alist) (standard-evisc-tuplep evisc-tuple) (alistp fmt-control-alist) (alist-keys-subsetp fmt-control-alist *fmt-control-defaults-keys*)))) (channel-to-string (fmt str alist chan-do-not-use-elsewhere state evisc-tuple) chan-do-not-use-elsewhere col fmt-control-alist))
fmt-to-stringmacro
(defmacro fmt-to-string (str alist &key evisc-tuple fmt-control-alist) `(fmt-to-string-fn ,STR ,ALIST ,EVISC-TUPLE ,FMT-CONTROL-ALIST))
fmt!-to-string-fnfunction
(defun fmt!-to-string-fn (str alist evisc-tuple fmt-control-alist) (declare (xargs :guard (and (stringp str) (character-alistp alist) (standard-evisc-tuplep evisc-tuple) (alistp fmt-control-alist) (alist-keys-subsetp fmt-control-alist *fmt-control-defaults-keys*)))) (channel-to-string (fmt! str alist chan-do-not-use-elsewhere state evisc-tuple) chan-do-not-use-elsewhere col fmt-control-alist))
fmt!-to-stringmacro
(defmacro fmt!-to-string (str alist &key evisc-tuple fmt-control-alist) `(fmt!-to-string-fn ,STR ,ALIST ,EVISC-TUPLE ,FMT-CONTROL-ALIST))
fmt1-to-string-fnfunction
(defun fmt1-to-string-fn (str alist col evisc-tuple fmt-control-alist) (declare (xargs :guard (and (character-alistp alist) (stringp str) (standard-evisc-tuplep evisc-tuple) (alistp fmt-control-alist) (alist-keys-subsetp fmt-control-alist *fmt-control-defaults-keys*))) (type (unsigned-byte 60) col)) (channel-to-string (fmt1 str alist col chan-do-not-use-elsewhere state evisc-tuple) chan-do-not-use-elsewhere col fmt-control-alist))
fmt1-to-stringmacro
(defmacro fmt1-to-string (str alist col &key evisc-tuple fmt-control-alist) `(fmt1-to-string-fn ,STR ,ALIST ,COL ,EVISC-TUPLE ,FMT-CONTROL-ALIST))
fmt1!-to-string-fnfunction
(defun fmt1!-to-string-fn (str alist col evisc-tuple fmt-control-alist) (declare (xargs :guard (and (stringp str) (character-alistp alist) (standard-evisc-tuplep evisc-tuple) (alistp fmt-control-alist) (alist-keys-subsetp fmt-control-alist *fmt-control-defaults-keys*))) (type (unsigned-byte 60) col)) (channel-to-string (fmt1! str alist col chan-do-not-use-elsewhere state evisc-tuple) chan-do-not-use-elsewhere col fmt-control-alist))
fmt1!-to-stringmacro
(defmacro fmt1!-to-string (str alist col &key evisc-tuple fmt-control-alist) `(fmt1!-to-string-fn ,STR ,ALIST ,COL ,EVISC-TUPLE ,FMT-CONTROL-ALIST))
attachment-pairsfunction
(defun attachment-pairs (fns wrld acc) (cond ((endp fns) acc) (t (attachment-pairs (cdr fns) wrld (let ((pair (attachment-pair (car fns) wrld))) (cond (pair (cons pair acc)) (t acc)))))))
sibling-attachmentsfunction
(defun sibling-attachments (f wrld) (attachment-pairs (siblings f wrld) wrld nil))
ext-ancestors-attachments4function
(defun ext-ancestors-attachments4 (fns wrld fal) (cond ((endp fns) fal) (t (ext-ancestors-attachments4 (cdr fns) wrld (cond ((hons-get (car fns) fal) fal) (t (hons-acons (car fns) (sibling-attachments (car fns) wrld) fal)))))))
ext-ancestors-attachments3function
(defun ext-ancestors-attachments3 (components wrld fal) (cond ((endp components) fal) (t (ext-ancestors-attachments3 (cdr components) wrld (let ((anc (access attachment-component (car components) :ord-anc)) (path (access attachment-component (car components) :path))) (ext-ancestors-attachments4 (if path (cons (car path) anc) anc) wrld fal))))))
ext-ancestors-attachments2function
(defun ext-ancestors-attachments2 (canon-gs arfal wrld canon-gs-fal fal) (cond ((endp canon-gs) fal) (t (let ((g (car canon-gs))) (cond ((hons-get g canon-gs-fal) (ext-ancestors-attachments2 (cdr canon-gs) arfal wrld canon-gs-fal fal)) (t (let ((rec (cdr (hons-get g arfal)))) (ext-ancestors-attachments2 (cdr canon-gs) arfal wrld (hons-acons g fal canon-gs-fal) (let ((fal (hons-acons g (sibling-attachments (car canon-gs) wrld) fal))) (cond (rec (ext-ancestors-attachments3 (access attachment rec :components) wrld fal)) (t fal)))))))))))
canonical-cdrsfunction
(defun canonical-cdrs (alist wrld acc) (cond ((endp alist) acc) (t (canonical-cdrs (cdr alist) wrld (cons (canonical-sibling (cdar alist) wrld) acc)))))
ext-ancestors-attachments1function
(defun ext-ancestors-attachments1 (fns canon-gs arfal wrld fal) (cond ((endp fns) (ext-ancestors-attachments2 canon-gs arfal wrld 'ext-ancestors-attachments2 fal)) ((hons-get (car fns) fal) (ext-ancestors-attachments1 (cdr fns) canon-gs arfal wrld fal)) (t (let* ((alist (sibling-attachments (car fns) wrld)) (canon-gs (cond ((null alist) canon-gs) (t (append (canonical-cdrs alist wrld nil) canon-gs))))) (ext-ancestors-attachments1 (append (canonical-ancestors (car fns) wrld nil) (cdr fns)) canon-gs arfal wrld (hons-acons (car fns) alist fal))))))
attachment-records-falfunction
(defun attachment-records-fal (attachment-records fal) (cond ((endp attachment-records) fal) (t (attachment-records-fal (cdr attachment-records) (hons-acons (access attachment (car attachment-records) :g) (car attachment-records) fal)))))
ext-ancestors-attachmentsfunction
(defun ext-ancestors-attachments (f wrld) (let ((g (canonical-sibling f wrld))) (ext-ancestors-attachments1 (cons g (canonical-ancestors g wrld nil)) nil (attachment-records-fal (global-val 'attachment-records wrld) :attachment-records-fal) wrld f)))
ext-anc-attachment-missingfunction
(defun ext-anc-attachment-missing (alist wrld) (cond ((endp alist) nil) ((eq (cdar alist) (cdr (attachment-pair (caar alist) wrld))) (ext-anc-attachment-missing (cdr alist) wrld)) (t (caar alist))))
ext-anc-attachments-valid-p-1function
(defun ext-anc-attachments-valid-p-1 (fns alist wrld) (cond ((endp fns) t) ((or (assoc-eq (car fns) alist) (not (attachment-pair (car fns) wrld))) (ext-anc-attachments-valid-p-1 (cdr fns) alist wrld)) (t nil)))
ext-anc-attachments-valid-pfunction
(defun ext-anc-attachments-valid-p (fns ext-anc-attachments special-name wrld acc) (cond ((endp fns) acc) ((eq (car fns) special-name) (if (or (hons-get 'apply$-userfn ext-anc-attachments) (hons-get 'badge-userfn ext-anc-attachments)) special-name (ext-anc-attachments-valid-p (cdr fns) ext-anc-attachments special-name wrld acc))) (t (let* ((f (car fns)) (alist (cdr (hons-get f ext-anc-attachments))) (missing (ext-anc-attachment-missing alist wrld))) (or missing (ext-anc-attachments-valid-p (cdr fns) ext-anc-attachments special-name wrld (and acc (ext-anc-attachments-valid-p-1 (siblings f wrld) alist wrld))))))))
regenerate-tau-database-fn0function
(defun regenerate-tau-database-fn0 (user-auto-modep auto-modep ens trips ctx wrld state) (cond ((endp trips) (value wrld)) ((eq (cadr (car trips)) 'formals) (regenerate-tau-database-fn0 user-auto-modep auto-modep ens (cdr trips) ctx (tau-visit-function-introduction (car (car trips)) wrld) state)) ((and (eq (car (car trips)) 'event-landmark) (eq (cadr (car trips)) 'global-value)) (cond ((eq (access-event-tuple-type (cddr (car trips))) 'exit-boot-strap-mode) (regenerate-tau-database-fn0 user-auto-modep user-auto-modep ens (cdr trips) ctx wrld state)) (t (er-let* ((wrld1 (tau-visit-event nil (access-event-tuple-type (cddr (car trips))) (access-event-tuple-namex (cddr (car trips))) auto-modep ens ctx wrld state))) (regenerate-tau-database-fn0 user-auto-modep auto-modep ens (cdr trips) ctx wrld1 state))))) (t (value (er hard 'regenerate-tau-database-fn0 "Collect-tau-relevant-triples collected an unrecognized ~ property! We expected to see fn FORMALS and EVENT-LANDMARK ~ GLOBAL-VALUE triples, but we see the triple ~x0." (car trips))))))
regenerate-tau-database-fn1function
(defun regenerate-tau-database-fn1 (boot-strap-auto-modep user-auto-modep ens ctx wrld state) (regenerate-tau-database-fn0 user-auto-modep boot-strap-auto-modep ens (collect-tau-relevant-triples wrld nil) ctx (initialize-tau-preds *primitive-monadic-booleans* (initialize-tau-globals wrld)) state))
regenerate-tau-database-fnfunction
(defun regenerate-tau-database-fn (state event-form) (when-logic "REGENERATE-TAU-DATABASE" (with-ctx-summarized "( REGENERATE-TAU-DATABASE)" (let* ((wrld (w state)) (event-form (or event-form '(regenerate-tau-database))) (boot-strap-auto-modep (cdar *tau-status-boot-strap-settings*)) (user-auto-modep (tau-auto-modep wrld)) (ens (ens state))) (er-let* ((wrld1 (regenerate-tau-database-fn1 boot-strap-auto-modep user-auto-modep ens ctx wrld state)) (val (install-event t event-form 'regenerate-tau-database 0 nil nil :protect nil wrld1 state))) (value t))))))
rational-to-decimal-stringfunction
(defun rational-to-decimal-string (x state) (declare (xargs :mode :program :stobjs state :guard (rationalp x))) (mv-let (channel state) (open-output-channel :string :character state) (pprogn (print-rational-as-decimal x channel state) (er-let* ((str (get-output-stream-string$ channel state nil))) (pprogn (close-output-channel channel state) (value str))))))
defundmacro
(defmacro defund (&rest def) (declare (xargs :guard (and (true-listp def) (symbolp (car def)) (symbol-listp (cadr def))))) `(with-output :stack :push :off :all (progn (with-output :stack :pop (defun ,@DEF)) ,@(AND (NOT (PROGRAM-DECLARED-P DEF)) `((WITH-OUTPUT :STACK :POP :OFF SUMMARY (IN-THEORY (DISABLE ,(CAR DEF)))))) (value-triple ',(EVENT-KEYWORD-NAME 'DEFUND (CAR DEF)) :on-skip-proofs t))))
make-event-ctxfunction
(defun make-event-ctx (event-form) (msg "( MAKE-EVENT ~@0~@1)" (tilde-@-abbreviate-object-phrase (cadr event-form)) (if (cddr event-form) " ..." "")))
with-hcomp-bindings-protected-evalmacro
(defmacro with-hcomp-bindings-protected-eval (form) form)
protected-evalfunction
(defun protected-eval (form on-behalf-of ctx state aok) (let ((original-wrld (w state))) (state-global-let* ((in-local-flg nil) (ld-always-skip-top-level-locals nil)) (protect-system-state-globals (er-let* ((result (with-hcomp-bindings-protected-eval (trans-eval-default-warning form ctx state aok)))) (let* ((new-kpa (known-package-alist state)) (new-ttags-seen (global-val 'ttags-seen (w state))) (stobjs-out (car result)) (vals (cdr result)) (safep (equal stobjs-out '(nil)))) (cond (safep (value (list* vals new-kpa new-ttags-seen))) ((or (null (cdr stobjs-out)) (not (eq (caddr stobjs-out) 'state)) (member-eq nil (cdddr stobjs-out))) (er soft ctx "The form ~x0 was expected to return a result that is ~ either a single ordinary value or else is a tuple (mv ~ erp val state stobj1 stobj2 ... stobjk) for some k >= ~ 0. But the shape of that result was ~x1." form (prettyify-stobjs-out stobjs-out))) ((car vals) (cond ((eq on-behalf-of :quiet!) (silent-error state)) ((stringp (car vals)) (er soft ctx (car vals))) ((tilde-@p (car vals)) (er soft ctx "~@0" (car vals))) ((eq on-behalf-of :quiet) (silent-error state)) (t (er soft ctx "Error in MAKE-EVENT ~@0from expansion of:~| ~y1" (cond (on-behalf-of (msg "on behalf of~| ~y0~|" on-behalf-of)) (t "")) form)))) (t (pprogn (set-w! original-wrld state) (value (list* (cadr vals) new-kpa new-ttags-seen)))))))))))
make-event-debug-prefunction
(defun make-event-debug-pre (depth form on-behalf-of state) (fms "~x0> Expanding for MAKE-EVENT~@1~| ~y2~|" (list (cons #\0 depth) (cons #\1 (if (and on-behalf-of (not (member-eq on-behalf-of '(:quiet :quiet!)))) (msg " on behalf of~| ~Y01:" on-behalf-of (term-evisc-tuple nil state)) ":")) (cons #\2 form)) (proofs-co state) state nil))
make-event-debug-postfunction
(defun make-event-debug-post (debug-depth expansion0 state) (fms "<~x0 Returning MAKE-EVENT expansion:~| ~Y12~|" (list (cons #\0 debug-depth) (cons #\1 expansion0) (cons #\2 (term-evisc-tuple nil state))) (proofs-co state) state nil))
other
(defattach always-do-proofs-during-make-event-expansion constant-nil-function-arity-0)
do-proofs?macro
(defmacro do-proofs? (do-proofsp use-always-do-proofs form) `(if ,(IF USE-ALWAYS-DO-PROOFS `(OR ,DO-PROOFSP (LET ((FLG (ALWAYS-DO-PROOFS-DURING-MAKE-EVENT-EXPANSION))) (AND FLG (OR (EQ FLG :ALL) (NOT (EQ (LD-SKIP-PROOFSP STATE) 'INCLUDE-BOOK)))))) DO-PROOFSP) (state-global-let* ((ld-skip-proofsp nil)) ,FORM) ,FORM))
make-event-fn2function
(defun make-event-fn2 (expansion0 whole-form in-encapsulatep check-expansion wrld ctx state) (mv-let (do-proofsp expansion0) (case-match expansion0 ((':do-proofs x) (mv (ld-skip-proofsp state) x)) (& (mv nil expansion0))) (er-let* ((expansion1a (do-proofs? check-expansion t (chk-embedded-event-form expansion0 whole-form wrld ctx state (primitive-event-macros) (f-get-global 'in-local-flg state) in-encapsulatep nil))) (expansion1b (value (or expansion1a *local-value-triple-elided*))) (stobjs-out-and-raw-result (do-proofs? do-proofsp nil (trans-eval-default-warning expansion1b ctx state t)))) (let ((raw-result (cdr stobjs-out-and-raw-result))) (cond ((car raw-result) (silent-error state)) (t (let ((expansion1 (if (f-get-global 'boot-strap-flg state) expansion1b (make-include-books-absolute expansion1b (cbd) nil (primitive-event-macros) nil ctx state)))) (value (list* expansion1 (car stobjs-out-and-raw-result) (cadr raw-result))))))))))
make-event-fn2-lstfunction
(defun make-event-fn2-lst (expansion-lst whole-form in-encapsulatep check-expansion on-behalf-of wrld ctx state) (cond ((atom expansion-lst) (cond ((member-eq on-behalf-of '(:quiet :quiet!)) (silent-error state)) (t (er soft ctx "Evaluation failed for all expansions.")))) (t (pprogn (cond ((f-get-global 'make-event-debug state) (fms "Attempting evaluation of next expansion:~|~Y01" (list (cons #\0 (car expansion-lst)) (cons #\1 (abbrev-evisc-tuple state))) (proofs-co state) state nil)) (t state)) (mv-let (erp val state) (make-event-fn2 (car expansion-lst) whole-form in-encapsulatep check-expansion wrld ctx state) (cond (erp (make-event-fn2-lst (cdr expansion-lst) whole-form in-encapsulatep check-expansion on-behalf-of wrld ctx state)) (t (value val))))))))
make-event-fn1function
(defun make-event-fn1 (expansion0 whole-form in-encapsulatep check-expansion on-behalf-of wrld ctx state) (cond ((and (consp expansion0) (eq (car expansion0) :or)) (state-global-let* ((cert-data nil)) (make-event-fn2-lst (cdr expansion0) whole-form in-encapsulatep check-expansion on-behalf-of wrld ctx state))) (t (make-event-fn2 expansion0 whole-form in-encapsulatep check-expansion wrld ctx state))))
ultimate-expansionfunction
(defun ultimate-expansion (x) (case-match x (('make-event & . kwd-alist) (let ((exp (cadr (assoc-keyword :expansion? kwd-alist)))) (cond ((and exp (not (cadr (assoc-keyword :check-expansion kwd-alist)))) (ultimate-expansion exp)) (t x)))) (& (mv-let (w y) (destructure-expansion x) (cond (w (rebuild-expansion w (ultimate-expansion y))) (t x))))))
make-event-fnfunction
(defun make-event-fn (form expansion? check-expansion on-behalf-of save-event-data whole-form state) (let ((ctx (make-event-ctx whole-form))) (with-ctx-summarized ctx (cond ((and (eq (cert-op state) :convert-pcert) (not (f-get-global 'in-local-flg state)) (not (consp check-expansion)) (not expansion?) (eql (f-get-global 'make-event-debug-depth state) 0)) (er soft ctx "Implementation error: You should not be seeing this message! ~ Please contact the ACL2 implementors.~|~%Make-event expansion is ~ illegal during the Convert procedure of provisional certification ~ (unless :check-expansion is supplied a consp argument or ~ :expansion? is supplied a non-nil argument). The form ~x0 is ~ thus illegal. The use of a .acl2x file can sometimes solve this ~ problem. See :DOC provisional-certification." whole-form)) ((not (or (eq check-expansion nil) (eq check-expansion t) (consp check-expansion))) (er soft ctx "The check-expansion flag of make-event must be t, nil, or a cons ~ pair. The following check-expansion flag is thus illegal: ~x0. ~ See :DOC make-event." check-expansion)) ((and expansion? (consp check-expansion)) (er soft ctx "It is illegal to supply a non-nil value for the keyword argument ~ :EXPANSION? of make-event when keyword argument :CHECK-EXPANSION ~ is give a value other than T or NIL. If you think you have a ~ reason why such a combination should be supported, please contact ~ the ACL2 implementors.")) (t (revert-world-on-error (let* ((make-event-debug (f-get-global 'make-event-debug state)) (new-debug-depth (1+ (f-get-global 'make-event-debug-depth state))) (wrld (w state))) (er-let* ((expansion0/new-kpa/new-ttags-seen (pprogn (if make-event-debug (make-event-debug-pre new-debug-depth form on-behalf-of state) state) (state-global-let* ((make-event-debug-depth new-debug-depth)) (cond ((and expansion? (eq (ld-skip-proofsp state) 'include-book) (not (f-get-global 'including-uncertified-p state)) (assert$ (iff check-expansion (eq check-expansion t)) (not (eq check-expansion t)))) (value (list* expansion? nil nil))) (t (do-proofs? (or check-expansion (eq (cert-op state) :create-pcert)) t (protected-eval form on-behalf-of ctx state t))))))) (expansion0 (value (car expansion0/new-kpa/new-ttags-seen))) (new-kpa (value (cadr expansion0/new-kpa/new-ttags-seen))) (new-ttags-seen (value (cddr expansion0/new-kpa/new-ttags-seen))) (need-event-landmark-p (pprogn (if make-event-debug (make-event-debug-post new-debug-depth expansion0 state) state) (cond ((or (null new-ttags-seen) (equal new-ttags-seen (global-val 'ttags-seen wrld))) (value nil)) (t (pprogn (set-w 'extension (global-set 'ttags-seen new-ttags-seen wrld) state) (value t)))))) (wrld0 (value (w state))) (expansion1/stobjs-out/result (make-event-fn1 expansion0 whole-form (in-encapsulatep (global-val 'embedded-event-lst wrld0) nil) check-expansion on-behalf-of wrld0 ctx state))) (let* ((expansion1 (car expansion1/stobjs-out/result)) (stobjs-out (cadr expansion1/stobjs-out/result)) (result (cddr expansion1/stobjs-out/result)) (expansion2 (cond ((f-get-global 'last-make-event-expansion state) (mv-let (wrappers base) (destructure-expansion expansion1) (declare (ignore base)) (rebuild-expansion wrappers (ultimate-expansion (f-get-global 'last-make-event-expansion state))))) (t (ultimate-expansion expansion1))))) (assert$ (equal stobjs-out *error-triple-sig*) (let ((expected-expansion (if (consp check-expansion) check-expansion (and (eq (ld-skip-proofsp state) 'include-book) check-expansion expansion?)))) (cond ((and expected-expansion (not (equal expected-expansion expansion2)) (not (equal (ultimate-expansion expected-expansion) expansion2))) (er soft ctx "The current MAKE-EVENT expansion differs from ~ the expected (original or specified) expansion. ~ ~ See :DOC make-event.~|~%~|~%Make-event ~ argument:~|~%~y0~|~%Expected ~ expansion:~|~%~y1~|~%Current expansion:~|~%~y2~|" form expected-expansion expansion2)) (t (let ((actual-expansion (cond ((or (consp check-expansion) (equal expansion? expansion2) (equal (ultimate-expansion expansion?) expansion2)) nil) (check-expansion (assert$ (eq check-expansion t) (list* 'make-event form :check-expansion expansion2 (and on-behalf-of `(:on-behalf-of ,ON-BEHALF-OF))))) (t expansion2)))) (er-progn (cond ((f-get-global 'boot-strap-flg state) (pprogn (if (in-encapsulatep (global-val 'embedded-event-lst (w state)) nil) (er soft ctx "Illegal form:~|~x0~|~%Make-event ~ is illegal inside an encapsulate ~ when in the boot-strap. See the ~ relevant discussion in ~ make-event-fn." form) (value nil)))) (t (pprogn (f-put-global 'last-make-event-expansion actual-expansion state) (value nil)))) (pprogn (cond ((f-get-global 'make-event-debug state) (fms "Saving make-event replacement into state ~ global 'last-make-event-expansion (debug ~ level ~ ~x0):~|Form:~|~X13~|Expansion:~|~X23~|" (list (cons #\0 new-debug-depth) (cons #\1 form) (cons #\2 actual-expansion) (cons #\3 (abbrev-evisc-tuple state))) (proofs-co state) state nil)) (t state)) (er-progn (cond (need-event-landmark-p (maybe-add-event-landmark state)) (t (value nil))) (value result))))))))))))))) :event-type (if save-event-data 'make-event-save-event-data 'make-event))))
trans*-fn1function
(defun trans*-fn1 (iter transp quiet make-event-p form ctx wrld state) (cond ((and (consp form) (member-eq (car form) *destructure-expansion-wrappers*)) (pprogn (cond (quiet state) (t (fms "Iteration ~x0 is dropping the ~x1 wrapper:~|~X23~|----------~|" (list (cons #\0 iter) (cons #\1 (car form)) (cons #\2 (car (last form))) (cons #\3 (term-evisc-tuple nil state))) (standard-co state) state nil))) (value (cons t (car (last form)))))) (t (let* ((make-event-case (and make-event-p (consp form) (eq (car form) 'make-event) (consp (cdr form)) (keyword-value-listp (cddr form)))) (macrop (and (not make-event-case) (consp form) (symbolp (car form)) (getpropc (car form) 'macro-body)))) (er-let* ((next (cond (make-event-case (er-let* ((expansion0/new-kpa/new-ttags-seen (revert-world-on-error (protected-eval (cadr form) (cadr (assoc-keyword :on-behalf-of (cddr form))) ctx state t)))) (value (car expansion0/new-kpa/new-ttags-seen)))) (macrop (macroexpand1 form ctx state)) (transp (translate form t nil t ctx wrld state)) (t (silent-error state))))) (pprogn (cond (quiet state) (t (fms "Iteration ~x0 produces (by ~#1~[expansion~/make-event ~ expansion~/translation~]):~|~X23~|----------~|" (list (cons #\0 iter) (cons #\1 (if macrop 0 (if make-event-case 1 2))) (cons #\2 next) (cons #\3 (term-evisc-tuple nil state))) (standard-co state) state nil))) (value (cons (or make-event-case macrop) next))))))))
trans*-fn-iterfunction
(defun trans*-fn-iter (iter bound transp quiet make-event-p names-fal form ctx wrld state) (declare (xargs :guard (and (posp iter) (or (eq bound t) (posp bound))))) (cond ((or (and (not (eq bound t)) (> iter bound)) (and (consp form) (not (and make-event-p (eq (car form) 'make-event))) (not (member-eq (car form) *destructure-expansion-wrappers*)) (hons-get (car form) names-fal))) (value (if quiet form :invisible))) (t (mv-let (erp flg/next state) (trans*-fn1 iter transp quiet make-event-p form ctx wrld state) (let ((flg (car flg/next)) (next (cdr flg/next))) (cond (erp (value (if quiet form :invisible))) ((and (eq (car form) 'make-event) (and (consp next) (eq (car next) :or))) (value (if quiet next :invisible))) ((not flg) (value (if quiet next :invisible))) (t (trans*-fn-iter (1+ iter) bound transp quiet make-event-p names-fal next ctx wrld state))))))))
trans*-fnfunction
(defun trans*-fn (bound form make-event-p ctx state) (mv-let (reps0 quiet) (cond ((consp bound) (cond ((cdr bound) (mv :error nil)) (t (mv (car bound) t)))) (t (mv bound nil))) (mv-let (reps transp) (cond ((integerp reps0) (cond ((< reps0 0) (mv (- reps0) nil)) ((> reps0 0) (mv reps0 t)) (t (mv :error nil)))) ((eq reps0 nil) (mv t nil)) ((eq reps0 t) (mv t t)) (t (mv :error nil))) (cond ((eq reps :error) (er soft ctx "Illegal first argument for trans*, ~x0. See :DOC trans*." bound)) ((and (consp form) (not (and make-event-p (eq (car form) 'make-event))) (not (member-eq (car form) *destructure-expansion-wrappers*)) (hons-get (car form) *syms-not-callable-in-code-fal*)) (er soft ctx "Nothing to do: The input form is already the final result.")) (t (trans*-fn-iter 1 reps transp quiet make-event-p *syms-not-callable-in-code-fal* form ctx (w state) state))))))
get-check-invariant-riskfunction
(defun get-check-invariant-risk (state) (let ((pair (assoc-eq :check-invariant-risk (table-alist 'acl2-defaults-table (w state)))) (cir (f-get-global 'check-invariant-risk state))) (cond (pair (case (cdr pair) ((:error :clear) cir) ((:warning) (if (eq cir :error) :warning cir)) ((t) (if (eq cir nil) nil t)) (otherwise nil))) (t cir))))
set-check-invariant-riskmacro
(defmacro set-check-invariant-risk (x &optional table-p) (declare (xargs :guard (booleanp table-p))) (cond (table-p `(with-output :off :all :on (observation error) (progn (table acl2-defaults-table :check-invariant-risk ,X) (make-event (pprogn (if (and (not (eq ,X (get-check-invariant-risk state))) (not (eq ,X :clear))) (observation 'set-check-invariant-risk "No change is being made in the value ~ computed by ~x0. This happens when ~ the value of state global ~ 'check-invariant-risk is less than ~ the new table value; see :DOC ~ set-check-invariant-risk." '(get-check-invariant-risk state)) state) (value '(value-triple ,X))) :check-expansion t)))) ((and x (member-eq x *check-invariant-risk-values*)) `(set-check-invariant-risk-fn ,X state)) (t `(cond ((not (member-eq ,X '(t nil :error :warning))) (er soft 'check-invariant-risk "Illegal value for ~x0: ~x1" 'check-invariant-risk ',X)) (t (er-progn (with-ubt! (with-output :off :all (with-output :on (error warning warning!) (progn (defttag :set-check-invariant-risk) (progn! (set-check-invariant-risk-fn ,X state)))))) (value nil)))))))
set-check-invariant-risk-fnfunction
(defun set-check-invariant-risk-fn (x state) (declare (xargs :guard (member-eq x *check-invariant-risk-values*))) (progn$ (mbt (and (member-eq x *check-invariant-risk-values*) t)) (cond ((and (null x) (f-get-global 'check-invariant-risk state) (not (ttag (w state)))) (er soft 'set-check-invariant-risk "There must be an active trust tag to set '~x0 to ~x1." 'check-invariant-risk nil)) (t (pprogn (f-put-global 'check-invariant-risk x state) (if (not (eq x (get-check-invariant-risk state))) (observation 'set-check-invariant-risk "No change is being made in the value ~ computed by ~x0, because the new value ~ of state global 'check-invariant-risk ~ is greater than the table value; see ~ :DOC set-check-invariant-risk." '(get-check-invariant-risk state)) state) (value x))))))
get-register-invariant-riskfunction
(defun get-register-invariant-risk (state) (get-register-invariant-risk-world (w state)))
set-register-invariant-riskmacro
(defmacro set-register-invariant-risk (val) (declare (xargs :guard (booleanp val))) `(with-output :off (event summary) (progn (table acl2-defaults-table :register-invariant-risk ,VAL) (table acl2-defaults-table :register-invariant-risk))))
sort-fboundpsfunction
(defun sort-fboundps (lst wrld ps ls ms) (declare (xargs :mode :program)) (cond ((endp lst) (mv ps ls ms)) (t (let ((s (car lst))) (cond ((getpropc s 'macro-body nil wrld) (sort-fboundps (cdr lst) wrld ps ls (cons s ms))) ((member (symbol-class s wrld) '(:ideal :common-lisp-compliant) :test 'eq) (sort-fboundps (cdr lst) wrld ps (cons s ls) ms)) ((not (eq (getpropc s 'formals t wrld) t)) (sort-fboundps (cdr lst) wrld (cons s ps) ls ms)) (t (sort-fboundps (cdr lst) wrld ps ls ms)))))))
other
(partial-encapsulate (((doppelganger-badge-userfn *) => *)) nil (logic) (local (defun doppelganger-badge-userfn (fn) (declare (xargs :mode :logic)) (declare (ignore fn)) nil)) (defthm doppelganger-badge-userfn-type (or (null (doppelganger-badge-userfn fn)) (let ((x (doppelganger-badge-userfn fn))) (and (weak-apply$-badge-p x) (natp (access apply$-badge x :arity)) (natp (access apply$-badge x :out-arity)) (or (eq (access apply$-badge x :ilks) t) (and (true-listp (access apply$-badge x :ilks)) (equal (len (access apply$-badge x :ilks)) (access apply$-badge x :arity)) (not (all-nils (access apply$-badge x :ilks))) (subsetp (access apply$-badge x :ilks) '(nil :fn :expr))))))) :rule-classes nil))
other
(partial-encapsulate (((doppelganger-apply$-userfn * *) => *)) nil (logic) (local (defun doppelganger-apply$-userfn (fn args) (declare (xargs :mode :logic)) (declare (ignore fn args)) nil)) (defthm doppelganger-apply$-userfn-takes-arity-args (implies (doppelganger-badge-userfn fn) (equal (doppelganger-apply$-userfn fn args) (doppelganger-apply$-userfn fn (take (caddr (doppelganger-badge-userfn fn)) args)))) :rule-classes nil))
apply$-lambda-logicalmacro
(defmacro apply$-lambda-logical (fn args) (declare (xargs :guard (symbolp fn))) `(ev$ (lambda-object-body ,FN) (ec-call (pairlis$ (lambda-object-formals ,FN) ,ARGS))))
our-quote-macromacro
(defmacro our-quote-macro (x) (list 'quote x))
value-triple-fn1function
(defun value-triple-fn1 (form check stobjs-out0 ctx state) (declare (xargs :guard t)) (er-let* ((stobjs-out0 (value (or stobjs-out0 '(nil)))) (stobjs-out/replaced-val (cond ((equal stobjs-out0 '(nil)) (cond ((or (eq form t) (eq form nil) (keywordp form)) (mv nil `((nil) . ,FORM) state)) ((and (consp form) (eq (car form) 'quote) (consp (cdr form)) (null (cddr form))) (mv nil `((nil) . ,(CADR FORM)) state)) (t (trans-eval `(value ,FORM) ctx state t)))) (t (revert-world (state-global-let* ((ttags-allowed nil)) (protect-system-state-globals (if (eq stobjs-out0 :auto) (trans-eval form ctx state t) (trans-eval-no-warning form ctx state t))))))))) (let* ((stobjs-out (car stobjs-out/replaced-val)) (replaced-val (cdr stobjs-out/replaced-val)) (error-triple-p (equal stobjs-out *error-triple-sig*)) (error-triple-p+ (or error-triple-p (equal stobjs-out *error-triple-df-sig*))) (val0 (cond (error-triple-p+ (cadr replaced-val)) ((cdr stobjs-out) (car replaced-val)) (t replaced-val)))) (cond ((not (or (eq stobjs-out0 :auto) (equal stobjs-out stobjs-out0) (and (equal stobjs-out0 '(nil)) error-triple-p))) (flet ((output-msg (stobjs-out) (cond ((equal stobjs-out '(nil)) "an ordinary (non-stobj, non-df) value") ((null (cdr stobjs-out)) (cond ((eq (car stobjs-out) :df) "a single :DF value") (t (msg "a single stobj value, ~x0" (car stobjs-out))))) (t (msg "multiple values of shape ~x0" (cons 'mv stobjs-out)))))) (er soft ctx "Expected ~@0, but got ~@1.~@2" (output-msg stobjs-out0) (if (and (equal stobjs-out0 '(nil)) (= (length stobjs-out) 3) (eq (caddr stobjs-out) 'state)) (output-msg (list (cadr stobjs-out))) (output-msg stobjs-out)) (let ((stobjs (if (equal stobjs-out0 '(nil)) nil (collect-non-nil-df stobjs-out)))) (cond ((null stobjs) "") (t (msg " Note that in spite of the error, evaluation ~ may have modified the stobj~#0~[~/s~] ~&0." stobjs))))))) ((and error-triple-p+ (car replaced-val)) (er soft ctx "Evaluation failed: Result was of the form (mv t _ state). See ~ :DOC error-triple." (car replaced-val))) (check (cond ((and (car stobjs-out) (not (eq (car stobjs-out) :df))) (er soft ctx "Ill-formed assertion: The~@0 value returned is ~@1." (if (cdr stobjs-out) " first" "") (if (eq (car stobjs-out) 'state) "the ACL2 state" (msg "the stobj, ~x0" (car stobjs-out))))) (val0 (value :passed)) ((tilde-@p check) (er soft ctx "Assertion failed:~%~@0~|" check)) (t (er soft ctx "Assertion failed on form:~%~x0~|" form)))) ((and (car stobjs-out) (not (eq (car stobjs-out) :df))) (value (car stobjs-out))) (t (value val0))))))
chk-value-triplefunction
(defun chk-value-triple (on-skip-proofs check safe-mode stobjs-out ctx state) (cond ((not (or (booleanp on-skip-proofs) (eq on-skip-proofs :interactive))) (er soft ctx "The value of keyword argument :ON-SKIP-PROOFS must be Boolean or ~ :INTERACTIVE, but ~x0 is not." on-skip-proofs)) ((not (or (booleanp check) (msgp check))) (er soft ctx "The value of keyword argument :CHECK must be Boolean or satisfy the ~ predicate msgp. The value ~x0 is thus illegal." check)) ((not (or (booleanp safe-mode) (eq safe-mode :same))) (er soft ctx "The value of keyword argument :SAFE-MODE must be Boolean, but ~x0 is ~ not." safe-mode)) ((not (or (eq stobjs-out :auto) (symbol-listp stobjs-out))) (er soft ctx "The value of keyword argument :STOBJS-OUT must either be :AUTO or ~ satisfy symbol-listp. The value ~x0 is thus illegal." stobjs-out)) (t (value nil))))
value-triple-fnfunction
(defun value-triple-fn (form on-skip-proofs check safe-mode stobjs-out ctx state) (declare (xargs :guard t)) (er-progn (chk-value-triple on-skip-proofs check safe-mode stobjs-out ctx state) (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)) ((or (eq safe-mode :same) (eq safe-mode (f-get-global 'safe-mode state))) (value-triple-fn1 form check stobjs-out ctx state)) (t (state-global-let* ((safe-mode (if safe-mode t nil))) (value-triple-fn1 form check stobjs-out ctx state))))))
collect-non-redundantfunction
(defun collect-non-redundant (events wrld) (cond ((endp events) nil) ((and (true-listp (car events)) (symbolp (cadr (car events))) (equal (get-event (cadr (car events)) wrld) (car events))) (collect-non-redundant (cdr events) wrld)) (t (cons (car events) (collect-non-redundant (cdr events) wrld)))))
remove-var-from-type-dclsfunction
(defun remove-var-from-type-dcls (var type-dcls) (cond ((endp type-dcls) nil) (t (let* ((d (car type-dcls)) (tp (car d)) (vars (remove-eq var (cdr d)))) (cond ((null vars) (remove-var-from-type-dcls var (cdr type-dcls))) (t (cons `(type ,TP ,@VARS) (remove-var-from-type-dcls var (cdr type-dcls)))))))))
memoize-partial-deffunction
(defun memoize-partial-def (fn fn-limit fn-limit-formals flet-bindings wrld) (cond ((member-eq 'state fn-limit-formals) :state) ((collect-user-stobjs (stobjs-out fn-limit wrld)) (cons :stobjs (collect-user-stobjs (stobjs-out fn-limit wrld)))) (t (let* ((ev (cltl-def-from-name fn-limit wrld)) (limit (assert$ (consp fn-limit-formals) (car (last fn-limit-formals)))) (def (case-match ev (('defun !fn-limit !fn-limit-formals . &) (cdr ev)) (('mutual-recursion . defs) (let* ((def (assoc-eq fn-limit (strip-cdrs defs)))) (and (equal (cadr def) fn-limit-formals) def))) (& nil)))) (cond ((null def) :definition-not-found) (t (let* ((fn-limit-body (car (last ev))) (rest (case-match fn-limit-body (('if ('zp !limit) & ('let ((!limit ('1- !limit))) . rest)) rest) (('cond (('zp !limit) &) (t ('let ((!limit ('1- !limit))) . rest))) rest) (& nil)))) (and rest (let* ((fn-formals (butlast fn-limit-formals 1)) (body (car (last rest))) (dcls (butlast (cddr def) 1)) (type-dcls (remove-var-from-type-dcls limit (fetch-dcl-field 'type dcls)))) `(defun ,FN ,FN-FORMALS (declare (ignorable ,@FN-FORMALS)) ,@(AND TYPE-DCLS `((DECLARE ,@TYPE-DCLS))) (flet ,FLET-BINDINGS (declare (inline ,FN-LIMIT)) (let ((,LIMIT 0)) (declare (ignorable ,LIMIT)) ,BODY))))))))))))
memoize-partial-declarefunction
(defun memoize-partial-declare (fn-limit limit wrld) (let* ((ev (get-event fn-limit wrld)) (def (case-match ev (('defun !fn-limit . &) (cdr ev)) (('mutual-recursion . defs) (assoc-eq fn-limit (strip-cdrs defs))) (& (er hard 'memoize-partial-declare "Implementation error: Unable to find event for the ~ alleged function, ~x0" fn-limit)))) (dcls (butlast (cddr def) 1)) (type-lst (remove-var-from-type-dcls limit (fetch-dcl-field 'type dcls))) (guard (conjoin-untranslated-terms (fetch-dcl-field :guard dcls))) (split-types-lst (fetch-dcl-field :split-types dcls)) (guard-simplify-lst (fetch-dcl-field :guard-simplify dcls))) `(declare ,@TYPE-LST (xargs :guard ,(IF (EQ GUARD T) T `(LET ((,LIMIT 0)) (DECLARE (IGNORABLE ,LIMIT)) ,GUARD)) ,@(AND SPLIT-TYPES-LST (PAIRLIS-X1 :SPLIT-TYPES SPLIT-TYPES-LST)) ,@(AND GUARD-SIMPLIFY-LST (PAIRLIS-X1 :GUARD-SIMPLIFY GUARD-SIMPLIFY-LST))))))
memoize-partial-supporting-events-1function
(defun memoize-partial-supporting-events-1 (fn fn-limit fn-limit-change fn-limit-stable flet-bindings wrld) (let* ((fn-limit-formals (formals fn-limit wrld)) (def (memoize-partial-def fn fn-limit fn-limit-formals flet-bindings wrld))) (cond ((eq def :definition-not-found) (mv (msg "Implementation error: Unable to find the definition of ~x0." fn-limit) nil nil)) ((eq def :state) (mv (msg "STATE is among the formals of ~x0, which is illegal for ~ memoization." fn-limit) nil nil)) ((eq (car def) :stobjs) (mv (msg "The stobj~#0~[ ~&0 is~/s ~&0 are~] returned by ~x1, which is ~ illegal for memoization." (cdr def) fn-limit) nil nil)) ((null def) (mv (msg "The (untranslated) body of function ~x0 is not of the ~ appropriate form." fn-limit) nil nil)) (t (let* ((limit (assert$ (consp fn-limit-formals) (car (last fn-limit-formals)))) (fn-formals (butlast fn-limit-formals 1)) (large (genvar limit "LARGE" nil fn-limit-formals))) (mv nil `((defchoose ,FN-LIMIT-CHANGE (,LARGE) ,FN-LIMIT-FORMALS (and (natp ,LARGE) (<= ,LIMIT ,LARGE) (not (equal (,FN-LIMIT ,@FN-LIMIT-FORMALS) (,FN-LIMIT ,@FN-FORMALS ,LARGE))))) (defchoose ,FN-LIMIT-STABLE (,LIMIT) ,FN-FORMALS (and (natp ,LIMIT) (equal (,FN-LIMIT ,@FN-LIMIT-FORMALS) (,FN-LIMIT ,@FN-FORMALS (,FN-LIMIT-CHANGE ,@FN-LIMIT-FORMALS))))) ,(LET* ((STOBJS-IN (STOBJS-IN FN-LIMIT WRLD)) (STOBJS (COLLECT-USER-STOBJS STOBJS-IN))) `(DEFUN ,FN ,FN-FORMALS ,(MEMOIZE-PARTIAL-DECLARE FN-LIMIT LIMIT WRLD) ,@(AND STOBJS `((DECLARE (XARGS :STOBJS ,@STOBJS)))) (,FN-LIMIT ,@FN-FORMALS (NFIX (NON-EXEC (,FN-LIMIT-STABLE ,@FN-FORMALS))))))) `(,FN ,FN-LIMIT ,FN-LIMIT-CHANGE ,FN-LIMIT-STABLE ,DEF)))))))
memoize-partial-supporting-events-recfunction
(defun memoize-partial-supporting-events-rec (tuples flet-bindings wrld msg defs table-tuples) (cond ((endp tuples) (mv (and msg (msg "~|~@0~|See :DOC memoize-partial.~|" msg)) (reverse defs) (let* ((val (reverse table-tuples)) (key (cadr (car val)))) `(table partial-functions-table ',KEY (put-assoc-eq-alist (cdr (assoc-eq ',KEY (table-alist 'partial-functions-table world))) ',VAL))))) (t (mv-let (msg1 defs1 table-tuple) (let ((tuple (car tuples))) (memoize-partial-supporting-events-1 (car tuple) (cadr tuple) (caddr tuple) (cadddr tuple) flet-bindings wrld)) (memoize-partial-supporting-events-rec (cdr tuples) flet-bindings wrld (cond (msg1 (cond (msg (msg "~@0~|~@1" msg msg1)) (t msg1))) (t msg)) (revappend defs1 defs) (cons table-tuple table-tuples))))))
flet-bindingsfunction
(defun flet-bindings (tuples wrld) (cond ((endp tuples) nil) (t (cons (let* ((tuple (car tuples)) (fn (car tuple)) (fn-limit (cadr tuple)) (fn-limit-formals (formals fn-limit wrld)) (limit (car (last fn-limit-formals))) (fn-formals (butlast fn-limit-formals 1))) `(,FN-LIMIT ,FN-LIMIT-FORMALS (declare (ignore ,LIMIT)) (,FN ,@FN-FORMALS))) (flet-bindings (cdr tuples) wrld)))))
memoize-partial-supporting-eventsfunction
(defun memoize-partial-supporting-events (tuples wrld) (memoize-partial-supporting-events-rec tuples (flet-bindings tuples wrld) wrld nil nil nil))
memoize-partial-tuple-shape-pfunction
(defun memoize-partial-tuple-shape-p (lst) (declare (xargs :guard t)) (cond ((atom lst) (null lst)) (t (let ((tuple (car lst))) (and (symbolp (car tuple)) (symbolp (cadr tuple)) (symbolp (caddr tuple)) (symbolp (cadddr tuple)) (consp (cddddr tuple)) (null (cdr (cddddr tuple))) (memoize-partial-tuple-shape-p (cdr lst)))))))
memoize-partial-translations-msg-formalsfunction
(defun memoize-partial-translations-msg-formals (fns limit fn0 wrld) (cond ((endp fns) nil) (t (let* ((fn (car fns)) (formals (formals fn wrld))) (cond ((null (cdr formals)) (msg "The function symbol ~x0 must have at least two formal ~ parameters." fn)) ((eq (car (last formals)) limit) (memoize-partial-translations-msg-formals (cdr fns) limit fn0 wrld)) (t (msg "The formal parameter lists for function symbols ~x0 and ~ ~x1 have different final elements (of ~x2 and ~x3, ~ respectively)." fn0 fn limit (car (last formals)))))))))
free-exactly-in-last-arg-of-callsmutual-recursion
(mutual-recursion (defun free-exactly-in-last-arg-of-calls (limit fns-limit term) (cond ((eq term limit) nil) ((or (variablep term) (fquotep term)) t) ((flambdap (ffn-symb term)) (let ((posn (position limit (lambda-formals (ffn-symb term)))) (args (fargs term))) (and (free-exactly-in-last-arg-of-calls limit fns-limit (lambda-body (ffn-symb term))) (cond (posn (and (eq (nth posn args) limit) (free-exactly-in-last-arg-of-calls-lst limit fns-limit (take posn args) nil) (free-exactly-in-last-arg-of-calls-lst limit fns-limit (nthcdr (1+ posn) args) nil))) (t (free-exactly-in-last-arg-of-calls-lst limit fns-limit args nil)))))) (t (free-exactly-in-last-arg-of-calls-lst limit fns-limit (fargs term) (member-eq (ffn-symb term) fns-limit))))) (defun free-exactly-in-last-arg-of-calls-lst (limit fns-limit args last-is-limit) (cond ((endp args) t) ((and last-is-limit (endp (cdr args))) (eq (car args) limit)) (t (and (free-exactly-in-last-arg-of-calls limit fns-limit (car args)) (free-exactly-in-last-arg-of-calls-lst limit fns-limit (cdr args) last-is-limit))))))
memoize-partial-translations-msg-bodiesfunction
(defun memoize-partial-translations-msg-bodies (tail fns-limit limit wrld) (cond ((endp tail) nil) (t (let* ((fn (car tail)) (body (body fn nil wrld)) (str "Unexpected form for translated body of ~x0")) (case-match body (('if ('zp !limit) & (('lambda (!limit . vars) body) ('binary-+ ''-1 !limit) . vars)) (declare (ignore vars)) (if (free-exactly-in-last-arg-of-calls limit fns-limit body) (memoize-partial-translations-msg-bodies (cdr tail) fns-limit limit wrld) (msg "The limit variable ~x0 fails to occur free exactly where ~ expected in the body of the definition of function ~x1 ~ (essentially, as the last argument of each recursive call)." limit fn))) (& (msg "~@0 (must be of the form (IF (ZP LIMIT) & &))." (msg str fn))))))))
memoize-partial-translations-msgfunction
(defun memoize-partial-translations-msg (fns-limit wrld) (assert$ (and (all-function-symbolps fns-limit wrld) (consp fns-limit)) (let* ((fn (car fns-limit)) (limit (car (last (formals fn wrld))))) (or (memoize-partial-translations-msg-formals fns-limit limit fn wrld) (memoize-partial-translations-msg-bodies fns-limit fns-limit limit wrld)))))
partial-functions-table-guard-msgfunction
(defun partial-functions-table-guard-msg (key new-tuples/old-tuples wrld) (declare (xargs :guard t)) (let* ((old-tuples (cdr (assoc-eq key (table-alist 'partial-functions-table wrld)))) (len-old-tuples (len old-tuples)) (len-new-tuples/old-tuples (len new-tuples/old-tuples)) (len-new (- len-new-tuples/old-tuples len-old-tuples)) (common-case (and (true-listp new-tuples/old-tuples) (< len-old-tuples len-new-tuples/old-tuples) (equal (nthcdr len-new new-tuples/old-tuples) old-tuples)))) (cond ((not (and (symbolp key) (function-symbolp key wrld))) (msg "The key is not a known function symbol.")) ((not (eq (symbol-class key wrld) :common-lisp-compliant)) (msg "The key is a function symbol but it is not guard-verified.")) ((null (cdr (formals key wrld))) (msg "The key is a guard-verified function symbol but it needs at least ~ two formal parameters.")) ((not (or common-case (subsetp-equal old-tuples new-tuples/old-tuples))) (msg "The value is not an extension of the previous value.")) (t (let ((new-tuples (if common-case (take len-new new-tuples/old-tuples) (set-difference-equal new-tuples/old-tuples old-tuples)))) (cond ((not (memoize-partial-tuple-shape-p new-tuples)) (msg "The extension of the old value is not a list of 5-tuples ~ where each tuple consists of four symbols followed by one ~ more element.")) (t (let ((fns-limit (strip-cadrs new-tuples)) (r (getpropc key 'recursivep nil wrld))) (cond ((not r) (msg "The key is a non-recursive function symbol.")) ((not (equal fns-limit r)) (cond ((cdr r) (msg "The strip-cadrs of the proposed extension of the ~ old value is not the list of function symbols, ~ in order, defined by mutual-recursion with the ~ key. That expected list of functions is ~x0." r)) (t (msg "The proposed extension of the old value is not a ~ one-element list containing the key.")))) (t (mv-let (msg defs table-event) (memoize-partial-supporting-events new-tuples wrld) (declare (ignore table-event)) (or msg (let ((bad-events (collect-non-redundant defs wrld))) (cond (bad-events (msg "The following ~#0~[event is~/events are~] ~ missing:~|~%~*1" bad-events (list "" "~X*2~|~%" "~X*2~|~%" "~X*2~|~%" bad-events (cons #\2 nil)))) (t (memoize-partial-translations-msg fns-limit wrld))))))))))))))))
partial-functions-table-guardfunction
(defun partial-functions-table-guard (fn val wrld) (let ((msg0 (partial-functions-table-guard-msg fn val wrld))) (cond (msg0 (mv nil (msg "Illegal partial-functions-table key and value (see :DOC ~ memoize-partial):~|key = ~y0value = ~y1Reason:~%~@2~|~%" fn val msg0))) (t (mv t nil)))))
other
(table partial-functions-table nil nil :guard (partial-functions-table-guard key val world))
memoize-invoke-equality-pfunction
(defun memoize-invoke-equality-p (fn invoke term) (and (ffn-symb-p term 'equal) (let ((lhs (fargn term 1)) (rhs (fargn term 2))) (and (if (ffn-symb-p lhs fn) (ffn-symb-p rhs invoke) (if (ffn-symb-p lhs invoke) (ffn-symb-p rhs fn) nil)) (all-variablep (fargs lhs)) (equal (fargs lhs) (fargs rhs)) (no-duplicatesp-eq (fargs lhs))))))
memoize-invoke-equality-existsfunction
(defun memoize-invoke-equality-exists (fn invoke wrld-tail wrld) (cond ((null wrld-tail) nil) ((and (eq (cadr (car wrld-tail)) 'theorem) (memoize-invoke-equality-p fn invoke (cddr (car wrld-tail))) (equal (getpropc (car (car wrld-tail)) 'theorem nil wrld) (cddr (car wrld-tail)))) t) (t (memoize-invoke-equality-exists fn invoke (cdr wrld-tail) wrld))))
memoize-invoke-guard-implication-default-namefunction
(defun memoize-invoke-guard-implication-default-name (f g) (intern-in-package-of-symbol (concatenate 'string (symbol-name f) "-guard-implies-" (symbol-name g) "-guard") g))
memoize-invoke-guard-implication-termfunction
(defun memoize-invoke-guard-implication-term (f g wrld) (let ((guard-g (guard g nil wrld))) (cond ((equal guard-g *t*) nil) (t (let ((guard-f (guard f nil wrld)) (guard-g (sublis-var (pairlis$ (formals g wrld) (formals f wrld)) guard-g))) (cond ((equal guard-f guard-g) nil) ((if-tautologyp (fcons-term* 'if guard-f guard-g *t*)) nil) (t (fcons-term* 'implies guard-f guard-g))))))))
verify-guard-implicationmacro
(defmacro verify-guard-implication (f g &key hints otf-flg) `(make-event (let ((term (or (memoize-invoke-guard-implication-term ',F ',G (w state)) t)) (name (memoize-invoke-guard-implication-default-name ',F ',G))) (list 'defthm name term ,@(AND HINTS (LIST :HINTS (LIST 'QUOTE HINTS))) ,@(AND OTF-FLG (LIST :OTF-FLG (LIST 'QUOTE OTF-FLG))) :rule-classes nil))))
memoize-invoke-guard-thm-exists-1function
(defun memoize-invoke-guard-thm-exists-1 (term wrld-tail wrld) (cond ((null wrld-tail) nil) ((and (eq (cadr (car wrld-tail)) 'theorem) (equal term (cddr (car wrld-tail))) (equal (getpropc (car (car wrld-tail)) 'theorem nil wrld) term)) t) (t (memoize-invoke-guard-thm-exists-1 term (cdr wrld-tail) wrld))))
memoize-invoke-guard-thm-existsfunction
(defun memoize-invoke-guard-thm-exists (fn invoke wrld) (let ((term (memoize-invoke-guard-implication-term fn invoke wrld))) (if term (memoize-invoke-guard-thm-exists-1 term wrld wrld) t)))
memoize-table-chk-invoke-msgfunction
(defun memoize-table-chk-invoke-msg (key invoke str wrld state) (cond ((not (and (symbolp invoke) (function-symbolp invoke wrld) (eq (symbol-class invoke wrld) :common-lisp-compliant))) (msg "~@0The value of keyword :INVOKE, ~x1, is not a guard-verified ~ function symbol." str invoke)) ((untouchable-fn-p invoke wrld (f-get-global 'temp-touchable-fns state)) (msg "~@0The value of keyword :INVOKE, ~x1, is an untouchable function ~ symbol." str invoke)) ((and (assoc-eq invoke *ttag-fns*) (not (ttag wrld))) (msg "~@0The value of keyword :INVOKE, ~x1, is a function symbol that ~ cannot be called unless a trust tag is in effect. See :DOC ~ defttag.~@2" str invoke (or (cdr (assoc-eq invoke *ttag-fns*)) ""))) ((not (logicp key wrld)) (msg "~@0When memoizing with memoize keyword :INVOKE, the memoized ~ function must be in :logic mode, which ~x1 is not." str key)) ((not (and (equal (stobjs-in key wrld) (stobjs-in invoke wrld)) (not (member-eq key *stobjs-out-invalid*)) (not (member-eq invoke *stobjs-out-invalid*)) (equal (stobjs-out key wrld) (stobjs-out invoke wrld)))) (msg "~@0The function to be memoized, ~x1, has a different signature from ~ the function to be :INVOKEd, ~x2." str key invoke)) ((skip-proofs-due-to-system state) nil) (t (let ((eq-thm-p (memoize-invoke-equality-exists key invoke wrld wrld)) (gd-thm-p (memoize-invoke-guard-thm-exists key invoke wrld))) (cond ((and eq-thm-p gd-thm-p) nil) (t (let* ((thm-formula (and (not eq-thm-p) `(defthm ,(INTERN-IN-PACKAGE-OF-SYMBOL (CONCATENATE 'STRING (SYMBOL-NAME KEY) "-is-" (SYMBOL-NAME INVOKE)) INVOKE) ,(LET ((FORMALS (FORMALS KEY WRLD))) `(EQUAL (,KEY ,@FORMALS) (,INVOKE ,@FORMALS))) :rule-classes nil))) (guard-thm-formula (and (not gd-thm-p) `(verify-guard-implication ,KEY ,INVOKE))) (msg (cond (gd-thm-p (msg "~x0" thm-formula)) (eq-thm-p (msg "~x0" guard-thm-formula)) (t (msg "~x0~|~%~x1" thm-formula guard-thm-formula))))) (msg "~@0The following event~#1~[~/s~] must be admitted ~ (possibly with differing name or macro) before memoizing ~ function ~x2 with :INVOKE value ~x3. See :DOC ~ memoize.~|~%~@4" str (if (or eq-thm-p gd-thm-p) 0 1) key invoke msg))))))))
memoize-table-chkfunction
(defun memoize-table-chk (key val wrld state) (let ((ctx '(table . memoize-table)) (str "Illegal attempt to set memoize-table: ")) (cond ((not (symbolp key)) (mv nil (msg "~@0The first argument of memoize must be a symbol, unlike ~ ~x1." str key))) ((not (symbol-alistp val)) (mv nil (msg "~@0Function symbol ~x1 must be associated with a ~ symbol-alistp, unlike ~x2." str key val))) (t (let* ((memoize-table (table-alist 'memoize-table wrld)) (key-formals (getpropc key 'formals t wrld)) (key-class (symbol-class key wrld)) (condition (and val (cdr (assoc-eq :condition-fn val)))) (inline (and val (cdr (assoc-eq :inline val)))) (aokp (and val (cdr (assoc-eq :aokp val)))) (invoke (and val (cdr (assoc-eq :invoke val)))) (total (and val (cdr (assoc-eq :total val)))) (msg (cond ((eq key-formals t) (msg "~@0~x1 is not a function symbol." str key)) ((and (or condition (cdr (assoc-eq :inline val))) (member-eq 'state (stobjs-in key wrld))) (msg "~@0~x1 takes ACL2's STATE as an argument (illegal ~ except for profiling)." str key)) ((not (booleanp aokp)) (msg "~@0:aokp has a non-Boolean value, ~x1." str aokp)) ((and (or condition (cdr (assoc-eq :inline val))) (non-memoizable-stobjs (stobjs-in key wrld) wrld)) (mv-let (abs conc) (filter-absstobjs (non-memoizable-stobjs (stobjs-in key wrld) wrld) wrld nil nil) (cond ((null abs) (msg "~@0~x1 has input stobj~#2~[ ~&2~/s ~&2, each~] ~ introduced with :NON-MEMOIZABLE T. See :DOC ~ defstobj." str key conc)) ((null conc) (msg "~@0~x1 has input abstract stobj~#2~[ ~&2~/s ~&2, ~ each of~] whose corresponding foundational stobj is ~ non-memoizable. See :DOC defabsstobj." str key abs)) (t (msg "~@0~x1 has input foundational stobj~#2~[ ~&2~/s ~ ~&2, each~] introduced as non-memoizable. ~x1 also ~ has input abstract stobj~#3~[ ~&2~/s ~&3, each of~] ~ whose corresponding foundational stobj is ~ non-memoizable. See :DOC defstobj." str key conc abs))))) ((member-eq key *stobjs-out-invalid*) (msg "~@0~x1 is a primitive without a fixed output signature." str key)) ((and (or condition (cdr (assoc-eq :inline val))) (collect-non-nil-df (stobjs-out key wrld))) (let ((stobj (car (collect-non-nil-df (stobjs-out key wrld))))) (msg "~@0~x1 returns a stobj, ~x2 (illegal except for ~ profiling)." str key stobj))) ((member-eq key *hons-primitive-fns*) (msg "~@0~x1 is a HONS primitive." str key)) ((not (cltl-def-from-name key wrld)) (msg "~@0Although ~x1 is a defined ACL2 function, its ~ implementation in raw Lisp is not.~@2" str key (let* ((st (getpropc key 'stobj-function nil wrld)) (ev (and st (get-event st wrld)))) (cond ((and ev (or (and (eq (car ev) 'defstobj) (member-eq :inline ev)) (eq (car ev) 'defabsstobj))) (msg " Note that ~x0 was introduced with the event ~ ~x1, so ~x0 is ``inlined'' by making it a ~ macro in raw Lisp." key ev)) (t ""))))) ((getpropc key 'constrainedp nil wrld) (msg "~@0~x1 is constrained. You may instead wish to memoize ~ a caller or to memoize its attachment (see :DOC ~ defattach)." str key)) ((and inline (if (eq key-class :program) (member-eq key *initial-program-fns-with-raw-code*) (member-eq key *initial-logic-fns-with-raw-code*))) (msg "~@0The built-in function symbol ~x1 has associated ~ raw-Lisp code, hence is illegal to memoize unless ~ :RECURSIVE is nil." str key)) ((let ((pair (assoc-eq :memo-table-init-size val))) (and pair (not (posp (cdr pair))))) (msg "~@0The :memo-table-init-size must be a positive ~ integer, unlike ~x1." str (cdr (assoc-eq :memo-table-init-size val)))) ((memoize-table-chk-commutative-msg str key val wrld)) ((and invoke total) (msg "~@0It is illegal to specify non-nil values for both the ~ :INVOKE and :TOTAL memoize keywords." str)) ((and invoke inline) (msg "~@0It is illegal to specify a non-NIL value for the ~ :INVOKE keyword of memoize when the :RECURSIVE keyword ~ (i.e., the :INLINE keyword for the memoize table) is T." str)) ((and invoke (memoize-table-chk-invoke-msg key invoke str wrld state))) ((not (symbolp total)) (msg "~@0The value of the :total keyword for memoize must be ~ a symbol, but ~x1 is not. Presumably you are trying to ~ use the :total option of memoize directly, which is not ~ recommended. See :DOC memoize-partial." str total)) ((and total (not (cltl-def-memoize-partial key total wrld))) (msg "~@0Unable to find executable Common Lisp definition for ~ ~x1 in the table, ~x2. Presumably you are trying to ~ use the :total option of memoize directly, which is not ~ recommended. See :DOC memoize-partial." str total 'partial-functions-table)) ((and val (cdr (assoc-eq key memoize-table))) (msg "~@0Function ~x1 is already memoized." str key)) ((and (null val) (null (cdr (assoc-eq key memoize-table)))) (msg "~@0Cannot unmemoize function ~x1 because it is not ~ currently memoized." str key)) ((and (eq key-class :ideal) val (let* ((pair (assoc-eq :ideal-okp val)) (okp (if pair (cdr pair) (cdr (assoc-eq :memoize-ideal-okp (table-alist 'acl2-defaults-table wrld)))))) (cond ((eq okp t) nil) ((not okp) (msg "~@0The function symbol ~x1 is in :logic ~ mode but has not had its guards verified. ~ ~ Either run ~x2, or specify :IDEAL-OKP ~ ~x3 in your ~x4 call, or else evaluate ~ ~x5 or ~x6." str key 'verify-guards t 'memoize '(table acl2-defaults-table :memoize-ideal-okp t) '(table acl2-defaults-table :memoize-ideal-okp :warn))) (t (prog2$ (warning$-cw0 'memoize-table-chk "Memoize" (default-state-vars t) "The function ~x0 to be memoized is in ~ :logic mode but has not had its ~ guards verified. Memoization might ~ therefore not take place; see :DOC ~ memoize." key) nil)))))) (t (let ((val-formals (and condition (if (symbolp condition) (getpropc condition 'formals t wrld) t))) (val-guard (and condition (if (symbolp condition) (guard condition t wrld) t)))) (cond ((or (eq val nil) (member-eq condition '(t nil))) nil) ((eq val-formals t) (msg "~@0The proposed memoization condition function, ~ ~x1, is neither T, NIL, nor a function symbol known ~ to ACL2." str condition)) ((not (and (symbolp condition) (or (eq key-class :program) (eq (symbol-class condition wrld) :common-lisp-compliant)))) (msg "~@0Function ~x1 cannot serve as a memoization ~ condition function for function ~x2, because unlike ~ ~x2, ~x1 is not common-lisp-compliant (a logic-mode ~ function that has had its guards verified)." str condition key)) ((not (equal key-formals val-formals)) (msg "~@0Function ~x1 cannot serve as a memoization ~ condition function for ~x2, because the two ~ functions have different formal parameter lists." str condition key)) ((not (equal (guard key t wrld) val-guard)) (msg "~@0Function ~x1 cannot serve as a memoization ~ condition function for ~x2, because the two ~ functions have different guards." str condition key)) (t nil))))))) (progn$ (and val (let* ((stobjs-in (stobjs-in key wrld)) (relevant-input-stobjs (and condition (collect-non-nil-df stobjs-in)))) (cond (relevant-input-stobjs (observation-cw ctx "The function ~x0 has input stobj~#1~[~/s~] ~&1. The ~ memoization table for ~x0 will be cleared whenever ~ ~#2~[this stobj is~/either of these stobjs is~/any of ~ these stobjs is~] updated. Any update of a stobj may ~ therefore be significantly slower, perhaps by a factor of ~ 5 or 10, when it is an input of a memoized function." key relevant-input-stobjs (zero-one-or-more (cdr relevant-input-stobjs)))) (t nil)))) (if msg (mv nil msg) (mv t nil))))))))
other
(table memoize-table nil nil :guard (memoize-table-chk key val world state))
memoize-partial-callsfunction
(defun memoize-partial-calls (tuples) (declare (xargs :guard (and (symbol-alistp tuples) (true-list-listp tuples)))) (cond ((endp tuples) nil) (t (cons `(memoize ',(CAAR TUPLES) :total ',(CADAR TUPLES) ,@(CDDDDR (CAR TUPLES))) (memoize-partial-calls (cdr tuples))))))
memoize-partial-tuple-1function
(defun memoize-partial-tuple-1 (x1 x2 ctx str fn fn-limit change stable) (declare (xargs :guard (and (keyword-value-listp x1) (keyword-value-listp x2) (stringp str)))) (cond ((endp x1) (list* fn fn-limit (or change (add-suffix fn-limit "-CHANGE")) (or stable (add-suffix fn-limit "-STABLE")) x2)) ((eq (car x1) :change) (cond (change (er hard ctx str (msg "The keyword :CHANGE appears more than once ~ for the tuple associated with ~x0" fn))) (t (memoize-partial-tuple-1 (cddr x1) x2 ctx str fn fn-limit (cadr x1) stable)))) ((eq (car x1) :stable) (cond (stable (er hard ctx str (msg "The keyword :STABLE appears more than once ~ for the tuple associated with ~x0" fn))) (t (memoize-partial-tuple-1 (cddr x1) x2 ctx str fn fn-limit change (cadr x1))))) (t (memoize-partial-tuple-1 (cddr x1) (list* (car x1) (cadr x1) (if (assoc-keyword (car x1) x2) (remove-keyword (car x1) x2) x2)) ctx str fn fn-limit change stable))))
memoize-partial-tuplefunction
(defun memoize-partial-tuple (tuple args ctx str) (declare (xargs :guard (and (consp tuple) (consp (cdr tuple)) (keyword-value-listp (cddr tuple)) (keyword-value-listp args) (stringp str)))) (memoize-partial-tuple-1 (cddr tuple) args ctx str (car tuple) (cadr tuple) nil nil))
memoize-partial-tuplesfunction
(defun memoize-partial-tuples (tuples args ctx) (declare (xargs :guard (keyword-value-listp args))) (let ((str "Ill-formed argument for memoize-partial: ~@0. See :DOC ~ memoize-partial.")) (cond ((null tuples) nil) ((atom tuples) (er hard ctx str "Not a null-terminated list")) (t (let* ((tuple (car tuples)) (tuple (if (symbolp tuple) (list tuple (add-suffix tuple "-LIMIT")) tuple))) (cond ((and (<= 2 (len tuple)) (symbolp (car tuple)) (car tuple) (symbolp (cadr tuple)) (cadr tuple) (keyword-value-listp (cddr tuple))) (cons (memoize-partial-tuple tuple args ctx str) (memoize-partial-tuples (cdr tuples) args ctx))) (t (er hard ctx str (msg "The tuple associated with ~x0 is not of the ~ form (fn fn-limit :kwd1 val1 ... :kwdn ~ valn)" (car tuple))))))))))
memoize-partial-basic-checksfunction
(defun memoize-partial-basic-checks (tuples ctx state) (let* ((fns (strip-cadrs tuples)) (wrld (w state)) (bad (non-function-symbols fns wrld))) (cond (bad (er soft ctx "You must define ~&0 before submitting your memoize-partial ~ form. See :DOC memoize-partial." bad)) (t (let ((bad (collect-non-common-lisp-compliants fns wrld))) (cond (bad (er soft ctx "The function~#0~[ ~&0 is~/s ~&0 are~] not guard-verified. ~ See :DOC memoize-partial." bad)) (t (value nil))))))))
memoize-partialmacro
(defmacro memoize-partial (&whole whole tuples &rest args) (let ((ctx 'memoize-partial)) (cond ((and (true-listp tuples) (equal (length tuples) 2) (equal (car tuples) 'quote)) (er hard ctx "The argument for memoize-partial should not be quoted. ~ Perhaps you intended that argument to be ~x0. See :DOC ~ memoize-partial." (cadr tuples))) ((not (keyword-value-listp args)) (er hard ctx "The arguments to MEMOIZE-PARTIAL after the first ~ argument should be an alternating list of keywords and ~ values (keyword first), which will be passed to ~ MEMOIZE. The call ~x0 is thus illegal. See :DOC ~ memoize-partial." whole)) (t (let ((tuples (memoize-partial-tuples (if (symbolp tuples) (list tuples) tuples) args ctx))) `(progn (make-event (er-progn (memoize-partial-basic-checks ',TUPLES ',CTX state) (mv-let (msg defs table-event) (memoize-partial-supporting-events ',TUPLES (w state)) (cond (msg (er soft ',CTX "~@0" msg)) (t (value (cons 'progn (append defs (list table-event)))))))) :on-behalf-of :quiet!) ,@(MEMOIZE-PARTIAL-CALLS TUPLES)))))))
read-event-data-falfunction
(defun read-event-data-fal (alist fal) (cond ((endp alist) fal) (t (let* ((key (caar alist)) (val (cdar alist)) (old (cdr (hons-get key fal)))) (read-event-data-fal (cdr alist) (hons-acons key (cons val old) fal))))))
first-non-string-key-pairfunction
(defun first-non-string-key-pair (fal) (cond ((atom fal) nil) ((stringp (caar fal)) (first-non-string-key-pair (cdr fal))) (t (car fal))))
old-and-new-event-data-falfunction
(defun old-and-new-event-data-fal (book-string dir ctx state) (let ((current-event-data-fal (f-get-global 'event-data-fal state))) (cond ((null current-event-data-fal) (er soft ctx "No event-data-fal has been saved in this session. See :DOC ~ saving-event-data.")) (t (mv-let (full-book-string full-book-name directory-name familiar-name) (parse-book-name (or dir (cbd)) book-string nil ctx state) (declare (ignore full-book-name directory-name familiar-name)) (let* ((cached (cdr (hons-get full-book-string current-event-data-fal)))) (cond (cached (value (cons cached current-event-data-fal))) (t (let ((event-data-filename (event-data-filename full-book-string nil))) (with-packages-unhidden (mv-let (channel state) (open-input-channel event-data-filename :object state) (cond (channel (er-let* ((alist (state-global-let* ((current-package "ACL2" set-current-package-state)) (mv-let (alist state) (read-file-iterate-safe channel nil state) (value alist))))) (let ((file-event-data-fal (read-event-data-fal alist 'read-event-data-fal))) (pprogn (close-input-channel channel state) (let ((new-event-data-fal (hons-acons full-book-string file-event-data-fal current-event-data-fal))) (pprogn (f-put-global 'event-data-fal new-event-data-fal state) (value (cons file-event-data-fal new-event-data-fal)))))))) (t (er soft ctx "Unable to open file ~x0 for reading event-data." event-data-filename))))))))))))))
old-and-new-event-data-fnfunction
(defun old-and-new-event-data-fn (book-string name namep dir ctx state) (er-let* ((old/new (old-and-new-event-data-fal book-string dir ctx state))) (let* ((old (car old/new)) (new (cdr old/new)) (pair (and (not namep) (first-non-string-key-pair new))) (name (if namep name (car pair))) (old-event-data-lst (cdr (hons-get name old))) (old-len (length old-event-data-lst)) (new-event-data-lst (if pair (cdr pair) (cdr (hons-get name new)))) (new-len (length new-event-data-lst))) (cond ((< old-len new-len) (pprogn (warning$ ctx "Event-data" "The number of events named ~x0 in the current ~ session, which is ~x1, exceeds the number of events, ~ ~x2, that are named ~x0 in the given file. Thus no ~ result is available." name new-len old-len) (value nil))) ((= new-len 0) (er soft ctx "No event-data ~#0~[was~/ for events named ~x1 were~] saved ~ in the current session. Thus no result is available." (if namep 1 0) name)) (t (value (cons (nth (- old-len new-len) old-event-data-lst) (car new-event-data-lst))))))))
old-and-new-event-datamacro
(defmacro old-and-new-event-data (book-string &key (name 'nil namep) dir) `(old-and-new-event-data-fn ,BOOK-STRING ,NAME ,NAMEP ,DIR 'old-and-new-event-data state))
runes-diff-fnfunction
(defun runes-diff-fn (book-string name namep dir ctx state) (er-let* ((old/new (old-and-new-event-data-fn book-string name namep dir ctx state))) (let* ((old (car old/new)) (new (cdr old/new)) (old-runes (get-event-data-1 'rules old)) (new-runes (get-event-data-1 'rules new)) (old-diff (set-difference-equal old-runes new-runes)) (new-diff (set-difference-equal new-runes old-runes))) (value (list (list :old old-diff) (list :new new-diff))))))
runes-diffmacro
(defmacro runes-diff (book-string &key (name 'nil namep) dir) `(runes-diff-fn ,BOOK-STRING ,NAME ,NAMEP ,DIR 'runes-diff state))
add-global-stobjfunction
(defun add-global-stobj (name state) (declare (xargs :guard (symbolp name) :mode :program :stobjs state)) (let ((user-stobj-alist (user-stobj-alist state)) (wrld (w state)) (ctx 'add-global-stobj)) (cond ((not (stobjp name t wrld)) (er soft ctx "~x0 is not the name of a known stobj." name)) ((assoc-eq name user-stobj-alist) (er soft ctx "The stobj ~x0 is already global." name)) (t (mv-let (erp init-val state) (read-acl2-oracle state) (declare (ignore erp)) (pprogn (update-user-stobj-alist (acons name init-val user-stobj-alist) state) (value name)))))))
remove-global-stobjfunction
(defun remove-global-stobj (name state) (declare (xargs :guard (symbolp name) :mode :program :stobjs state)) (let ((user-stobj-alist (user-stobj-alist state)) (wrld (w state)) (ctx 'add-global-stobj)) (cond ((not (stobjp name t wrld)) (er soft ctx "~x0 is not the name of a known stobj." name)) ((not (assoc-eq name user-stobj-alist)) (er soft ctx "The stobj ~x0 is not currently global." name)) (t (pprogn (update-user-stobj-alist (remove-assoc-eq name user-stobj-alist) state) (value name))))))