other
(in-package "ACL2")
other
(defrec goal-tree (children processor cl-id . fanout) nil)
start-proof-tree-fnfunction
(defun start-proof-tree-fn (remove-inhibit-p state) (if remove-inhibit-p (f-put-global 'inhibit-output-lst (remove1-eq 'proof-tree (f-get-global 'inhibit-output-lst state)) state) state))
start-proof-treemacro
(defmacro start-proof-tree nil '(pprogn (start-proof-tree-fn t state) (fms "Proof tree output is now enabled. Note that ~ :START-PROOF-TREE works by removing 'proof-tree from ~ the inhibit-output-lst; see :DOC ~ set-inhibit-output-lst.~%" nil (standard-co state) state nil) (value :invisible)))
checkpoint-forced-goalsmacro
(defmacro checkpoint-forced-goals (val) `(pprogn (f-put-global 'checkpoint-forced-goals ',VAL state) (value ',VAL)))
stop-proof-tree-fnfunction
(defun stop-proof-tree-fn (state) (f-put-global 'inhibit-output-lst (add-to-set-eq 'proof-tree (f-get-global 'inhibit-output-lst state)) state))
stop-proof-treemacro
(defmacro stop-proof-tree nil '(pprogn (stop-proof-tree-fn state) (fms "Proof tree output is now inhibited. Note that ~ :STOP-PROOF-TREE works by adding 'proof-tree to the ~ inhibit-output-lst; see :DOC set-inhibit-output-lst.~%" nil (standard-co state) state nil) (value :invisible)))
insert-into-goal-tree-recmutual-recursion
(mutual-recursion (defun insert-into-goal-tree-rec (cl-id processor n goal-tree) (let ((new-children (insert-into-goal-tree-lst cl-id processor n (access goal-tree goal-tree :children)))) (and new-children (change goal-tree goal-tree :children new-children)))) (defun insert-into-goal-tree-lst (cl-id processor n goal-tree-lst) (cond ((consp goal-tree-lst) (let ((new-child (insert-into-goal-tree-rec cl-id processor n (car goal-tree-lst)))) (if new-child (cons new-child (cdr goal-tree-lst)) (let ((rest-children (insert-into-goal-tree-lst cl-id processor n (cdr goal-tree-lst)))) (if rest-children (cons (car goal-tree-lst) rest-children) nil))))) ((integerp goal-tree-lst) (cons (make goal-tree :cl-id cl-id :processor processor :children n :fanout (or n 0)) (if (eql goal-tree-lst 1) nil (1- goal-tree-lst)))) (t nil))))
insert-into-goal-treefunction
(defun insert-into-goal-tree (cl-id processor n goal-tree) (cond ((equal cl-id *initial-clause-id*) (make goal-tree :cl-id cl-id :processor processor :children n :fanout (or n 0))) (t (insert-into-goal-tree-rec cl-id processor n goal-tree))))
set-difference-equal-changedpfunction
(defun set-difference-equal-changedp (l1 l2) (declare (xargs :guard (and (true-listp l1) (true-listp l2)))) (cond ((endp l1) (mv nil nil)) (t (mv-let (changedp lst) (set-difference-equal-changedp (cdr l1) l2) (cond ((member-equal (car l1) l2) (mv t lst)) (changedp (mv t (cons (car l1) lst))) (t (mv nil l1)))))))
prune-goal-treemutual-recursion
(mutual-recursion (defun prune-goal-tree (forcing-round dead-clause-ids goal-tree) (let* ((processor (access goal-tree goal-tree :processor)) (cl-id (access goal-tree goal-tree :cl-id)) (goal-forcing-round (access clause-id cl-id :forcing-round))) (cond ((member-equal cl-id dead-clause-ids) (mv (er hard 'prune-goal-tree "Surprise! We didn't think this case could occur.") dead-clause-ids)) ((and (not (= forcing-round goal-forcing-round)) (consp processor) (eq (cadr processor) :forced)) (mv-let (changedp forced-clause-ids) (set-difference-equal-changedp (cddr processor) dead-clause-ids) (cond ((null forced-clause-ids) (mv nil (cons cl-id dead-clause-ids))) (t (mv-let (children new-dead-clause-ids) (prune-goal-tree-lst forcing-round dead-clause-ids (access goal-tree goal-tree :children)) (cond (changedp (mv (change goal-tree goal-tree :processor (list* (car processor) :forced forced-clause-ids) :children children) new-dead-clause-ids)) (t (mv (change goal-tree goal-tree :children children) new-dead-clause-ids)))))))) ((and (consp processor) (eq (car processor) 'push-clause)) (assert$ (null (access goal-tree goal-tree :children)) (if (member-equal (cadr processor) dead-clause-ids) (mv nil (cons cl-id dead-clause-ids)) (mv goal-tree dead-clause-ids)))) (t (mv-let (children new-dead-clause-ids) (prune-goal-tree-lst forcing-round dead-clause-ids (access goal-tree goal-tree :children)) (cond ((or children (and (consp processor) (eq (cadr processor) :forced))) (mv (change goal-tree goal-tree :children children) new-dead-clause-ids)) (t (mv nil (cons cl-id new-dead-clause-ids))))))))) (defun prune-goal-tree-lst (forcing-round dead-clause-ids goal-tree-lst) (cond ((consp goal-tree-lst) (mv-let (x new-dead-clause-ids) (prune-goal-tree forcing-round dead-clause-ids (car goal-tree-lst)) (if x (mv-let (rst newer-dead-clause-ids) (prune-goal-tree-lst forcing-round new-dead-clause-ids (cdr goal-tree-lst)) (mv (cons x rst) newer-dead-clause-ids)) (prune-goal-tree-lst forcing-round new-dead-clause-ids (cdr goal-tree-lst))))) (t (mv goal-tree-lst dead-clause-ids)))))
prune-proof-treefunction
(defun prune-proof-tree (forcing-round dead-clause-ids proof-tree) (if (null proof-tree) nil (mv-let (new-goal-tree new-dead-clause-ids) (prune-goal-tree forcing-round dead-clause-ids (car proof-tree)) (if new-goal-tree (cons new-goal-tree (prune-proof-tree forcing-round new-dead-clause-ids (cdr proof-tree))) (prune-proof-tree forcing-round new-dead-clause-ids (cdr proof-tree))))))
print-string-repeatfunction
(defun print-string-repeat (increment level col channel state) (declare (type (unsigned-byte 60) col level)) (the2s (unsigned-byte 60) (if (= level 0) (mv col state) (mv-letc (col state) (fmt1 "~s0" (list (cons #\0 increment)) col channel state nil) (print-string-repeat increment (1-f level) col channel state)))))
*format-proc-alist*constant
(defconst *format-proc-alist* '((apply-top-hints-clause-or-hit . ":OR") (apply-top-hints-clause . "top-level-hints") (preprocess-clause . "preprocess") (simplify-clause . "simp") (eliminate-destructors-clause . "ELIM") (fertilize-clause . "FERT") (generalize-clause . "GEN") (eliminate-irrelevance-clause . "IRREL")))
format-forced-subgoalsfunction
(defun format-forced-subgoals (clause-ids col max-col channel state) (cond ((null clause-ids) (princ$ ")" channel state)) (t (let ((goal-name (string-for-tilde-@-clause-id-phrase (car clause-ids)))) (if (or (null max-col) (if (null (cdr clause-ids)) (<= (+ 2 col (length goal-name)) max-col) (<= (+ 7 col (length goal-name)) max-col))) (mv-let (col state) (fmt1 " ~s0~#1~[~/,~]" (list (cons #\0 goal-name) (cons #\1 clause-ids)) col channel state nil) (format-forced-subgoals (cdr clause-ids) col max-col channel state)) (princ$ " ...)" channel state))))))
format-processorfunction
(defun format-processor (col goal-tree channel state) (let ((proc (access goal-tree goal-tree :processor))) (cond ((consp proc) (cond ((eq (car proc) 'push-clause) (mv-let (col state) (fmt1 "~s0 ~@1" (list (cons #\0 "PUSH") (cons #\1 (cond ((eq (caddr proc) :revert) "(reverting)") ((eq (caddr proc) :abort) "*ABORTING*") (t (tilde-@-pool-name-phrase (access clause-id (cadr proc) :forcing-round) (access clause-id (cadr proc) :pool-lst)))))) col channel state nil) (declare (ignore col)) state)) ((eq (cadr proc) :forced) (mv-let (col state) (fmt1 "~s0 (FORCED" (list (cons #\0 (cdr (assoc-eq (car proc) *format-proc-alist*)))) col channel state nil) (format-forced-subgoals (cddr proc) col (f-get-global 'proof-tree-buffer-width state) channel state))) (t (let ((err (er hard 'format-processor "Unexpected shape for goal-tree processor, ~x0" proc))) (declare (ignore err)) state)))) (t (princ$ (or (cdr (assoc-eq proc *format-proc-alist*)) proc) channel state)))))
format-goal-tree-lstmutual-recursion
(mutual-recursion (defun format-goal-tree-lst (goal-tree-lst level fanout increment checkpoints checkpoint-forced-goals channel state) (cond ((null goal-tree-lst) state) ((atom goal-tree-lst) (mv-let (col state) (pprogn (princ$ " " channel state) (print-string-repeat increment (the-fixnat! level 'format-goal-tree-lst) 5 channel state)) (mv-let (col state) (fmt1 "<~x0 ~#1~[~/more ~]subgoal~#2~[~/s~]>~%" (list (cons #\0 goal-tree-lst) (cons #\1 (if (= fanout goal-tree-lst) 0 1)) (cons #\2 (if (eql goal-tree-lst 1) 0 1))) col channel state nil) (declare (ignore col)) state))) (t (pprogn (format-goal-tree (car goal-tree-lst) level increment checkpoints checkpoint-forced-goals channel state) (format-goal-tree-lst (cdr goal-tree-lst) level fanout increment checkpoints checkpoint-forced-goals channel state))))) (defun format-goal-tree (goal-tree level increment checkpoints checkpoint-forced-goals channel state) (let* ((cl-id (access goal-tree goal-tree :cl-id)) (pool-lst (access clause-id cl-id :pool-lst)) (fanout (access goal-tree goal-tree :fanout)) (raw-processor (access goal-tree goal-tree :processor)) (processor (if (atom raw-processor) raw-processor (car raw-processor)))) (mv-letc (col state) (pprogn (mv-letc (col state) (fmt1 "~#0~[c~/ ~]~c1 " (list (cons #\0 (if (or (member-eq processor checkpoints) (and checkpoint-forced-goals (consp raw-processor) (eq (cadr raw-processor) :forced))) 0 1)) (cons #\1 (cons fanout 3))) 0 channel state nil) (print-string-repeat increment (the-fixnat! level 'format-goal-tree) col channel state))) (mv-letc (col state) (if (and (null (access clause-id cl-id :case-lst)) (= (access clause-id cl-id :primes) 0) pool-lst) (fmt1 "~@0 " (list (cons #\0 (tilde-@-pool-name-phrase (access clause-id cl-id :forcing-round) pool-lst))) col channel state nil) (fmt1 "~@0 " (list (cons #\0 (tilde-@-clause-id-phrase cl-id))) col channel state nil)) (pprogn (format-processor col goal-tree channel state) (pprogn (newline channel state) (format-goal-tree-lst (access goal-tree goal-tree :children) (1+ level) fanout increment checkpoints checkpoint-forced-goals channel state))))))))
format-proof-treefunction
(defun format-proof-tree (proof-tree-rev increment checkpoints checkpoint-forced-goals channel state) (if (null proof-tree-rev) state (pprogn (format-goal-tree (car proof-tree-rev) 0 increment checkpoints checkpoint-forced-goals channel state) (if (null (cdr proof-tree-rev)) state (mv-let (col state) (fmt1 "++++++++++++++++++++++++++++++~%" nil 0 channel state nil) (declare (ignore col)) state)) (format-proof-tree (cdr proof-tree-rev) increment checkpoints checkpoint-forced-goals channel state))))
print-proof-tree1function
(defun print-proof-tree1 (ctx channel state) (let ((proof-tree (f-get-global 'proof-tree state))) (if (null proof-tree) (if (and (consp ctx) (eq (car ctx) :failed)) state (princ$ "Q.E.D." channel state)) (format-proof-tree (reverse proof-tree) (f-get-global 'proof-tree-indent state) (f-get-global 'checkpoint-processors state) (f-get-global 'checkpoint-forced-goals state) channel state))))
*proof-failure-string*constant
(defconst *proof-failure-string* "******** FAILED ********~|")
print-proof-tree-ctxfunction
(defun print-proof-tree-ctx (ctx channel state) (let* ((failed-p (and (consp ctx) (eq (car ctx) :failed))) (actual-ctx (if failed-p (cdr ctx) ctx))) (mv-let (erp val state) (state-global-let* ((fmt-hard-right-margin 1000 set-fmt-hard-right-margin) (fmt-soft-right-margin 1000 set-fmt-soft-right-margin)) (mv-let (col state) (fmt-ctx actual-ctx 0 channel state) (mv-let (col state) (fmt1 "~|~@0" (list (cons #\0 (if failed-p *proof-failure-string* ""))) col channel state nil) (declare (ignore col)) (value nil)))) (declare (ignore erp val)) state)))
*proof-tree-start-delimiter*constant
(defconst *proof-tree-start-delimiter* "#<\<0")
*proof-tree-end-delimiter*constant
(defconst *proof-tree-end-delimiter* "#>\>")
print-proof-tree-finishfunction
(defun print-proof-tree-finish (state) (if (f-get-global 'proof-tree-start-printed state) (pprogn (mv-let (col state) (fmt1! "~s0" (list (cons #\0 *proof-tree-end-delimiter*)) 0 (proofs-co state) state nil) (declare (ignore col)) (f-put-global 'proof-tree-start-printed nil state))) state))
print-proof-treefunction
(defun print-proof-tree (state) (let ((chan (proofs-co state)) (ctx (f-get-global 'proof-tree-ctx state))) (pprogn (if (f-get-global 'window-interfacep state) state (pprogn (f-put-global 'proof-tree-start-printed t state) (mv-let (col state) (fmt1 "~s0" (list (cons #\0 *proof-tree-start-delimiter*)) 0 chan state nil) (declare (ignore col)) state))) (print-proof-tree-ctx ctx chan state) (print-proof-tree1 ctx chan state) (print-proof-tree-finish state))))
decorate-forced-goals-1mutual-recursion
(mutual-recursion (defun decorate-forced-goals-1 (goal-tree clause-id-list forced-clause-id) (let ((cl-id (access goal-tree goal-tree :cl-id)) (new-children (decorate-forced-goals-1-lst (access goal-tree goal-tree :children) clause-id-list forced-clause-id))) (cond ((member-equal cl-id clause-id-list) (let ((processor (access goal-tree goal-tree :processor))) (change goal-tree goal-tree :processor (list* (car processor) :forced forced-clause-id (cddr processor)) :children new-children))) (t (change goal-tree goal-tree :children new-children))))) (defun decorate-forced-goals-1-lst (goal-tree-lst clause-id-list forced-clause-id) (cond ((null goal-tree-lst) nil) ((atom goal-tree-lst) (er hard 'decorate-forced-goals-1-lst "Unexpected goal-tree in call ~x0" (list 'decorate-forced-goals-1-lst goal-tree-lst clause-id-list forced-clause-id))) (t (cons (decorate-forced-goals-1 (car goal-tree-lst) clause-id-list forced-clause-id) (decorate-forced-goals-1-lst (cdr goal-tree-lst) clause-id-list forced-clause-id))))))
decorate-forced-goalsfunction
(defun decorate-forced-goals (forcing-round goal-tree clause-id-list-list n) (if (null clause-id-list-list) goal-tree (decorate-forced-goals forcing-round (decorate-forced-goals-1 goal-tree (car clause-id-list-list) (make clause-id :forcing-round forcing-round :pool-lst nil :case-lst (and n (list n)) :primes 0)) (cdr clause-id-list-list) (and n (1- n)))))
decorate-forced-goals-in-proof-treefunction
(defun decorate-forced-goals-in-proof-tree (forcing-round proof-tree clause-id-list-list n) (if (null proof-tree) nil (cons (decorate-forced-goals forcing-round (car proof-tree) clause-id-list-list n) (decorate-forced-goals-in-proof-tree forcing-round (cdr proof-tree) clause-id-list-list n))))
assumnote-list-to-clause-id-listfunction
(defun assumnote-list-to-clause-id-list (assumnote-list) (if (null assumnote-list) nil (cons (access assumnote (car assumnote-list) :cl-id) (assumnote-list-to-clause-id-list (cdr assumnote-list)))))
assumnote-list-list-to-clause-id-list-listfunction
(defun assumnote-list-list-to-clause-id-list-list (assumnote-list-list) (if (null assumnote-list-list) nil (cons (assumnote-list-to-clause-id-list (car assumnote-list-list)) (assumnote-list-list-to-clause-id-list-list (cdr assumnote-list-list)))))
extend-proof-tree-for-forcing-roundfunction
(defun extend-proof-tree-for-forcing-round (forcing-round parent-clause-id clause-id-list-list state) (cond ((null clause-id-list-list) state) (t (let ((n (length clause-id-list-list))) (f-put-global 'proof-tree (cons (make goal-tree :cl-id parent-clause-id :processor :forcing-round :children n :fanout n) (decorate-forced-goals-in-proof-tree forcing-round (f-get-global 'proof-tree state) clause-id-list-list (if (null (cdr clause-id-list-list)) nil (length clause-id-list-list)))) state)))))
initialize-proof-tree1function
(defun initialize-proof-tree1 (parent-clause-id x pool-lst forcing-round ctx state) (pprogn (start-proof-tree-fn nil state) (f-put-global 'proof-tree-ctx ctx state) (cond ((and (null pool-lst) (eql forcing-round 0)) (f-put-global 'proof-tree nil state)) (pool-lst (f-put-global 'proof-tree (cons (let ((n (length x))) (make goal-tree :cl-id parent-clause-id :processor :induct :children (if (= n 0) nil n) :fanout n)) (f-get-global 'proof-tree state)) state)) (t (extend-proof-tree-for-forcing-round forcing-round parent-clause-id (assumnote-list-list-to-clause-id-list-list (strip-cars x)) state)))))
initialize-proof-treefunction
(defun initialize-proof-tree (parent-clause-id x ctx state) (let ((pool-lst (access clause-id parent-clause-id :pool-lst)) (forcing-round (access clause-id parent-clause-id :forcing-round))) (pprogn (io? proof-tree nil state (ctx forcing-round pool-lst x parent-clause-id) (initialize-proof-tree1 parent-clause-id x pool-lst forcing-round ctx state)) (io? prove nil state (forcing-round pool-lst) (cond ((intersectp-eq '(prove proof-tree) (f-get-global 'inhibit-output-lst state)) state) ((and (null pool-lst) (eql forcing-round 0)) (fms "<< Starting proof tree logging >>~|" nil (proofs-co state) state nil)) (t state))))))
*star-1-clause-id*constant
(defconst *star-1-clause-id* (make clause-id :forcing-round 0 :pool-lst '(1) :case-lst nil :primes 0))
revert-goal-tree-recmutual-recursion
(mutual-recursion (defun revert-goal-tree-rec (cl-id revertp goal-tree) (let ((processor (access goal-tree goal-tree :processor))) (cond ((and (consp processor) (eq (car processor) 'push-clause)) (mv (equal cl-id (access goal-tree goal-tree :cl-id)) (if revertp (change goal-tree goal-tree :processor (list 'push-clause *star-1-clause-id* :revert)) goal-tree))) (t (mv-let (cl-id-foundp new-children) (revert-goal-tree-lst (eq processor 'apply-top-hints-clause-or-hit) cl-id revertp (access goal-tree goal-tree :children)) (mv cl-id-foundp (change goal-tree goal-tree :children new-children))))))) (defun revert-goal-tree-lst (or-p cl-id revertp goal-tree-lst) (cond ((atom goal-tree-lst) (mv nil nil)) (t (mv-let (cl-id-foundp new-goal-tree) (revert-goal-tree-rec cl-id revertp (car goal-tree-lst)) (cond ((or (eq cl-id-foundp :or-found) (and cl-id-foundp or-p)) (mv :or-found (cons new-goal-tree (cdr goal-tree-lst)))) (t (mv-let (cl-id-foundp2 new-goal-tree-lst) (revert-goal-tree-lst or-p cl-id revertp (cdr goal-tree-lst)) (mv (or cl-id-foundp2 cl-id-foundp) (cons (if (eq cl-id-foundp2 :or-found) (car goal-tree-lst) new-goal-tree) new-goal-tree-lst))))))))))
revert-goal-treefunction
(defun revert-goal-tree (cl-id revertp goal-tree) (mv-let (cl-id-foundp new-goal-tree) (revert-goal-tree-rec cl-id revertp goal-tree) (assert$ cl-id-foundp new-goal-tree)))
pool-lst1function
(defun pool-lst1 (pool n ans) (cond ((null pool) (cons n ans)) ((eq (access pool-element (car pool) :tag) 'to-be-proved-by-induction) (pool-lst1 (cdr pool) (1+ n) ans)) (t (pool-lst1 (cdr pool) 1 (cons n ans)))))
increment-proof-treefunction
(defun increment-proof-tree (cl-id ttree processor clause-count new-hist signal pspv state) (if (or (eq processor 'settled-down-clause) (and (consp new-hist) (consp (access history-entry (car new-hist) :processor)))) state (let* ((forcing-round (access clause-id cl-id :forcing-round)) (aborting-p (and (eq signal 'abort) (not (equal (tagged-objects 'abort-cause ttree) '(revert))))) (clause-count (cond ((eq signal 'or-hit) (assert$ (eq processor 'apply-top-hints-clause) (length (nth 2 (tagged-object :or ttree))))) (t clause-count))) (processor (cond ((tagged-objectsp 'assumption ttree) (assert$ (and (not (eq processor 'push-clause)) (not (eq signal 'or-hit))) (list processor :forced))) ((eq processor 'push-clause) (list* 'push-clause (make clause-id :forcing-round forcing-round :pool-lst (pool-lst (cdr (access prove-spec-var pspv :pool))) :case-lst nil :primes 0) (if aborting-p '(:abort) nil))) ((eq signal 'or-hit) 'apply-top-hints-clause-or-hit) (t processor))) (starting-proof-tree (f-get-global 'proof-tree state)) (new-goal-tree (insert-into-goal-tree cl-id processor (if (eql clause-count 0) nil clause-count) (car starting-proof-tree)))) (pprogn (if new-goal-tree (f-put-global 'proof-tree (if (and (consp processor) (eq (car processor) 'push-clause) (eq signal 'abort) (not aborting-p)) (if (and (= forcing-round 0) (null (cdr starting-proof-tree))) (list (revert-goal-tree cl-id t new-goal-tree)) (er hard 'increment-proof-tree "Internal Error: Attempted to ``revert'' ~ the proof tree with forcing round ~x0 and ~ proof tree of length ~x1. This reversion ~ should only have been tried with forcing ~ round 0 and proof tree of length 1. ~ Please contact the ACL2 implementors." forcing-round (length starting-proof-tree))) (prune-proof-tree forcing-round nil (cons (if (eq signal 'abort) (revert-goal-tree cl-id nil new-goal-tree) new-goal-tree) (cdr starting-proof-tree)))) state) (prog2$ (er hard 'increment-proof-tree "Found empty goal tree from call ~x0" (list 'insert-into-goal-tree cl-id processor (if (= clause-count 0) nil clause-count) (car starting-proof-tree))) state)) (print-proof-tree state)))))
goal-tree-with-cl-idfunction
(defun goal-tree-with-cl-id (cl-id goal-tree-lst) (cond ((atom goal-tree-lst) nil) ((equal cl-id (access goal-tree (car goal-tree-lst) :cl-id)) (car goal-tree-lst)) (t (goal-tree-with-cl-id cl-id (cdr goal-tree-lst)))))
goal-tree-choose-disjunct-recmutual-recursion
(mutual-recursion (defun goal-tree-choose-disjunct-rec (cl-id disjunct-cl-id goal-tree) (let ((children (access goal-tree goal-tree :children))) (cond ((equal cl-id (access goal-tree goal-tree :cl-id)) (assert$ (eq (access goal-tree goal-tree :processor) 'apply-top-hints-clause-or-hit) (let ((child (goal-tree-with-cl-id disjunct-cl-id children))) (mv t (cond (child (change goal-tree goal-tree :children (list child))) (t (change goal-tree goal-tree :children nil))))))) ((atom children) (mv nil goal-tree)) (t (mv-let (found new-children) (goal-tree-choose-disjunct-lst cl-id disjunct-cl-id children) (cond (found (mv t (change goal-tree goal-tree :children new-children))) (t (mv nil goal-tree)))))))) (defun goal-tree-choose-disjunct-lst (cl-id disjunct-cl-id goal-tree-lst) (cond ((consp goal-tree-lst) (mv-let (found new-goal-tree) (goal-tree-choose-disjunct-rec cl-id disjunct-cl-id (car goal-tree-lst)) (cond (found (mv t (cons new-goal-tree (cdr goal-tree-lst)))) (t (mv-let (found new-goal-tree-lst) (goal-tree-choose-disjunct-lst cl-id disjunct-cl-id (cdr goal-tree-lst)) (cond (found (mv t (cons (car goal-tree-lst) new-goal-tree-lst))) (t (mv nil goal-tree-lst)))))))) (t (mv nil goal-tree-lst)))))
goal-tree-choose-disjunctfunction
(defun goal-tree-choose-disjunct (cl-id disjunct-cl-id goal-tree) (mv-let (foundp new-goal-tree) (goal-tree-choose-disjunct-rec cl-id disjunct-cl-id goal-tree) (assert$ foundp new-goal-tree)))
install-disjunct-into-proof-treefunction
(defun install-disjunct-into-proof-tree (cl-id disjunct-cl-id state) (let ((proof-tree (f-get-global 'proof-tree state))) (assert$ (consp proof-tree) (pprogn (f-put-global 'proof-tree (prune-proof-tree (access clause-id cl-id :forcing-round) nil (cons (goal-tree-choose-disjunct cl-id disjunct-cl-id (car proof-tree)) (cdr proof-tree))) state) (print-proof-tree state)))))
logical-namepfunction
(defun logical-namep (name wrld) (declare (xargs :guard (and (plist-worldp wrld) (known-package-alistp (global-val 'known-package-alist wrld))))) (cond ((symbolp name) (cond ((eq name :here) (not (null wrld))) (t (getpropc name 'absolute-event-number nil wrld)))) ((and (stringp name) (find-non-hidden-package-entry name (global-val 'known-package-alist wrld))) t) (t nil)))
logical-name-type-stringfunction
(defun logical-name-type-string (typ) (case typ (package "package") (function "function") (macro "macro") (const "constant") (stobj "single-threaded object") (stobj-live-var "single-threaded object live var") (theorem "theorem") (theory "theory") (label "label") (t (symbol-name typ))))
scan-to-commandfunction
(defun scan-to-command (wrld) (cond ((null wrld) nil) ((and (eq (caar wrld) 'command-landmark) (eq (cadar wrld) 'global-value)) wrld) (t (scan-to-command (cdr wrld)))))
update-world-indexfunction
(defun update-world-index (flg wrld) (cond ((eq flg 'event) (let ((n (max-absolute-event-number wrld))) (cond ((= (mod n *event-index-interval*) 0) (let ((event-index (global-val 'event-index wrld))) (cond ((= (floor n *event-index-interval*) (if (null event-index) 0 (1+ (car event-index)))) (global-set 'event-index (add-to-zap-table wrld event-index) wrld)) (t (er hard 'update-world-index "The event-index and the maximum absolute ~ event number have gotten out of sync! ~ In particular, the next available index ~ is ~x0 but the world has event number ~ ~x1, which requires index ~x2." (if (null event-index) 0 (1+ (car event-index))) n (floor n *event-index-interval*)))))) (t wrld)))) (t (let ((n (max-absolute-command-number wrld))) (cond ((= (mod n *command-index-interval*) 0) (let ((command-index (global-val 'command-index wrld))) (cond ((= (floor n *command-index-interval*) (if (null command-index) 0 (1+ (car command-index)))) (global-set 'command-index (add-to-zap-table wrld command-index) wrld)) (t (er hard 'update-world-index "The command-index and the maximum ~ absolute command number have gotten out ~ of sync! In particular, the next ~ available index is ~x0 but the world has ~ command number ~x1, which requires index ~ ~x2." (if (null command-index) 0 (1+ (car command-index))) n (floor n *command-index-interval*)))))) (t wrld))))))
store-absolute-event-numberfunction
(defun store-absolute-event-number (namex n wrld boot-strap-flg) (cond ((equal namex 0) wrld) ((atom namex) (cond ((symbolp namex) (putprop namex 'absolute-event-number n (cond (boot-strap-flg (putprop namex 'predefined t wrld)) (t wrld)))) (t wrld))) (t (store-absolute-event-number (or (cdr namex) 0) n (if (stringp (car namex)) wrld (putprop (car namex) 'absolute-event-number n (cond (boot-strap-flg (putprop (car namex) 'predefined t wrld)) (t wrld)))) boot-strap-flg))))
the-namex-symbol-class1function
(defun the-namex-symbol-class1 (lst wrld symbol-class1) (cond ((null lst) symbol-class1) ((stringp (car lst)) (the-namex-symbol-class1 (cdr lst) wrld symbol-class1)) (t (let ((symbol-class2 (symbol-class (car lst) wrld))) (cond ((eq symbol-class1 nil) (the-namex-symbol-class1 (cdr lst) wrld symbol-class2)) ((eq symbol-class2 nil) (the-namex-symbol-class1 (cdr lst) wrld symbol-class1)) ((eq symbol-class1 symbol-class2) (the-namex-symbol-class1 (cdr lst) wrld symbol-class1)) (t (er hard 'the-namex-symbol-class "The symbolp elements of the namex argument ~ to add-event-landmark are all supposed to ~ have the same symbol-class, but the first ~ one we found with a symbol-class had class ~ ~x0 and now we've found another with ~ symbol-class ~x1. The list of elements, ~ starting with the one that has ~ symbol-class ~x0 is ~x2." symbol-class2 symbol-class1 lst)))))))
the-namex-symbol-classfunction
(defun the-namex-symbol-class (namex wrld) (cond ((equal namex 0) nil) ((atom namex) (cond ((symbolp namex) (symbol-class namex wrld)) (t nil))) (t (the-namex-symbol-class1 namex wrld nil))))
add-event-landmarkfunction
(defun add-event-landmark (form ev-type namex wrld boot-strap-flg skipped-proofs-p local-p) (let* ((n (next-absolute-event-number wrld)) (wrld1 (store-absolute-event-number namex n wrld boot-strap-flg)) (wrld2 (update-world-index 'event wrld1)) (wrld3 (global-set 'event-landmark (make-event-tuple n (length (global-val 'embedded-event-lst wrld)) form ev-type namex (the-namex-symbol-class namex wrld2) skipped-proofs-p local-p) wrld2))) wrld3))
er-decode-logical-namefunction
(defun er-decode-logical-name (name wrld ctx state) (let ((wrld1 (decode-logical-name name wrld))) (cond ((null wrld1) (er soft ctx "The object ~x0 is not a logical name. See :DOC logical-name." name)) (t (value wrld1)))))
renew-lemmasfunction
(defun renew-lemmas (fn lemmas) (cond ((null lemmas) nil) ((eq (base-symbol (access rewrite-rule (car lemmas) :rune)) fn) (renew-lemmas fn (cdr lemmas))) (t (cons (car lemmas) (renew-lemmas fn (cdr lemmas))))))
renew-name/erasefunction
(defun renew-name/erase (name old-getprops wrld) (cond ((null old-getprops) wrld) (t (renew-name/erase name (cdr old-getprops) (if (member-eq (caar old-getprops) '(global-value table-alist table-guard)) wrld (putprop name (caar old-getprops) *acl2-property-unbound* wrld))))))
renew-name/overwritefunction
(defun renew-name/overwrite (name old-getprops wrld) (cond ((null old-getprops) wrld) ((eq (caar old-getprops) 'redefined) (renew-name/overwrite name (cdr old-getprops) wrld)) ((member-eq (caar old-getprops) '(formals stobjs-in stobjs-out symbol-class non-executablep siblings level-no tau-pair quick-block-info primitive-recursive-defunp constrainedp hereditarily-constrained-fnnames def-bodies induction-machine justification unnormalized-body constraint-lst-etc recursivep loop$-recursion type-prescriptions guard split-types-term invariant-risk absolute-event-number runic-mapping-pairs stobj-function global-stobjs)) (renew-name/overwrite name (cdr old-getprops) (putprop name (caar old-getprops) *acl2-property-unbound* wrld))) ((eq (caar old-getprops) 'lemmas) (renew-name/overwrite name (cdr old-getprops) (putprop name 'lemmas (renew-lemmas name (getpropc name 'lemmas nil wrld)) wrld))) ((member-eq (caar old-getprops) '(global-value linear-lemmas forward-chaining-rules eliminate-destructors-rules coarsenings congruences recognizer-alist pequivs induction-rules defchoose-axiom table-guard table-alist predefined defaxiom-supporter attachment clause-processor tau-pair-saved pos-implicants neg-implicants unevalable-but-known signature-rules-form-1 signature-rules-form-2 big-switch tau-bounders-form-1 tau-bounders-form-2)) (renew-name/overwrite name (cdr old-getprops) wrld)) (t (illegal 'renew-name/overwrite "We thought we knew all the properties stored by events ~ introducing redefinable function names, but we don't know about ~ the property ~x0." (list (cons #\0 (caar old-getprops)))))))
renew-namefunction
(defun renew-name (name renewal-mode wrld) (putprop name 'redefined (cons renewal-mode (cond ((and (symbolp name) (function-symbolp name wrld)) (list name (formals name wrld) (stobjs-in name wrld) (getpropc name 'stobjs-out '(nil) wrld))) (t nil))) (cond ((eq renewal-mode :erase) (renew-name/erase name (getprops name 'current-acl2-world wrld) wrld)) ((or (eq renewal-mode :overwrite) (eq renewal-mode :reclassifying-overwrite)) (renew-name/overwrite name (getprops name 'current-acl2-world wrld) wrld)) (t wrld))))
renew-namesfunction
(defun renew-names (names renewal-mode wrld) (cond ((endp names) wrld) (t (renew-names (cdr names) renewal-mode (renew-name (car names) renewal-mode wrld)))))
collect-redefinedfunction
(defun collect-redefined (wrld ans) (cond ((or (null wrld) (and (eq (caar wrld) 'event-landmark) (eq (cadar wrld) 'global-value))) ans) ((and (eq (cadar wrld) 'redefined) (consp (cddar wrld)) (not (eq (car (cddar wrld)) :reclassifying-overwrite))) (collect-redefined (cdr wrld) (cons (caar wrld) ans))) (t (collect-redefined (cdr wrld) ans))))
scrunch-eqfunction
(defun scrunch-eq (lst) (cond ((null lst) nil) ((member-eq (car lst) (cdr lst)) (scrunch-eq (cdr lst))) (t (cons (car lst) (scrunch-eq (cdr lst))))))
print-redefinition-warningfunction
(defun print-redefinition-warning (wrld ctx state) (cond ((warning-disabled-p "Redef") state) ((let ((act (f-get-global 'ld-redefinition-action state))) (and (consp act) (or (eq (car act) :warn) (eq (car act) :warn!)))) (let* ((wrld (scan-to-event wrld)) (redefs (scrunch-eq (reverse (collect-redefined (cdr wrld) nil))))) (cond (redefs (warning$ ctx ("Redef") "~&0 redefined.~%" redefs)) (t state)))) (t state)))
get-event-data-1function
(defun get-event-data-1 (key event-data) (cdr (assoc-eq key event-data)))
get-event-datafunction
(defun get-event-data (key state) (get-event-data-1 key (f-get-global 'last-event-data state)))
put-event-datafunction
(defun put-event-data (key val state) (f-put-global 'last-event-data (acons key val (f-get-global 'last-event-data state)) state))
last-prover-stepsfunction
(defun last-prover-steps (state) (get-event-data 'prover-steps-counted state))
initialize-summary-accumulatorsfunction
(defun initialize-summary-accumulators (state) (cond ((global-val 'include-book-path (w state)) state) (t (progn$ (time-tracker :tau :end) (time-tracker :tau :init :times '(1 5) :interval 10 :msg (concatenate 'string (if (f-get-global 'get-internal-time-as-realtime state) "Elapsed realtime" "Elapsed runtime") " in tau is ~st secs; see :DOC time-tracker-tau.~|~%")) (pprogn (cond ((null (cdr (get-timer 'other-time state))) (mv-let (x state) (main-timer state) (declare (ignore x)) state)) (t (increment-timer 'other-time state))) (push-timer 'other-time 0 state) (push-timer 'prove-time 0 state) (push-timer 'print-time 0 state) (push-timer 'proof-tree-time 0 state) (push-warning-frame state))))))
clear-warning-summaries-alistfunction
(defun clear-warning-summaries-alist (alist) (cond ((endp alist) nil) ((and (stringp (car (car alist))) (member-string-equal (car (car alist)) *tracked-warning-summaries*)) (clear-warning-summaries-alist (cdr alist))) (t (cons (car alist) (clear-warning-summaries-alist (cdr alist))))))
clear-warning-summariesfunction
(defun clear-warning-summaries nil (wormhole 'comment-window-io '(lambda (whs) (make-wormhole-status whs :skip (clear-warning-summaries-alist (wormhole-data whs)))) nil nil))
print-warnings-summaryfunction
(defun print-warnings-summary (state) (mv-let (warnings state) (pop-warning-frame t state) (pprogn (put-event-data 'warnings warnings state) (io? summary nil state (warnings) (cond ((member-eq 'warnings (f-get-global 'inhibited-summary-types state)) state) ((null warnings) state) (t (let ((channel (proofs-co state))) (mv-let (col state) (fmt1 "Warnings: ~*0~%" (list (cons #\0 (list "None" "~s*" "~s* and " "~s*, " warnings))) 0 channel state nil) (declare (ignore col)) state))))))))
skip-proof-tree-timefunction
(defun skip-proof-tree-time (state) (and (member-eq 'proof-tree (f-get-global 'inhibit-output-lst state)) (= (car (get-timer 'proof-tree-time state)) 0)))
print-time-summaryfunction
(defun print-time-summary (state) (pprogn (cond ((member-eq 'time (f-get-global 'inhibited-summary-types state)) state) (t (let ((skip-proof-tree-time (skip-proof-tree-time state))) (pprogn (push-timer 'total-time 0 state) (add-timers 'total-time 'prove-time state) (add-timers 'total-time 'print-time state) (add-timers 'total-time 'proof-tree-time state) (add-timers 'total-time 'other-time state) (let ((total-time (car (get-timer 'total-time state))) (prove-time (car (get-timer 'prove-time state))) (print-time (car (get-timer 'print-time state))) (proof-tree-time (and (not skip-proof-tree-time) (car (get-timer 'proof-tree-time state)))) (other-time (car (get-timer 'other-time state)))) (io? summary nil state (total-time prove-time print-time proof-tree-time other-time) (let ((channel (proofs-co state))) (pprogn (princ$ "Time: " channel state) (print-rational-as-decimal total-time channel state) (princ$ " seconds (prove: " channel state) (print-rational-as-decimal prove-time channel state) (princ$ ", print: " channel state) (print-rational-as-decimal print-time channel state) (if (null proof-tree-time) state (pprogn (princ$ ", proof tree: " channel state) (print-rational-as-decimal proof-tree-time channel state))) (princ$ ", other: " channel state) (print-rational-as-decimal other-time channel state) (princ$ ")" channel state) (newline channel state))))) (pop-timer 'total-time nil state))))) (pop-timer 'prove-time t state) (pop-timer 'print-time t state) (pop-timer 'proof-tree-time t state) (pop-timer 'other-time t state)))
prover-stepsfunction
(defun prover-steps (state) (let* ((rec (f-get-global 'step-limit-record state)) (start (assert$ rec (access step-limit-record rec :start))) (last-limit (assert$ start (f-get-global 'last-step-limit state)))) (cond ((and last-limit (not (int= start last-limit))) (cond ((eql last-limit -1) (assert$ (natp start) (- start))) (t (- start last-limit)))) (t nil))))
print-steps-summaryfunction
(defun print-steps-summary (steps state) (cond ((null steps) state) (t (io? summary nil state (steps) (cond ((member-eq 'steps (f-get-global 'inhibited-summary-types state)) state) (t (let ((channel (proofs-co state))) (pprogn (princ$ "Prover steps counted: " channel state) (cond ((<= steps 0) (pprogn (princ$ "More than " channel state) (princ$ (- steps) channel state))) (t (princ$ steps channel state))) (newline channel state)))))))))
*gag-prefix*constant
(defconst *gag-prefix* "([ ")
*gag-suffix*constant
(defconst *gag-suffix* (msg "])~|"))
gag-start-msgfunction
(defun gag-start-msg (cl-id pool-name) (msg "~@0A key checkpoint~#1~[ while proving ~@2 ~ (descended from ~@3)~/~]:" *gag-prefix* (if cl-id 0 1) pool-name (and cl-id (tilde-@-clause-id-phrase cl-id))))
print-gag-infofunction
(defun print-gag-info (info state) (fms "~@0~%~Q12~|" (list (cons #\0 (tilde-@-clause-id-phrase (access gag-info info :clause-id))) (cons #\1 (prettyify-clause (access gag-info info :clause) (let*-abstractionp state) (w state))) (cons #\2 (term-evisc-tuple nil state))) (proofs-co state) state nil))
set-checkpoint-summary-limit-fnfunction
(defun set-checkpoint-summary-limit-fn (val state) (if (or (eq val nil) (eq val t) (natp val) (and (consp val) (or (null (car val)) (natp (car val))) (or (null (cdr val)) (natp (cdr val))))) (let ((val (if (natp val) (cons val val) val))) (pprogn (f-put-global 'checkpoint-summary-limit val state) (value val))) (er soft 'set-checkpoint-summary-limit "Illegal value, ~x0, for checkpoint-summary-limit; see :DOC ~ set-checkpoint-summary-limit." val)))
set-checkpoint-summary-limitmacro
(defmacro set-checkpoint-summary-limit (val) (let ((x (if (and (consp val) (eq (car val) 'quote)) val (list 'quote val)))) `(set-checkpoint-summary-limit-fn ,X state)))
checkpoint-summary-limitmacro
(defmacro checkpoint-summary-limit nil '(f-get-global 'checkpoint-summary-limit state))
print-gag-stack-revfunction
(defun print-gag-stack-rev (lst limit orig-limit msg chan state) (cond ((endp lst) state) ((eql limit 0) (fms "Note: ~#2~[Not shown~/There~] ~#0~[is~#2~[ the~/~] ~n1~#2~[~/ ~ additional~] key checkpoint~/are~#2~[ the~/~] ~n1~#2~[~/ ~ additional~] key checkpoints~] ~@3. See :DOC ~ set-checkpoint-summary-limit to ~#4~[change the number ~ printed~/print this key checkpoint~/print some or all of these ~ key checkpoints~].~|" (list (cons #\0 lst) (cons #\1 (length lst)) (cons #\2 (if (eql orig-limit 0) 0 1)) (cons #\3 msg) (cons #\4 (cond ((not (eql orig-limit 0)) 0) ((null (cdr lst)) 1) (t 2)))) chan state nil)) (t (pprogn (print-gag-info (car lst) state) (print-gag-stack-rev (cdr lst) (and limit (1- limit)) orig-limit msg chan state)))))
reverse-gag-stackfunction
(defun reverse-gag-stack (stack acc) (cond ((null stack) acc) ((equal (access gag-info (car stack) :clause) nil) (cons (car stack) (revappend (cdr stack) acc))) (t (reverse-gag-stack (cdr stack) (cons (car stack) acc)))))
print-abort-info-cause-msgfunction
(defun print-abort-info-cause-msg (abort-cause) (case abort-cause (empty-clause (msg "~| before generating a goal of ~x0 (see :DOC nil-goal)" 'nil)) (do-not-induct "~| before a :DO-NOT-INDUCT hint stopped the proof attempt") (induction-depth-limit-exceeded "~| before the induction-depth-limit stopped the proof attempt") (otherwise "")))
print-gag-state1function
(defun print-gag-state1 (gag-state state) (cond ((eq (f-get-global 'checkpoint-summary-limit state) t) state) (gag-state (let* ((chan (proofs-co state)) (abort-info (access gag-state gag-state :abort-info)) (abort-stack (abort-info-stack abort-info)) (abort-cause (abort-info-cause abort-info)) (top-stack0 (access gag-state gag-state :top-stack)) (top-stack (or abort-stack top-stack0)) (sub-stack (access gag-state gag-state :sub-stack)) (some-stack (or sub-stack top-stack0)) (forcing-round-p (and some-stack (let ((cl-id (access gag-info (car some-stack) :clause-id))) (not (eql 0 (access clause-id cl-id :forcing-round))))))) (cond (some-stack (pprogn (fms "---~|The key checkpoint goal~#0~[~/s~], below, may help you to ~ debug this failure. See :DOC failure and see :DOC ~ set-checkpoint-summary-limit.~@1~|---~|" (list (cons #\0 (if (or (and top-stack sub-stack) (cdr top-stack) (cdr sub-stack)) 1 0)) (cons #\1 (if forcing-round-p " Note that at least one checkpoint is in a ~ forcing round, so you may want to see a full ~ proof." ""))) chan state nil) (cond (top-stack (let ((limit (car (f-get-global 'checkpoint-summary-limit state)))) (pprogn (fms "*** Key checkpoint~#0~[~/s~] ~#1~[before reverting ~ to proof by induction~/at the top level~@2~]: ***" (list (cons #\0 top-stack) (cons #\1 (if (consp abort-stack) 0 1)) (cons #\2 (if sub-stack "" (print-abort-info-cause-msg abort-cause)))) chan state nil) (newline chan state) (print-gag-stack-rev (reverse-gag-stack top-stack nil) limit limit "before induction" chan state)))) (t state)) (cond (sub-stack (let ((limit (cdr (f-get-global 'checkpoint-summary-limit state)))) (pprogn (fms "*** Key checkpoint~#0~[~/s~] under a top-level ~ induction~@1: ***" (list (cons #\0 sub-stack) (cons #\1 (print-abort-info-cause-msg abort-cause))) chan state nil) (newline chan state) (print-gag-stack-rev (reverse-gag-stack sub-stack nil) limit limit "under a top-level induction" chan state)))) (t state)))) (t (fms "*** Note: No checkpoints~#0~[ from gag-mode~/~] to print. ***~|" (list (cons #\0 (if (@ waterfall-parallelism) 0 1))) chan state nil))))) (t state)))
save-and-print-gag-statefunction
(defun save-and-print-gag-state (state) (let ((gag-state (f-get-global 'gag-state state))) (pprogn (if gag-state (f-put-global 'gag-state-saved gag-state state) state) (f-put-global 'gag-state nil state) (io? summary nil state (gag-state) (print-gag-state1 gag-state state)))))
tilde-@pfunction
(defun tilde-@p (arg) (declare (xargs :guard t)) (or (stringp arg) (and (consp arg) (stringp (car arg)) (character-alistp (cdr arg)))))
collect-definition-rune-fnsfunction
(defun collect-definition-rune-fns (fns runes) (cond ((endp runes) nil) ((and (eq (caar runes) :definition) (member-eq (base-symbol (car runes)) fns)) (cons (base-symbol (car runes)) (collect-definition-rune-fns fns (cdr runes)))) (t (collect-definition-rune-fns fns (cdr runes)))))
print-failure1function
(defun print-failure1 (erp acc-ttree ctx state) (let ((channel (proofs-co state))) (pprogn (error-fms-channel nil ctx "Failure" "~@0See :DOC failure.~@1~#2~[~|*NOTE*: Useless-runes were in use and ~ can affect proof attempts. See :DOC useless-runes-failures.~/~]" (list (cons #\0 (if (tilde-@p erp) erp "")) (cons #\1 (if (global-val 'projects/apply/base-includedp (w state)) "" (let ((loop$-fns (collect-definition-rune-fns *loop$-special-function-symbols* (tagged-objects 'lemma acc-ttree)))) (if loop$-fns (msg "~|*NOTE*: The definition~#0~[ of ~&0 was~/s ~ of ~&0 were~] used in the proof attempt, but ~ a relevant book has not been included. ~ Consider first evaluating ~x1." loop$-fns '(include-book "projects/apply/top" :dir :system)) "")))) (cons #\2 (if (and acc-ttree (not (ld-skip-proofsp state)) (let ((useless-runes (f-get-global 'useless-runes state))) (and useless-runes (not (eq (access useless-runes useless-runes :tag) 'channel))))) 0 1))) channel state 1) (io? summary nil state (channel) (fms *proof-failure-string* nil channel state nil)))))
print-failurefunction
(defun print-failure (erp event-type acc-ttree ctx state) (pprogn (save-and-print-gag-state state) (cond ((not (member-eq event-type '(encapsulate progn defun make-event make-event-save-event-data))) (cond ((output-ignored-p 'error state) (io? summary nil state (erp acc-ttree ctx) (print-failure1 erp acc-ttree ctx state))) (t (print-failure1 erp acc-ttree ctx state)))) ((member-eq 'errors (f-get-global 'inhibited-summary-types state)) state) (t (io? summary nil state (erp acc-ttree ctx) (print-failure1 erp acc-ttree ctx state))))))
lmi-seedfunction
(defun lmi-seed (lmi) (cond ((atom lmi) lmi) (t (case (car lmi) ((:instance :functional-instance) (lmi-seed (cadr lmi))) (:theorem (cadr lmi)) ((:termination-theorem :termination-theorem!) (list :termination-theorem (cadr lmi))) (:guard-theorem (list :guard-theorem (cadr lmi))) (otherwise (base-symbol lmi))))))
lmi-techsfunction
(defun lmi-techs (lmi) (cond ((atom lmi) nil) ((eq (car lmi) '(:theorem :termination-theorem :termination-theorem! :guard-theorem)) nil) ((eq (car lmi) :instance) (add-to-set-equal "in~-stan~-ti~-a~-tion" (lmi-techs (cadr lmi)))) ((eq (car lmi) :functional-instance) (add-to-set-equal "functional in~-stan~-ti~-a~-tion" (lmi-techs (cadr lmi)))) (t nil)))
lmi-seed-lstfunction
(defun lmi-seed-lst (lmi-lst) (cond ((null lmi-lst) nil) (t (add-to-set-equal (lmi-seed (car lmi-lst)) (lmi-seed-lst (cdr lmi-lst))))))
lmi-techs-lstfunction
(defun lmi-techs-lst (lmi-lst) (cond ((null lmi-lst) nil) (t (union-equal (lmi-techs (car lmi-lst)) (lmi-techs-lst (cdr lmi-lst))))))
lmi-seeds-infofunction
(defun lmi-seeds-info (flg lst) (cond ((endp lst) nil) (t (let ((lmi-type (cond ((mbe :logic (atom (car lst)) :exec (symbolp (car lst))) 'name) ((member-eq (car (car lst)) '(:termination-theorem :guard-theorem)) 'extended-name) (t 'theorem)))) (cond ((eq flg t) (case lmi-type (name (cons (car lst) (lmi-seeds-info flg (cdr lst)))) (extended-name (cons (cadr (car lst)) (lmi-seeds-info flg (cdr lst)))) (otherwise (lmi-seeds-info flg (cdr lst))))) ((iff flg (eq lmi-type 'theorem)) (lmi-seeds-info flg (cdr lst))) (t (cons (car lst) (lmi-seeds-info flg (cdr lst)))))))))
print-runes-summaryfunction
(defun print-runes-summary (ttree state) (let ((runes (merge-sort-runes (all-runes-in-ttree ttree nil)))) (pprogn (put-event-data 'rules runes state) (io? summary nil state (runes) (let ((channel (proofs-co state))) (mv-let (col state) (fmt1 "Rules: ~y0~|" (list (cons #\0 runes)) 0 channel state nil) (declare (ignore col)) state))))))
use-names-in-ttreefunction
(defun use-names-in-ttree (ttree names-only) (let* ((objs (tagged-objects :use ttree)) (lmi-lst (append-lst (strip-cars (strip-cars objs)))) (seeds (lmi-seed-lst lmi-lst))) (if names-only (lmi-seeds-info t seeds) (lmi-seeds-info 'hint-events seeds))))
by-names-in-ttreefunction
(defun by-names-in-ttree (ttree names-only) (let* ((objs (tagged-objects :by ttree)) (lmi-lst (append-lst (strip-cars objs))) (seeds (lmi-seed-lst lmi-lst))) (if names-only (lmi-seeds-info t seeds) (lmi-seeds-info 'hint-events seeds))))
other
(defrec clause-processor-hint (term stobjs-out . verified-p) nil)
collect-non-hint-eventsfunction
(defun collect-non-hint-events (lst non-symbols-okp) (declare (xargs :guard (true-listp lst))) (cond ((endp lst) nil) (t (let ((x (car lst))) (cond ((symbolp x) (collect-non-hint-events (cdr lst) non-symbols-okp)) ((and non-symbols-okp (consp x) (consp (cdr x)) (null (cddr x)) (member-eq (car x) '(:termination-theorem :guard-theorem)) (symbolp (cadr x))) (collect-non-hint-events (cdr lst) non-symbols-okp)) (t (cons x (collect-non-hint-events (cdr lst) non-symbols-okp))))))))
hint-events-symbolsfunction
(defun hint-events-symbols (lst) (declare (xargs :guard (null (collect-non-hint-events lst t)))) (cond ((atom lst) nil) ((symbolp (car lst)) (cons (car lst) (hint-events-symbols (cdr lst)))) (t (cons (cadr (car lst)) (hint-events-symbols (cdr lst))))))
get-summary-datamacro
(defmacro get-summary-data (summary-data field &optional names-only) (declare (xargs :guard (member-eq field '(:use-names :by-names :clause-processor-fns)))) (let ((val-expr `(access summary-data ,SUMMARY-DATA ,FIELD))) `(cond (,NAMES-ONLY (let ((lst ,VAL-EXPR)) (if (symbol-listp lst) lst (hint-events-symbols lst)))) (t ,VAL-EXPR))))
cl-proc-data-in-ttree-1function
(defun cl-proc-data-in-ttree-1 (objs use-names by-names cl-proc-fns names-only) (cond ((endp objs) (mv use-names by-names cl-proc-fns)) (t (let* ((obj (car objs)) (cl-proc-hint (car obj)) (cl-proc-fn (ffn-symb (access clause-processor-hint cl-proc-hint :term))) (new-cl-proc-fns (if (eq cl-proc-fn 'proof-builder-cl-proc) cl-proc-fns (cons cl-proc-fn cl-proc-fns))) (summary-data (cadr obj))) (cond ((null summary-data) (cl-proc-data-in-ttree-1 (cdr objs) use-names by-names new-cl-proc-fns names-only)) (t (cl-proc-data-in-ttree-1 (cdr objs) (append (get-summary-data summary-data :use-names names-only) use-names) (append (get-summary-data summary-data :by-names names-only) by-names) (append (access summary-data summary-data :clause-processor-fns) new-cl-proc-fns) names-only)))))))
cl-proc-data-in-ttreefunction
(defun cl-proc-data-in-ttree (ttree names-only) (cl-proc-data-in-ttree-1 (tagged-objects :clause-processor ttree) nil nil nil names-only))
hint-event-names-in-ttreefunction
(defun hint-event-names-in-ttree (ttree) (mv-let (use-names by-names cl-proc-fns) (cl-proc-data-in-ttree ttree nil) (mv (merge-sort-lexorder (union-equal-removing-duplicates use-names (use-names-in-ttree ttree nil))) (merge-sort-lexorder (union-equal-removing-duplicates by-names (by-names-in-ttree ttree nil))) (sort-symbol-listp cl-proc-fns))))
print-hint-events-summaryfunction
(defun print-hint-events-summary (ttree state) (flet ((make-rune-like-objs (kwd lst) (and lst (pairlis$ (make-list (length lst) :initial-element kwd) (pairlis$ lst nil))))) (mv-let (use-lst by-lst cl-proc-fns) (hint-event-names-in-ttree ttree) (let ((lst (append (make-rune-like-objs :by by-lst) (make-rune-like-objs :clause-processor cl-proc-fns) (make-rune-like-objs :use use-lst)))) (pprogn (put-event-data 'hint-events lst state) (cond (lst (io? summary nil state (lst) (let ((channel (proofs-co state))) (mv-let (col state) (fmt1 "Hint-events: ~y0~|" (list (cons #\0 lst)) 0 channel state nil) (declare (ignore col)) state)))) (t state)))))))
print-splitter-rules-summary-1function
(defun print-splitter-rules-summary-1 (cl-id clauses case-split immed-forced if-intro state) (let ((channel (proofs-co state))) (mv-let (col state) (fmt1 "Splitter ~s0 (see :DOC splitter)~@1~s2~|~@3~@4~@5" (list (cons #\0 (if cl-id "note" "rules")) (cons #\1 (if cl-id (msg " for ~@0 (~x1 subgoal~#2~[~/s~])" (tilde-@-clause-id-phrase cl-id) (length clauses) clauses) "")) (cons #\2 (if cl-id "." ":")) (cons #\3 (cond (case-split (msg " case-split: ~y0" case-split)) (t ""))) (cons #\4 (cond (immed-forced (msg " immed-forced: ~y0" immed-forced)) (t ""))) (cons #\5 (cond (if-intro (msg " if-intro: ~y0" if-intro)) (t "")))) 0 channel state nil) (declare (ignore col)) (cond ((and cl-id (gag-mode)) (newline channel state)) (t state)))))
print-splitter-rules-summaryfunction
(defun print-splitter-rules-summary (cl-id clauses ttree state) (let ((if-intro (merge-sort-runes (tagged-objects 'splitter-if-intro ttree))) (case-split (merge-sort-runes (tagged-objects 'splitter-case-split ttree))) (immed-forced (merge-sort-runes (tagged-objects 'splitter-immed-forced ttree)))) (cond ((or if-intro case-split immed-forced) (cond (cl-id (pprogn (newline (proofs-co state) state) (with-output-lock (print-splitter-rules-summary-1 cl-id clauses case-split immed-forced if-intro state)))) (t (pprogn (put-event-data 'splitter-rules (list case-split immed-forced if-intro) state) (io? summary nil state (cl-id clauses case-split immed-forced if-intro) (print-splitter-rules-summary-1 cl-id clauses case-split immed-forced if-intro state)))))) (cl-id state) (t (put-event-data 'splitter-rules nil state)))))
print-rules-and-hint-events-summaryfunction
(defun print-rules-and-hint-events-summary (acc-ttree state) (let ((inhibited-summary-types (f-get-global 'inhibited-summary-types state))) (pprogn (cond ((member-eq 'rules inhibited-summary-types) state) (t (print-runes-summary acc-ttree state))) (cond ((member-eq 'hint-events inhibited-summary-types) state) (t (print-hint-events-summary acc-ttree state))) (cond ((member-eq 'splitter-rules inhibited-summary-types) state) (t (print-splitter-rules-summary nil nil acc-ttree state))) (f-put-global 'accumulated-ttree nil state))))
modified-system-attachmentfunction
(defun modified-system-attachment (pair recs) (cond ((endp recs) (cons (car pair) nil)) (t (let ((tmp (assoc-eq (car pair) (access attachment (car recs) :pairs)))) (cond (tmp (and (not (eq (cdr tmp) (cdr pair))) tmp)) (t (modified-system-attachment pair (cdr recs))))))))
modified-system-attachments-1function
(defun modified-system-attachments-1 (pairs recs acc) (cond ((endp pairs) acc) (t (modified-system-attachments-1 (cdr pairs) recs (let ((x (modified-system-attachment (car pairs) recs))) (if x (cons x acc) acc))))))
modified-system-attachmentsfunction
(defun modified-system-attachments (state) (let* ((wrld (w state)) (lst (global-val 'attachment-records wrld)) (cache (f-get-global 'system-attachments-cache state))) (cond ((equal lst (car cache)) (value (cdr cache))) (t (let ((mods (modified-system-attachments-1 (global-val 'attachments-at-ground-zero wrld) lst nil))) (pprogn (f-put-global 'system-attachments-cache (cons lst mods) state) (value mods)))))))
print-system-attachments-summaryfunction
(defun print-system-attachments-summary (state) (cond ((f-get-global 'boot-strap-flg state) state) (t (mv-let (erp pairs state) (modified-system-attachments state) (assert$ (null erp) (pprogn (put-event-data 'system-attachments pairs state) (io? summary nil state (pairs) (cond ((member-eq 'system-attachments (f-get-global 'inhibited-summary-types state)) state) ((null pairs) state) (t (let ((channel (proofs-co state))) (mv-let (col state) (fmt1 "Modified system attachments:~| ~y0" (list (cons #\0 (merge-sort-lexorder (alist-to-doublets pairs)))) 0 channel state nil) (declare (ignore col)) state)))))))))))
saving-event-datamacro
(defmacro saving-event-data (form) `(er-progn (assign event-data-fal 'event-data-fal) ,FORM))
event-data-namefunction
(defun event-data-name (event-data event-type) (let ((event (and (not (eq event-type 'thm)) (get-event-data-1 'event event-data)))) (cond ((null event) nil) ((eq event-type 'defun) (cond ((member-eq (car event) '(defuns mutual-recursion)) (let ((def (if (eq (car event) 'mutual-recursion) (cdr (cadr event)) (cadr event)))) (if (and (consp def) (symbolp (car def))) (car def) :no-event-data-name))) ((or (eq (car event) 'defun)) (cadr event)) (t (er hard 'event-data-name "Unexpected call: ~x0" `(event-data-name ',EVENT-DATA ',EVENT-TYPE))))) (t (cadr event)))))
clear-event-datafunction
(defun clear-event-data (state) (f-put-global 'last-event-data nil state))
print-event-datafunction
(defun print-event-data (name event-data channel ctx state) (mv-let (erp val state) (state-global-let* ((current-package "ACL2" set-current-package-state) (fmt-hard-right-margin 10000 set-fmt-hard-right-margin) (fmt-soft-right-margin 10000 set-fmt-soft-right-margin)) (pprogn (print-object$ (cons name event-data) channel state) (value nil))) (declare (ignore val)) (prog2$ (and erp (er hard ctx "Implementation error in print-event-data. Please ~ contact the ACL2 implementors.")) state)))
print-summaryfunction
(defun print-summary (erp noop-flg event-type event ctx state) (let ((wrld (w state))) (cond ((global-val 'include-book-path wrld) (clear-event-data state)) (t (let* ((steps (prover-steps state)) (make-event-save-event-data-p (eq event-type 'make-event-save-event-data)) (old-event-data (and make-event-save-event-data-p (f-get-global 'last-event-data state)))) (pprogn (clear-event-data state) (prog2$ (clear-warning-summaries) state) (let ((trip (car wrld))) (cond ((and (not noop-flg) (eq (car trip) 'event-landmark) (eq (cadr trip) 'global-value)) (put-event-data 'namex (access-event-tuple-namex (cddr trip)) state)) (t state))) (put-event-data 'prover-steps-counted steps state) (put-event-data 'form ctx state) (if event (put-event-data 'event event state) state) (increment-timer 'other-time state) (put-event-data 'time (list (car (get-timer 'prove-time state)) (car (get-timer 'print-time state)) (car (get-timer 'proof-tree-time state)) (car (get-timer 'other-time state))) state) (let ((abort-causes (tagged-objects 'abort-cause (f-get-global 'accumulated-ttree state)))) (if abort-causes (put-event-data 'abort-causes abort-causes state) state)) (cond ((ld-skip-proofsp state) (pprogn (if (or erp noop-flg) state (print-redefinition-warning wrld ctx state)) (pop-timer 'prove-time t state) (pop-timer 'print-time t state) (pop-timer 'proof-tree-time t state) (pop-timer 'other-time t state) (mv-let (warnings state) (pop-warning-frame nil state) (declare (ignore warnings)) state))) (t (let ((output-ignored-p (output-ignored-p 'summary state)) (acc-ttree (f-get-global 'accumulated-ttree state))) (pprogn (if (or erp noop-flg output-ignored-p) state (print-redefinition-warning wrld ctx state)) (io? summary nil state nil (let ((channel (proofs-co state))) (cond ((member-eq 'header (f-get-global 'inhibited-summary-types state)) state) (t (pprogn (newline channel state) (princ$ "Summary" channel state) (newline channel state)))))) (io? summary nil state (ctx) (let ((channel (proofs-co state))) (cond ((member-eq 'form (f-get-global 'inhibited-summary-types state)) state) (t (mv-let (col state) (fmt1 "Form: " nil 0 channel state nil) (mv-let (col state) (fmt-ctx ctx col channel state) (declare (ignore col)) (newline channel state))))))) (print-rules-and-hint-events-summary acc-ttree state) (print-system-attachments-summary state) (print-warnings-summary state) (print-time-summary state) (print-steps-summary steps state) (progn$ (and (not output-ignored-p) (time-tracker :tau :print? :min-time 1 :msg (concatenate 'string "For the proof above, the total " (if (f-get-global 'get-internal-time-as-realtime state) "realtime" "runtime") " spent in the tau system was ~st seconds. See :DOC ~ time-tracker-tau.~|~%"))) state) (cond (erp (cond ((f-get-global 'proof-tree state) (io? proof-tree nil state (ctx) (pprogn (f-put-global 'proof-tree-ctx (cons :failed ctx) state) (print-proof-tree state)))) (t state))) (t (pprogn state))) (f-put-global 'proof-tree nil state))))) (if make-event-save-event-data-p (f-put-global 'last-event-data old-event-data state) state) (if (and (not (eq (ld-skip-proofsp state) 'include-book)) event-type (member-eq event-type '(defthm defun verify-guards thm))) (let* ((info (f-get-global 'certify-book-info state)) (channel (and info (access certify-book-info info :event-data-channel))) (event-data (f-get-global 'last-event-data state)) (edf (f-get-global 'event-data-fal state)) (name (if (or channel edf) (event-data-name event-data event-type) :no-event-data-name))) (cond ((eq name :no-event-data-name) state) (t (pprogn (if channel (print-event-data name event-data channel ctx state) state) (if edf (f-put-global 'event-data-fal (hons-acons name (cons event-data (cdr (hons-get name edf))) edf) state) state))))) state)))))))
with-prover-step-limit-fnfunction
(defun with-prover-step-limit-fn (limit form no-change-flg) (let ((protected-form `(state-global-let* ((step-limit-record (make step-limit-record :start wpsl-limit :strictp wpsl-strictp :sub-limit nil))) (check-vars-not-free (wpsl-limit wpsl-strictp) ,FORM)))) `(mv-let (wpsl-limit wpsl-strictp) (let ((limit ,LIMIT)) (cond ((or (null limit) (eql limit *default-step-limit*)) (mv *default-step-limit* nil)) ((eq limit :start) (let ((rec (f-get-global 'step-limit-record state))) (cond (rec (mv (or (access step-limit-record rec :sub-limit) (f-get-global 'last-step-limit state)) (access step-limit-record rec :strictp))) (t (let ((limit (step-limit-from-table (w state)))) (mv limit (< limit *default-step-limit*))))))) ((and (natp limit) (< limit *default-step-limit*)) (mv limit t)) (t (mv 0 (er hard! 'with-prover-step-limit "Illegal value for ~x0, ~x1. See :DOC ~ with-prover-step-limit." 'with-prover-step-limit limit))))) ,(COND (NO-CHANGE-FLG `(STATE-GLOBAL-LET* ((LAST-STEP-LIMIT WPSL-LIMIT)) ,PROTECTED-FORM)) (T `(LET ((WPSL-OLD-LIMIT (F-GET-GLOBAL 'LAST-STEP-LIMIT STATE))) (PPROGN (F-PUT-GLOBAL 'LAST-STEP-LIMIT WPSL-LIMIT STATE) (MV-LET (ERP VAL STATE) (CHECK-VARS-NOT-FREE (WPSL-OLD-LIMIT) ,PROTECTED-FORM) (LET* ((STEPS-TAKEN (- WPSL-LIMIT (F-GET-GLOBAL 'LAST-STEP-LIMIT STATE))) (NEW-STEP-LIMIT (COND ((< WPSL-OLD-LIMIT STEPS-TAKEN) -1) (T (- WPSL-OLD-LIMIT STEPS-TAKEN))))) (PPROGN (F-PUT-GLOBAL 'LAST-STEP-LIMIT NEW-STEP-LIMIT STATE) (COND (ERP (MV ERP VAL STATE)) ((AND (EQL NEW-STEP-LIMIT -1) (STEP-LIMIT-STRICTP STATE)) (STEP-LIMIT-ERROR T)) (T (VALUE VAL)))))))))))))
with-prover-step-limitmacro
(defmacro with-prover-step-limit (limit form &optional (actual-form 'nil actual-form-p)) (declare (xargs :guard (or (not actual-form-p) (booleanp form)))) (cond (actual-form-p (with-prover-step-limit-fn limit actual-form form)) (t (with-prover-step-limit-fn limit form nil))))
with-prover-step-limit!macro
(defmacro with-prover-step-limit! (limit form &optional no-change-flg) (declare (xargs :guard (booleanp no-change-flg))) (with-prover-step-limit-fn limit form no-change-flg))
other
(defrec proved-functional-instances-alist-entry (constraint-event-name restricted-alist . behalf-of-event-name) t)
supply-name-for-proved-functional-instances-alist-entryfunction
(defun supply-name-for-proved-functional-instances-alist-entry (name lst) (cond ((endp lst) nil) (t (cons (change proved-functional-instances-alist-entry (car lst) :behalf-of-event-name name) (supply-name-for-proved-functional-instances-alist-entry name (cdr lst))))))
proved-functional-instances-from-tagged-objectsfunction
(defun proved-functional-instances-from-tagged-objects (name lst) (cond ((null lst) nil) ((atom (cdr (car lst))) (proved-functional-instances-from-tagged-objects name (cdr lst))) (t (append (supply-name-for-proved-functional-instances-alist-entry name (nth 5 (car lst))) (proved-functional-instances-from-tagged-objects name (cdr lst))))))
add-command-landmarkfunction
(defun add-command-landmark (defun-mode form cbd last-make-event-expansion wrld) (global-set 'command-landmark (make-command-tuple (next-absolute-command-number wrld) defun-mode form cbd last-make-event-expansion) (update-world-index 'command wrld)))
find-longest-common-retraction1function
(defun find-longest-common-retraction1 (wrld1 wrld2) (cond ((equal wrld1 wrld2) wrld1) (t (find-longest-common-retraction1 (scan-to-command (cdr wrld1)) (scan-to-command (cdr wrld2))))))
find-longest-common-retraction1-eventfunction
(defun find-longest-common-retraction1-event (wrld1 wrld2) (cond ((equal wrld1 wrld2) wrld1) (t (find-longest-common-retraction1-event (scan-to-event (cdr wrld1)) (scan-to-event (cdr wrld2))))))
find-longest-common-retractionfunction
(defun find-longest-common-retraction (event-p wrld1 wrld2) (cond (event-p (let* ((n (min (max-absolute-event-number wrld1) (max-absolute-event-number wrld2)))) (find-longest-common-retraction1-event (scan-to-landmark-number 'event-landmark n wrld1) (scan-to-landmark-number 'event-landmark n wrld2)))) (t (let* ((n (min (max-absolute-command-number wrld1) (max-absolute-command-number wrld2)))) (find-longest-common-retraction1 (scan-to-landmark-number 'command-landmark n wrld1) (scan-to-landmark-number 'command-landmark n wrld2))))))
install-global-enabled-structurefunction
(defun install-global-enabled-structure (wrld state) (cond ((null wrld) state) ((active-useless-runes state) state) (t (let* ((augmented-theory (global-val 'current-theory-augmented wrld)) (ens (f-get-global 'global-enabled-structure state)) (theory-array (access enabled-structure ens :theory-array)) (current-theory-index (global-val 'current-theory-index wrld)) (eq-theories (equal augmented-theory (cdr theory-array)))) (cond ((and eq-theories (eql current-theory-index (access enabled-structure ens :index-of-last-enabling))) state) ((and eq-theories (< current-theory-index (car (dimensions (access enabled-structure ens :array-name) theory-array)))) (f-put-global 'global-enabled-structure (change enabled-structure ens :index-of-last-enabling current-theory-index) state)) (t (mv-let (erp new-ens state) (load-theory-into-enabled-structure :no-check augmented-theory t ens nil current-theory-index wrld 'irrelevant-ctx state) (assert$ (null erp) (f-put-global 'global-enabled-structure new-ens state)))))))))
other
(state-global-let* ((ld-skip-proofsp 'initialize-acl2)) (partial-encapsulate (((retract-stobj-tables * state) => state)) nil (local (defun retract-stobj-tables (wrld state) (declare (xargs :stobjs state) (ignore wrld)) state))))
set-wfunction
(defun set-w (flg wrld state) (declare (xargs :guard (and (or (eq flg 'extension) (eq flg 'retraction)) (plist-worldp wrld) (known-package-alistp (getpropc 'known-package-alist 'global-value nil wrld)) (symbol-alistp (getpropc 'acl2-defaults-table 'table-alist nil wrld)) (state-p state)))) (pprogn (cond ((eq flg 'retraction) (retract-stobj-tables wrld state)) (t state)) (f-put-global 'current-acl2-world wrld state) (install-global-enabled-structure wrld state) (cond ((find-non-hidden-package-entry (current-package state) (known-package-alist state)) state) (t (f-put-global 'current-package "ACL2" state)))))
set-w!function
(defun set-w! (wrld state) (let ((w (w state))) (cond ((equal wrld w) state) (t (pprogn (set-w 'retraction (find-longest-common-retraction t wrld w) state) (set-w 'extension wrld state))))))
save-event-state-globalsmacro
(defmacro save-event-state-globals (form) `(state-global-let* ((accumulated-ttree nil) (gag-state nil) (print-base 10 set-print-base) (print-radix nil set-print-radix) (proof-tree-ctx nil) (saved-output-p nil)) (with-prover-step-limit! :start ,FORM)))
*protected-system-state-globals*constant
(defconst *protected-system-state-globals* (let ((val (set-difference-eq (strip-cars *initial-global-table*) '(acl2-raw-mode-p bddnotes current-acl2-world global-enabled-structure acl2-world-alist inhibit-output-lst inhibited-summary-types keep-tmp-files make-event-debug saved-output-token-lst print-clause-ids fmt-soft-right-margin fmt-hard-right-margin compiler-enabled port-file-enabled parallel-execution-enabled waterfall-parallelism warnings-as-errors waterfall-parallelism-timing-threshold waterfall-printing waterfall-printing-when-finished saved-output-reversed saved-output-p ttags-allowed ld-evisc-tuple term-evisc-tuple abbrev-evisc-tuple gag-mode-evisc-tuple slow-array-action iprint-ar iprint-fal iprint-soft-bound iprint-hard-bound trace-co trace-specs giant-lambda-object last-event-data event-data-fal show-custom-keyword-hint-expansion timer-alist main-timer verbose-theory-warning pc-ss-alist pc-output last-step-limit illegal-to-certify-message splitter-output serialize-character serialize-character-system top-level-errorp deferred-ttag-notes deferred-ttag-notes-saved useless-runes fast-cert-status writes-okp cert-data gag-state-saved)))) val))
state-global-bindingsfunction
(defun state-global-bindings (names) (cond ((endp names) nil) (t (cons `(,(CAR NAMES) (f-get-global ',(CAR NAMES) state)) (state-global-bindings (cdr names))))))
*protected-system-state-global-bindings*constant
(defconst *protected-system-state-global-bindings* (state-global-bindings *protected-system-state-globals*))
protect-system-state-globalsmacro
(defmacro protect-system-state-globals (form) `(state-global-let* ((writes-okp nil) (cert-data nil) ,@*PROTECTED-SYSTEM-STATE-GLOBAL-BINDINGS*) ,FORM))
formal-value-triplefunction
(defun formal-value-triple (erp val) (fcons-term* 'cons erp (fcons-term* 'cons val (fcons-term* 'cons 'state *nil*))))
other
(defun-for-state set-standard-co (val state))
other
(defun-for-state set-proofs-co (val state))
other
(defun@par translate-simple-or-error-triple (uform ctx wrld state) (mv-let@par (erp term bindings state) (translate1@par uform :stobjs-out '((:stobjs-out . :stobjs-out)) '(state) ctx wrld state) (cond (erp (mv@par t nil state)) (t (let ((stobjs-out (translate-deref :stobjs-out bindings))) (cond ((equal stobjs-out '(nil)) (value@par (formal-value-triple@par *nil* term))) ((equal stobjs-out *error-triple-sig*) (serial-first-form-parallel-second-form@par (value@par term) (er@par soft ctx "Since we are translating a form in ACL2(p) intended to be ~ executed with waterfall parallelism enabled, the form ~x0 was ~ expected to represent an ordinary value, not an error triple (mv ~ erp val state), as would be acceptable in a serial execution of ~ ACL2. Therefore, the form returning a tuple of the form ~x1 is ~ an error. See :DOC unsupported-waterfall-parallelism-features ~ and :DOC error-triples-and-parallelism for further explanation." uform (prettyify-stobj-flags stobjs-out)))) (t (serial-first-form-parallel-second-form@par (er soft ctx "The form ~x0 was expected to represent an ordinary value or ~ an error triple (mv erp val state), but it returns a tuple ~ of the form ~x1." uform (prettyify-stobj-flags stobjs-out)) (er@par soft ctx "The form ~x0 was expected to represent an ordinary value, but ~ it returns a tuple of the form ~x1. Note that error triples ~ are not allowed in this feature in ACL2(p) (see :doc ~ error-triples-and-parallelism)" uform (prettyify-stobj-flags stobjs-out))))))))))
xtrans-evalfunction
(defun xtrans-eval (uterm alist trans-flg ev-flg ctx state aok) (er-let* ((term (if trans-flg (translate-simple-or-error-triple uterm ctx (w state) state) (value uterm)))) (cond ((or ev-flg (subsetp-eq (all-vars term) (cons 'state (strip-cars alist)))) (let ((original-world (w state))) (er-let* ((val (acl2-unwind-protect "xtrans-eval" (protect-system-state-globals (mv-let (erp val latches) (ev term (cons (cons 'state (coerce-state-to-object state)) alist) state (list (cons 'state (coerce-state-to-object state))) nil aok) (let ((state (coerce-object-to-state (cdr (car latches))))) (cond (erp (er soft ctx "~@0" val)) (t (mv (car val) (cadr val) state)))))) (set-w! original-world state) (set-w! original-world state)))) (value val)))) (t (mv t 'wait state)))))
xtrans-eval-state-fn-attachmentmacro
(defmacro xtrans-eval-state-fn-attachment (form ctx) (declare (xargs :guard (and (true-listp form) (symbolp (car form))))) `(let ((form ',FORM) (fn ',(CAR FORM)) (ctx ,CTX)) (cond ((or (f-get-global 'boot-strap-flg state) (null (attachment-pair fn (w state)))) (value nil)) (t (let ((form (list 'pprogn (append form '(state)) '(value nil)))) (mv-let (erp val state) (xtrans-eval form nil t t ctx state t) (cond (erp (er soft ctx "The error above occurred during ~ evaluation of ~x0." form)) (t (value val)))))))))
acl2-unwind-protect-altmacro
(defmacro acl2-unwind-protect-alt (expl body cleanup1 cleanup2) `(mv-let (erp val state) (acl2-unwind-protect ,EXPL (mv-let (aupa-erp aupa-val state) ,BODY (value (cons aupa-erp aupa-val))) ,CLEANUP1 ,CLEANUP2) (assert$ (null erp) (mv (car val) (cdr val) state))))
with-ctx-summarizedmacro
(defmacro with-ctx-summarized (ctx body &key event-type event) `(let ((ctx (or (f-get-global 'global-ctx state) ,CTX)) (saved-wrld (w state))) (pprogn (initialize-summary-accumulators state) (mv-let (erp val state) (save-event-state-globals (acl2-unwind-protect-alt "with-ctx-summarized1" (mv-let (erp val state) (acl2-unwind-protect "with-ctx-summarized2" (er-progn (xtrans-eval-state-fn-attachment (initialize-event-user ',CTX ',BODY) ctx) ,BODY) (print-summary t (equal saved-wrld (w state)) ,EVENT-TYPE ,EVENT ctx state) (print-summary nil (equal saved-wrld (w state)) ,EVENT-TYPE ,EVENT ctx state)) (pprogn (if erp (print-failure erp ,(IF (EQ EVENT-TYPE 'MAKE-EVENT-SAVE-EVENT-DATA) 'MAKE-EVENT EVENT-TYPE) (f-get-global 'accumulated-ttree state) ctx state) state) (er-progn (xtrans-eval-state-fn-attachment (finalize-event-user ',CTX ',BODY) ctx) (mv erp val state)))) (print-failure t ,(IF (EQ EVENT-TYPE 'MAKE-EVENT-SAVE-EVENT-DATA) 'MAKE-EVENT EVENT-TYPE) (f-get-global 'accumulated-ttree state) ctx state) state)) (pprogn (f-put-global 'saved-output-p nil state) (mv erp val state))))))
revert-world-on-errormacro
(defmacro revert-world-on-error (form) `(let ((revert-world-on-error-temp (w state))) (acl2-unwind-protect "revert-world-on-error" (check-vars-not-free (revert-world-on-error-temp) ,FORM) (set-w! revert-world-on-error-temp state) state)))
other
(defun@par chk-theory-expr-value1 (lst wrld expr macro-aliases ctx state) (cond ((atom lst) (cond ((null lst) (value@par nil)) (t (er@par soft ctx "The value of the alleged theory expression ~x0 is not a ~ true list and, hence, is not a legal theory value. In ~ particular, the final non-consp cdr is the atom ~x1. ~ See :DOC theories." expr lst)))) ((rule-name-designatorp (car lst) macro-aliases wrld) (chk-theory-expr-value1@par (cdr lst) wrld expr macro-aliases ctx state)) (t (er@par soft ctx "The value of the alleged theory expression ~x0 includes the ~ element ~x1, which we do not know how to interpret as a rule ~ name. See :DOC theories and :DOC rune." expr (car lst)))))
other
(defun@par chk-theory-expr-value (lst wrld expr ctx state) (chk-theory-expr-value1@par lst wrld expr (macro-aliases wrld) ctx state))
theory-fn-translated-callpfunction
(defun theory-fn-translated-callp (x) (and (nvariablep x) (not (fquotep x)) (member-eq (car x) '(current-theory-fn e/d-fn executable-counterpart-theory-fn function-theory-fn intersection-theories-fn set-difference-theories-fn set-difference-current-theory-fn theory-fn union-theories-fn union-current-theory-fn universal-theory-fn)) t))
eval-theory-exprfunction
(defun eval-theory-expr (expr ctx wrld state) (cond ((equal expr '(current-theory :here)) (mv-let (erp val latches) (ev '(current-theory-fn ':here world) (list (cons 'world wrld)) state nil nil t) (declare (ignore latches)) (mv erp val state))) (t (er-let* ((trans-ans (state-global-let* ((guard-checking-on t)) (simple-translate-and-eval expr (list (cons 'world wrld)) nil "A theory expression" ctx wrld state t)))) (cond ((theory-fn-translated-callp (car trans-ans)) (value (cdr trans-ans))) (t (er-progn (chk-theory-expr-value (cdr trans-ans) wrld expr ctx state) (value (runic-theory (cdr trans-ans) wrld)))))))))
no-rune-based-onfunction
(defun no-rune-based-on (runes symbols) (cond ((null runes) t) ((member-eq (base-symbol (car runes)) symbols) nil) (t (no-rune-based-on (cdr runes) symbols))))
revappend-delete-runes-based-on-symbols1function
(defun revappend-delete-runes-based-on-symbols1 (runes symbols ans) (cond ((null runes) ans) ((member-eq (base-symbol (car runes)) symbols) (revappend-delete-runes-based-on-symbols1 (cdr runes) symbols ans)) (t (revappend-delete-runes-based-on-symbols1 (cdr runes) symbols (cons (car runes) ans)))))
revappend-delete-runes-based-on-symbolsfunction
(defun revappend-delete-runes-based-on-symbols (runes symbols ans) (cond ((or (null symbols) (no-rune-based-on runes symbols)) (revappend ans runes)) (t (reverse (revappend-delete-runes-based-on-symbols1 runes symbols ans)))))
current-theory1function
(defun current-theory1 (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 (cdr lst) ans (add-to-set-eq (car (car lst)) redefined))) ((member-eq (car (car lst)) redefined) (current-theory1 (cdr lst) ans redefined)) (t (current-theory1 (cdr lst) (append-strip-cdrs (cddr (car lst)) ans) redefined)))) ((and (eq (car (car lst)) 'current-theory) (eq (cadr (car lst)) 'global-value)) (revappend-delete-runes-based-on-symbols (cddr (car lst)) redefined ans)) (t (current-theory1 (cdr lst) ans redefined))))
first-n-ac-revfunction
(defun first-n-ac-rev (i l ac) (declare (type (unsigned-byte 60) i) (xargs :guard (and (true-listp l) (true-listp ac)))) (cond ((zpf i) ac) (t (first-n-ac-rev (the (unsigned-byte 60) (1- (the (unsigned-byte 60) i))) (cdr l) (cons (car l) ac)))))
longest-common-tail-length-recfunction
(defun longest-common-tail-length-rec (old new len-old acc) (declare (type (unsigned-byte 60) acc len-old)) (cond ((endp old) (assert$ (null new) acc)) (t (longest-common-tail-length-rec (cdr old) (cdr new) (1-f len-old) (if (equal (car old) (car new)) (1+f acc) 0)))))
longest-common-tail-lengthfunction
(defun longest-common-tail-length (old new len-old) (longest-common-tail-length-rec old new len-old 0))
extend-current-theoryfunction
(defun extend-current-theory (old-th len-old new-th len-new old-aug-th wrld) (let* ((len-common (cond ((int= len-old len-new) (longest-common-tail-length old-th new-th len-old)) ((< len-old len-new) (longest-common-tail-length old-th (nthcdr (- len-new len-old) new-th) len-old)) (t (longest-common-tail-length (nthcdr (- len-old len-new) old-th) new-th len-new)))) (take-new (- len-new len-common)) (nthcdr-old (- len-old len-common)) (old-th-tail (nthcdr nthcdr-old old-th)) (new-part-of-new-rev (cond (t (first-n-ac-rev (the-unsigned-byte! 29 take-new 'extend-current-theory) new-th nil))))) (mv (cond (t (revappend new-part-of-new-rev old-th-tail))) (if (eq old-aug-th :none) :none (augment-runic-theory1 new-part-of-new-rev nil wrld (nthcdr nthcdr-old old-aug-th))))))
update-current-theoryfunction
(defun update-current-theory (theory0 theory0-length wrld) (mv-let (theory theory-augmented) (extend-current-theory (global-val 'current-theory wrld) (global-val 'current-theory-length wrld) theory0 theory0-length (global-val 'current-theory-augmented wrld) wrld) (global-set 'current-theory theory (global-set 'current-theory-augmented theory-augmented (global-set 'current-theory-index (1- (get-next-nume wrld)) (global-set 'current-theory-length theory0-length wrld))))))
put-cltl-commandfunction
(defun put-cltl-command (cltl-cmd in-local-flg wrld wrld0 state) (global-set 'cltl-command cltl-cmd (cond ((or in-local-flg (global-val 'boot-strap-flg wrld0)) wrld) (t (let ((path (global-val 'include-book-path wrld0))) (cond ((or (null path) (and (null (cdr path)) (let ((certify-book-info (f-get-global 'certify-book-info state))) (and certify-book-info (equal (access certify-book-info certify-book-info :full-book-name) (car path)))))) (global-set 'top-level-cltl-command-stack (cons cltl-cmd (global-val 'top-level-cltl-command-stack wrld0)) wrld)) (t wrld)))))))
strip-non-nil-base-symbolsfunction
(defun strip-non-nil-base-symbols (runes acc) (cond ((endp runes) acc) (t (strip-non-nil-base-symbols (cdr runes) (let ((b (base-symbol (car runes)))) (cond ((null b) acc) (t (cons b acc))))))))
install-proof-supportersfunction
(defun install-proof-supporters (namex ttree wrld) (mv-let (use-names0 by-names0 cl-proc-fns0) (cl-proc-data-in-ttree ttree t) (let* ((runes (all-runes-in-ttree ttree nil)) (use-lst (use-names-in-ttree ttree t)) (by-lst (by-names-in-ttree ttree t)) (names (append by-names0 by-lst cl-proc-fns0 use-names0 use-lst (strip-non-nil-base-symbols runes nil))) (sorted-names (and names (sort-symbol-listp (cond ((symbolp namex) (cond ((member-eq namex names) (remove-eq namex names)) (t names))) ((intersectp-eq namex names) (set-difference-eq names namex)) (t names)))))) (cond ((and (not (eql namex 0)) sorted-names) (global-set 'proof-supporters-alist (acons namex sorted-names (global-val 'proof-supporters-alist wrld)) wrld)) (t wrld)))))
update-wmacro
(defmacro update-w (condition new-w &optional retract-p) (let ((form `(pprogn ,(IF RETRACT-P '(SET-W 'RETRACTION WRLD STATE) '(SET-W 'EXTENSION WRLD STATE)) (value wrld)))) (cond ((eq condition t) `(let ((wrld ,NEW-W)) ,FORM)) (t `(let ((wrld ,NEW-W)) (cond (,CONDITION ,FORM) (t (value wrld))))))))
skip-proofs-due-to-systemfunction
(defun skip-proofs-due-to-system (state) (and (not (f-get-global 'inside-skip-proofs state)) (f-get-global 'skip-proofs-by-system state)))
set-cert-replay-pfunction
(defun set-cert-replay-p (wrld state) (cond ((f-get-global 'in-local-flg state) (and (not (global-val 'cert-replay wrld)) (if (f-get-global 'certify-book-info state) (and (not (global-val 'include-book-path wrld)) 'certify) 'portcullis))) ((f-get-global 'certify-book-info state) nil) ((gc-off1 (f-get-global 'guard-checking-on state)) (and (not (global-val 'cert-replay wrld)) 'portcullis)) (t nil)))
install-eventfunction
(defun install-event (val form ev-type namex ttree cltl-cmd chk-theory-inv-p ctx wrld state) (let ((currently-installed-wrld (w state))) (mv-let (chk-theory-inv-p theory-invariant-table) (cond ((member-eq (ld-skip-proofsp state) '(include-book include-book-with-locals)) (mv nil nil)) (t (let ((tbl (table-alist 'theory-invariant-table currently-installed-wrld))) (cond ((null tbl) (mv nil nil)) (t (mv chk-theory-inv-p tbl)))))) (let* ((new-proved-fnl-insts (proved-functional-instances-from-tagged-objects (cond ((atom namex) namex) (t (car namex))) (revappend (strip-cars (tagged-objects :use ttree)) (reverse (tagged-objects :by ttree))))) (wrld0 (if (or (ld-skip-proofsp state) (and (atom namex) (not (symbolp namex)))) wrld (install-proof-supporters namex ttree wrld))) (in-local-flg (f-get-global 'in-local-flg state)) (wrld1a (case (set-cert-replay-p wrld state) (portcullis (global-set 'cert-replay (cons (cons (- (max-absolute-command-number wrld)) in-local-flg) (scan-to-command wrld)) wrld)) (certify (global-set 'cert-replay t wrld0)) (t wrld0))) (wrld1 (if new-proved-fnl-insts (global-set 'proved-functional-instances-alist (append new-proved-fnl-insts (global-val 'proved-functional-instances-alist wrld1a)) wrld1a) wrld1a)) (skipped-proofs-p (and (ld-skip-proofsp state) (not (member-eq ev-type '(include-book defchoose defconst deflabel defmacro defpkg defstobj deftheory in-arithmetic-theory in-theory push-untouchable regenerate-tau-database remove-untouchable reset-prehistory set-body table))) (not (skip-proofs-due-to-system state)))) (wrld2 (cond ((and skipped-proofs-p (let ((old (global-val 'skip-proofs-seen wrld))) (or (not old) (eq (car old) :include-book)))) (global-set 'skip-proofs-seen form wrld1)) (t wrld1))) (wrld3 (cond ((and (ld-redefinition-action state) (not (global-val 'include-book-path wrld)) (not (global-val 'redef-seen wrld))) (global-set 'redef-seen form wrld2)) (t wrld2))) (wrld4 (if cltl-cmd (put-cltl-command cltl-cmd in-local-flg wrld3 currently-installed-wrld state) wrld3))) (er-let* ((wrld4a (update-w t wrld4)) (wrld5 (tau-visit-event t ev-type namex (tau-auto-modep wrld4a) (ens state) ctx wrld4a state))) (let ((wrld6 (add-event-landmark form ev-type namex wrld5 (f-get-global 'boot-strap-flg state) skipped-proofs-p in-local-flg))) (pprogn (f-put-global 'accumulated-ttree ttree state) (cond ((eq chk-theory-inv-p :protect) (revert-world-on-error (let ((state (set-w 'extension wrld6 state))) (er-progn (chk-theory-invariant1 :install (ens state) theory-invariant-table nil ctx state) (value val))))) (t (let ((state (set-w 'extension wrld6 state))) (cond (chk-theory-inv-p (er-progn (chk-theory-invariant1 :install (ens state) theory-invariant-table nil ctx state) (value val))) (t (value val)))))))))))))
stop-redundant-event-fn1function
(defun stop-redundant-event-fn1 (chan ctx extra-msg state) (mv-let (col state) (fmt "The event " nil chan state nil) (mv-let (col state) (fmt-ctx ctx col chan state) (mv-let (col state) (fmt1 " is redundant. See :DOC redundant-events.~#0~[~/ ~@1~]~%" (list (cons #\0 (if (null extra-msg) 0 1)) (cons #\1 extra-msg)) col chan state nil) (declare (ignore col)) state))))
scan-to-cltl-commandfunction
(defun scan-to-cltl-command (wrld) (declare (xargs :guard (plist-worldp wrld))) (cond ((endp wrld) nil) ((and (eq (caar wrld) 'event-landmark) (eq (cadar wrld) 'global-value)) nil) ((and (eq (caar wrld) 'cltl-command) (eq (cadar wrld) 'global-value)) (cddar wrld)) (t (scan-to-cltl-command (cdr wrld)))))
fast-cert-modefunction
(defun fast-cert-mode (state) (let ((status (f-get-global 'fast-cert-status state))) (cond ((null status) nil) ((consp status) :accept) (t t))))
fast-cert-included-bookfunction
(defun fast-cert-included-book (status) (let ((tmp (if (consp status) (car status) status))) (and (stringp tmp) tmp)))
in-encapsulatepfunction
(defun in-encapsulatep (embedded-event-lst non-trivp) (cond ((endp embedded-event-lst) nil) ((and (eq (car (car embedded-event-lst)) 'encapsulate) (if non-trivp (cadr (car embedded-event-lst)) t)) t) (t (in-encapsulatep (cdr embedded-event-lst) non-trivp))))
in-nested-encapsulatep1function
(defun in-nested-encapsulatep1 (embedded-event-lst) (cond ((endp embedded-event-lst) nil) ((eq (car (car embedded-event-lst)) 'encapsulate) (in-encapsulatep (cdr embedded-event-lst) nil)) (t (in-nested-encapsulatep1 (cdr embedded-event-lst)))))
in-nested-encapsulatepfunction
(defun in-nested-encapsulatep (state) (in-nested-encapsulatep1 (global-val 'embedded-event-lst (w state))))
store-cltl-command-for-redundant-deffunction
(defun store-cltl-command-for-redundant-def (state) (cond ((f-get-global 'in-local-flg state) nil) ((f-get-global 'certify-book-info state) (eq (fast-cert-mode state) t)) ((f-get-global 'inside-progn-fn1 state) t) ((in-encapsulatep (global-val 'embedded-event-lst (w state)) nil) (member-eq (ld-skip-proofsp state) '(include-book include-book-with-locals initialize-acl2))) (t nil)))
new-top-level-cltl-command-stackfunction
(defun new-top-level-cltl-command-stack (depth stack wrld) (cond ((or (null wrld) (and (eq (car (car wrld)) 'command-landmark) (eq (cadr (car wrld)) 'global-value))) stack) ((and (eq (car (car wrld)) 'event-landmark) (eq (cadr (car wrld)) 'global-value)) (if (> (access-event-tuple-depth (cddr (car wrld))) depth) (new-top-level-cltl-command-stack depth stack (cdr wrld)) stack)) ((and (eq (car (car wrld)) 'cltl-command) (eq (cadr (car wrld)) 'global-value)) (new-top-level-cltl-command-stack depth (cons (cddr (car wrld)) stack) (cdr wrld))) (t (new-top-level-cltl-command-stack depth stack (cdr wrld)))))
stop-redundant-event-fnfunction
(defun stop-redundant-event-fn (ctx state extra-msg name defun-mode def-lst) (let ((chan (proofs-co state)) (ctx (or (f-get-global 'global-ctx state) ctx))) (pprogn (cond ((ld-skip-proofsp state) state) ((not (member-eq 'event (f-get-global 'inhibit-output-lst state))) (io? event nil state (chan ctx extra-msg) (stop-redundant-event-fn1 chan ctx extra-msg state))) ((member-eq 'redundant (f-get-global 'inhibited-summary-types state)) state) (t (io? summary nil state (chan ctx extra-msg) (stop-redundant-event-fn1 chan ctx extra-msg state)))) (cond ((and name (store-cltl-command-for-redundant-def state)) (let* ((wrld (w state)) (index (getpropc name 'absolute-event-number nil wrld)) (old-wrld (and index (lookup-world-index 'event index wrld))) (event-tuple (cddr (car old-wrld))) (old (and index (access-event-tuple-local-p event-tuple) (scan-to-cltl-command (cdr old-wrld))))) (cond ((null old) state) (t (let* ((old-stack (global-val 'top-level-cltl-command-stack wrld)) (new-stack (case-match old (('defuns & & . old-def-lst) (cons (if (null def-lst) (assert$ (null defun-mode) `(defuns ,DEFUN-MODE nil ,@OLD-DEF-LST)) `(defuns ,DEFUN-MODE nil ,@DEF-LST)) old-stack)) (& (cond ((member-eq (car old) '(defstobj defabsstobj)) (new-top-level-cltl-command-stack (access-event-tuple-depth event-tuple) old-stack (cdr old-wrld))) (t (cons old old-stack))))))) (set-w 'extension (global-set 'top-level-cltl-command-stack new-stack wrld) state)))))) (t state)) (value :redundant))))
stop-redundant-eventmacro
(defmacro stop-redundant-event (ctx state &key extra-msg name defun-mode def-lst) `(stop-redundant-event-fn ,CTX ,STATE ,EXTRA-MSG ,NAME ,DEFUN-MODE ,DEF-LST))
other
(defrec command-number-baseline-info (current permanent-p . original) nil)
absolute-to-relative-command-numberfunction
(defun absolute-to-relative-command-number (n wrld) (- n (access command-number-baseline-info (global-val 'command-number-baseline-info wrld) :current)))
relative-to-absolute-command-numberfunction
(defun relative-to-absolute-command-number (n wrld) (+ n (access command-number-baseline-info (global-val 'command-number-baseline-info wrld) :current)))
normalize-absolute-command-numberfunction
(defun normalize-absolute-command-number (n wrld) (let ((m (max-absolute-command-number wrld))) (cond ((> n m) (mv t m)) ((< n 0) (mv nil 0)) (t (mv nil n)))))
tree-occurfunction
(defun tree-occur (x y) (cond ((equal x y) t) ((atom y) nil) (t (or (tree-occur x (car y)) (tree-occur x (cdr y))))))
cd-form-matchpfunction
(defun cd-form-matchp (pat form) (cond ((symbolp form) nil) ((null pat) t) ((tree-occur (car pat) form) (cd-form-matchp (cdr pat) form)) (t nil)))
cd-some-event-matchpfunction
(defun cd-some-event-matchp (pat wrld) (cond ((null wrld) nil) ((and (eq (caar wrld) 'command-landmark) (eq (cadar wrld) 'global-value)) wrld) ((and (eq (caar wrld) 'event-landmark) (eq (cadar wrld) 'global-value) (cd-form-matchp pat (access-event-tuple-form (cddar wrld)))) t) (t (cd-some-event-matchp pat (cdr wrld)))))
cd-searchfunction
(defun cd-search (pat earliestp start-wrld end-wrld) (cond ((equal start-wrld end-wrld) (cond ((or (cd-form-matchp pat (access-command-tuple-form (cddar start-wrld))) (eq t (cd-some-event-matchp pat (cdr start-wrld)))) start-wrld) ((eq earliestp t) nil) (t earliestp))) ((cd-form-matchp pat (access-command-tuple-form (cddar start-wrld))) (cond (earliestp (cd-search pat start-wrld (scan-to-command (cdr start-wrld)) end-wrld)) (t start-wrld))) (t (let ((wrld1 (cd-some-event-matchp pat (cdr start-wrld)))) (cond ((eq wrld1 t) (cond (earliestp (cd-search pat start-wrld (scan-to-command (cdr start-wrld)) end-wrld)) (t start-wrld))) (t (cd-search pat earliestp wrld1 end-wrld)))))))
superior-command-worldfunction
(defun superior-command-world (wrld1 wrld ctx state) (let ((prev-cmd-wrld (scan-to-command wrld1))) (cond ((<= (1+ (access-command-tuple-number (cddar prev-cmd-wrld))) (max-absolute-command-number wrld)) (value (lookup-world-index 'command (if prev-cmd-wrld (1+ (access-command-tuple-number (cddar prev-cmd-wrld))) 0) wrld))) (t (er soft ctx "We have been asked to find the about-to-be-most-recent ~ command landmark. We cannot do that because that ~ landmark hasn't been laid down yet!")))))
er-decode-cdfunction
(defun er-decode-cd (cd wrld ctx state) (let ((msg "The object ~x0 is not a legal command descriptor. See ~ :DOC command-descriptor.")) (cond ((or (symbolp cd) (stringp cd)) (cond ((or (eq cd :max) (eq cd :x)) (value (scan-to-command wrld))) ((eq cd :min) (value (lookup-world-index 'command 0 wrld))) ((eq cd :start) (value (lookup-world-index 'command (access command-number-baseline-info (global-val 'command-number-baseline-info wrld) :original) wrld))) ((and (keywordp cd) (let ((str (symbol-name cd))) (and (eql (char str 0) #\X) (eql (char str 1) #\-) (mv-let (k pos) (parse-natural nil str 2 (length str)) (and k (= pos (length str))))))) (er-decode-cd (list :max (- (mv-let (k pos) (parse-natural nil (symbol-name cd) 2 (length (symbol-name cd))) (declare (ignore pos)) k))) wrld ctx state)) (t (er-let* ((ev-wrld (er-decode-logical-name cd wrld ctx state))) (superior-command-world ev-wrld wrld ctx state))))) ((integerp cd) (mv-let (flg n) (normalize-absolute-command-number (relative-to-absolute-command-number cd wrld) wrld) (cond (flg (er soft ctx "The object ~x0 is not a legal command descriptor ~ because it exceeds the current maximum command ~ number, ~x1." cd (absolute-to-relative-command-number n wrld))) (t (value (lookup-world-index 'command n wrld)))))) ((and (consp cd) (true-listp cd)) (case (car cd) (:search (cond ((and (or (= (length cd) 4) (= (length cd) 2)) (or (atom (cadr cd)) (true-listp (cadr cd)))) (let* ((pat (if (atom (cadr cd)) (list (cadr cd)) (cadr cd)))) (er-let* ((wrld1 (er-decode-cd (cond ((null (cddr cd)) :max) (t (caddr cd))) wrld ctx state)) (wrld2 (er-decode-cd (cond ((null (cddr cd)) 0) (t (cadddr cd))) wrld ctx state))) (let ((ans (cond ((>= (access-command-tuple-number (cddar wrld1)) (access-command-tuple-number (cddar wrld2))) (cd-search pat nil wrld1 wrld2)) (t (cd-search pat t wrld2 wrld1))))) (cond ((null ans) (er soft ctx "No command or event in the region from ~x0 to ~ ~x1 contains ~&2. See :DOC command-descriptor." (cond ((null (cddr cd)) :x) (t (caddr cd))) (cond ((null (cddr cd)) 0) (t (cadddr cd))) pat cd)) (t (value ans))))))) (t (er soft ctx msg cd)))) (otherwise (cond ((and (consp (cdr cd)) (integerp (cadr cd)) (null (cddr cd))) (er-let* ((wrld1 (er-decode-cd (car cd) wrld ctx state))) (mv-let (flg n) (normalize-absolute-command-number (+ (access-command-tuple-number (cddar wrld1)) (cadr cd)) wrld) (cond (flg (er soft ctx "The object ~x0 is not a legal ~ command descriptor because it ~ represents command number ~x1, ~ which exceeds the current maximum ~ command number, ~x2." cd (absolute-to-relative-command-number (+ (access-command-tuple-number (cddar wrld1)) (cadr cd)) wrld) (absolute-to-relative-command-number n wrld))) (t (value (lookup-world-index 'command n wrld))))))) (t (er soft ctx msg cd)))))) (t (er soft ctx msg cd)))))
other
(defrec ldd-status (defun-mode-pair disabled memoized) nil)
make-ldd-flagsfunction
(defun make-ldd-flags (class markp status fullp) (cons (cons class markp) (cons status fullp)))
make-lddfunction
(defun make-ldd (class markp status n fullp form) (cons (make-ldd-flags class markp status fullp) (cons n form)))
access-ldd-classfunction
(defun access-ldd-class (ldd) (caaar ldd))
access-ldd-markpfunction
(defun access-ldd-markp (ldd) (cdaar ldd))
access-ldd-statusfunction
(defun access-ldd-status (ldd) (cadar ldd))
access-ldd-fullpfunction
(defun access-ldd-fullp (ldd) (cddar ldd))
access-ldd-nfunction
(defun access-ldd-n (ldd) (cadr ldd))
access-ldd-formfunction
(defun access-ldd-form (ldd) (cddr ldd))
big-d-little-d-name1function
(defun big-d-little-d-name1 (lst ens ans) (cond ((null lst) ans) ((equal ans (if (enabled-numep (caar lst) ens) #\E #\D)) (big-d-little-d-name1 (cdr lst) ens ans)) (t #\d)))
big-d-little-d-namefunction
(defun big-d-little-d-name (name ens wrld) (let ((temp (getpropc name 'runic-mapping-pairs nil wrld))) (cond ((null temp) #\ ) (t (big-d-little-d-name1 (cdr temp) ens (if (enabled-numep (caar temp) ens) #\E #\D))))))
big-d-little-d-clique1function
(defun big-d-little-d-clique1 (names ens wrld ans) (cond ((null names) ans) (t (let ((ans1 (big-d-little-d-name (car names) ens wrld))) (cond ((eql ans1 #\d) #\d) ((eql ans1 ans) (big-d-little-d-clique1 (cdr names) ens wrld ans)) (t #\d))))))
big-d-little-d-cliquefunction
(defun big-d-little-d-clique (names ens wrld) (let ((ans (big-d-little-d-name (car names) ens wrld))) (cond ((eql ans #\d) #\d) (t (big-d-little-d-clique1 (cdr names) ens wrld ans)))))
big-d-little-d-eventfunction
(defun big-d-little-d-event (ev-tuple ens wrld) (let ((namex (access-event-tuple-namex ev-tuple))) (case (access-event-tuple-type ev-tuple) ((defun defthm defaxiom) (big-d-little-d-name namex ens wrld)) (defuns (big-d-little-d-clique namex ens wrld)) (defstobj (big-d-little-d-clique (cddr namex) ens wrld)) (otherwise #\ ))))
big-d-little-d-command-blockfunction
(defun big-d-little-d-command-block (wrld1 ens wrld s) (cond ((or (null wrld1) (and (eq (caar wrld1) 'command-landmark) (eq (cadar wrld1) 'global-value))) s) ((and (eq (caar wrld1) 'event-landmark) (eq (cadar wrld1) 'global-value)) (let ((s1 (big-d-little-d-event (cddar wrld1) ens wrld))) (cond ((or (eql s s1) (eql s1 #\ )) (big-d-little-d-command-block (cdr wrld1) ens wrld s)) ((or (eql s1 #\d) (and (eql s #\E) (eql s1 #\D)) (and (eql s #\D) (eql s1 #\E))) #\d) (t (big-d-little-d-command-block (cdr wrld1) ens wrld s1))))) (t (big-d-little-d-command-block (cdr wrld1) ens wrld s))))
big-m-little-m-namefunction
(defun big-m-little-m-name (name wrld) (cond ((and (function-symbolp name wrld) (not (getpropc name 'constrainedp nil wrld))) (if (memoizedp-world name wrld) #\M #\E)) (t #\ )))
big-m-little-m-clique1function
(defun big-m-little-m-clique1 (names wrld ans) (cond ((null names) ans) (t (let ((ans1 (big-m-little-m-name (car names) wrld))) (cond ((eql ans1 #\m) #\m) ((eql ans1 ans) (big-m-little-m-clique1 (cdr names) wrld ans)) (t #\m))))))
big-m-little-m-cliquefunction
(defun big-m-little-m-clique (names wrld) (let ((ans (big-m-little-m-name (car names) wrld))) (cond ((eql ans #\m) #\m) (t (big-m-little-m-clique1 (cdr names) wrld ans)))))
big-m-little-m-eventfunction
(defun big-m-little-m-event (ev-tuple wrld) (let ((namex (access-event-tuple-namex ev-tuple))) (case (access-event-tuple-type ev-tuple) ((defun) (big-m-little-m-name namex wrld)) (defuns (big-m-little-m-clique namex wrld)) (defstobj (big-m-little-m-clique (cddr namex) wrld)) (otherwise #\ ))))
big-m-little-m-command-blockfunction
(defun big-m-little-m-command-block (wrld1 wrld s) (cond ((or (null wrld1) (and (eq (caar wrld1) 'command-landmark) (eq (cadar wrld1) 'global-value))) s) ((and (eq (caar wrld1) 'event-landmark) (eq (cadar wrld1) 'global-value)) (let ((s1 (big-m-little-m-event (cddar wrld1) wrld))) (cond ((or (eql s s1) (eql s1 #\ )) (big-m-little-m-command-block (cdr wrld1) wrld s)) ((or (eql s1 #\m) (and (eql s #\E) (eql s1 #\M)) (and (eql s #\M) (eql s1 #\E))) #\m) (t (big-m-little-m-command-block (cdr wrld1) wrld s1))))) (t (big-m-little-m-command-block (cdr wrld1) wrld s))))
symbol-class-charfunction
(defun symbol-class-char (symbol-class) (case symbol-class (:program #\P) (:ideal #\L) (:common-lisp-compliant #\V) (otherwise #\ )))
defun-mode-stringfunction
(defun defun-mode-string (defun-mode) (case defun-mode (:logic ":logic") (:program ":program") (otherwise (er hard 'defun-mode-string "Unrecognized defun-mode, ~x0." defun-mode))))
big-c-little-c-eventfunction
(defun big-c-little-c-event (ev-tuple wrld) (case (access-event-tuple-type ev-tuple) ((defuns defun defstobj) (let ((c1 (symbol-class-char (access-event-tuple-symbol-class ev-tuple))) (c2 (symbol-class-char (let ((namex (access-event-tuple-namex ev-tuple))) (cond ((symbolp namex) (symbol-class namex wrld)) (t (symbol-class (car namex) wrld))))))) (cond ((eql c1 c2) (cons c1 #\ )) (t (cons c1 c2))))) (encapsulate '(#\v . #\ )) (otherwise '(#\ . #\ ))))
big-c-little-c-command-blockfunction
(defun big-c-little-c-command-block (wrld1 wrld s) (cond ((or (null wrld1) (and (eq (caar wrld1) 'command-landmark) (eq (cadar wrld1) 'global-value))) (or s '(#\ . #\ ))) ((and (eq (caar wrld1) 'event-landmark) (eq (cadar wrld1) 'global-value)) (cond (s '(#\ . #\ )) (t (big-c-little-c-command-block (cdr wrld1) wrld (big-c-little-c-event (cddar wrld1) wrld))))) (t (big-c-little-c-command-block (cdr wrld1) wrld s))))
print-ldd-full-or-sketch/mutual-recursionfunction
(defun print-ldd-full-or-sketch/mutual-recursion (lst) (cond ((null lst) nil) (t (cons (list 'defun (cadr (car lst)) (caddr (car lst)) *evisceration-ellipsis-mark*) (print-ldd-full-or-sketch/mutual-recursion (cdr lst))))))
print-ldd-full-or-sketch/encapsulatefunction
(defun print-ldd-full-or-sketch/encapsulate (lst) (cond ((null lst) nil) (t (cons (list (car (car lst)) *evisceration-ellipsis-mark*) (print-ldd-full-or-sketch/encapsulate (cdr lst))))))
normalize-charfunction
(defun normalize-char (c hyphen-is-spacep) (if (or (eql c #\ ) (and hyphen-is-spacep (eql c #\-))) #\ (char-upcase c)))
normalize-string1function
(defun normalize-string1 (str hyphen-is-spacep j ans) (cond ((< j 0) ans) (t (let ((c (normalize-char (char str j) hyphen-is-spacep))) (normalize-string1 str hyphen-is-spacep (1- j) (cond ((and (eql c #\ ) (eql c (car ans))) ans) (t (cons c ans))))))))
normalize-stringfunction
(defun normalize-string (str hyphen-is-spacep) (normalize-string1 str hyphen-is-spacep (1- (length str)) nil))
string-matchpfunction
(defun string-matchp (pat-lst str j jmax normp skippingp) (cond ((null pat-lst) t) ((>= j jmax) nil) (t (let ((c (if normp (normalize-char (char str j) (eq normp 'hyphen-is-space)) (char str j)))) (cond ((and skippingp (eql c #\ )) (string-matchp pat-lst str (1+ j) jmax normp t)) (t (and (eql c (car pat-lst)) (string-matchp (cdr pat-lst) str (1+ j) jmax normp (if normp (eql c #\ ) nil)))))))))
print-ldd-full-or-sketchfunction
(defun print-ldd-full-or-sketch (fullp form state) (cond ((atom form) (mv form state)) (fullp (let* ((evisc-tuple (ld-evisc-tuple state)) (evisc-alist (world-evisceration-alist state (car evisc-tuple))) (print-level (cadr evisc-tuple)) (print-length (caddr evisc-tuple))) (cond (evisc-tuple (eviscerate-top form print-level print-length evisc-alist (table-alist 'evisc-table (w state)) nil state)) (t (mv form state))))) (t (mv (case (car form) ((defun defund defmacro) (list (car form) (cadr form) (caddr form) *evisceration-ellipsis-mark*)) ((defthm defthmd) (list (car form) (cadr form) *evisceration-ellipsis-mark*)) (defconst (list (car form) (cadr form) *evisceration-ellipsis-mark*)) (mutual-recursion (cons 'mutual-recursion (print-ldd-full-or-sketch/mutual-recursion (cdr form)))) (encapsulate (list 'encapsulate (print-ldd-full-or-sketch/encapsulate (cadr form)) *evisceration-ellipsis-mark*)) (t (eviscerate-simple form 2 3 nil nil nil))) state))))
with-base-10macro
(defmacro with-base-10 (form) `(cond ((and (eql (f-get-global 'print-base state) 10) (eq (f-get-global 'print-radix state) nil)) ,FORM) (t (mv-let (erp val state) (state-global-let* ((print-base 10 set-print-base) (print-radix nil set-print-radix)) (pprogn ,FORM (value nil))) (declare (ignore erp val)) state))))
print-ldd-formula-columnmacro
(defmacro print-ldd-formula-column (&optional (skip-ldd-n 'nil skip-ldd-n-p)) (cond (skip-ldd-n-p `(if ,SKIP-LDD-N 7 14)) (t '(if (eq (f-get-global 'script-mode state) 'skip-ldd-n) 7 14))))
print-lddfunction
(defun print-ldd (ldd channel state) (with-base-10 (let* ((skip-ldd-n (eq (f-get-global 'script-mode state) 'skip-ldd-n)) (formula-col (if (eq (access-ldd-class ldd) 'command) (print-ldd-formula-column skip-ldd-n) (+ (print-ldd-formula-column skip-ldd-n) (access-ldd-n ldd)))) (status (access-ldd-status ldd))) (declare (type (signed-byte 61) formula-col)) (pprogn (princ$ (if (access-ldd-markp ldd) (access-ldd-markp ldd) #\ ) channel state) (let ((defun-mode-pair (access ldd-status status :defun-mode-pair))) (pprogn (princ$ (car defun-mode-pair) channel state) (princ$ (cdr defun-mode-pair) channel state))) (let ((disabled (access ldd-status status :disabled))) (princ$ (if (eql disabled #\E) #\ disabled) channel state)) (let ((memoized (access ldd-status status :memoized))) (princ$ (if (eql memoized #\E) #\ memoized) channel state)) (let ((cur-col 5)) (if (eq (access-ldd-class ldd) 'command) (mv-let (col state) (let ((arg1 (cond ((= (access-ldd-n ldd) (absolute-to-relative-command-number (max-absolute-command-number (w state)) (w state))) ":x") (t " ")))) (if skip-ldd-n (fmt1 "~s1" (list (cons #\1 arg1)) cur-col channel state nil) (fmt1 "~c0~s1" (list (cons #\0 (cons (access-ldd-n ldd) 7)) (cons #\1 arg1)) cur-col channel state nil))) (declare (ignore col)) state) (spaces (- formula-col cur-col) cur-col channel state))) (mv-let (form state) (print-ldd-full-or-sketch (access-ldd-fullp ldd) (access-ldd-form ldd) state) (fmt-ppr form (+f (fmt-hard-right-margin state) (-f formula-col)) 0 formula-col channel state (not (and (access-ldd-fullp ldd) (null (ld-evisc-tuple state)))))) (newline channel state)))))
print-lddsfunction
(defun print-ldds (ldds channel state) (cond ((null ldds) state) (t (pprogn (print-ldd (car ldds) channel state) (print-ldds (cdr ldds) channel state)))))
make-command-lddfunction
(defun make-command-ldd (markp fullp cmd-wrld ens wrld) (make-ldd 'command markp (make ldd-status :defun-mode-pair (big-c-little-c-command-block (cdr cmd-wrld) wrld nil) :disabled (big-d-little-d-command-block (cdr cmd-wrld) ens wrld #\ ) :memoized (big-m-little-m-command-block (cdr cmd-wrld) wrld #\ )) (absolute-to-relative-command-number (access-command-tuple-number (cddar cmd-wrld)) wrld) fullp (access-command-tuple-form (cddar cmd-wrld))))
extend-pe-tablemacro
(defmacro extend-pe-table (name form) `(with-output :off error (table pe-table ',NAME (cons (cons (getpropc ',NAME 'absolute-event-number (list :error (concatenate 'string "Event for " ,(SYMBOL-NAME NAME) " (package " ,(SYMBOL-PACKAGE-NAME NAME) ") not found.")) world) ',FORM) (cdr (assoc-eq ',NAME (table-alist 'pe-table world)))))))
pe-event-formfunction
(defun pe-event-form (event-tuple wrld) (let* ((ev-form (access-event-tuple-form event-tuple)) (ev-n (access-event-tuple-number event-tuple)) (pe-entry (cdr (assoc ev-n (cdr (assoc-eq (cadr ev-form) (table-alist 'pe-table wrld))))))) (or pe-entry ev-form)))
make-event-lddfunction
(defun make-event-ldd (markp indent fullp ev-tuple ens wrld) (make-ldd 'event markp (make ldd-status :defun-mode-pair (big-c-little-c-event ev-tuple wrld) :disabled (big-d-little-d-event ev-tuple ens wrld) :memoized (big-m-little-m-event ev-tuple wrld)) indent fullp (pe-event-form ev-tuple wrld)))
make-ldds-command-sequencefunction
(defun make-ldds-command-sequence (cmd-wrld1 cmd2 ens wrld markp ans) (cond ((equal (cddar cmd-wrld1) cmd2) (cons (make-command-ldd (and markp (cond ((null ans) #\>) (t #\/))) nil cmd-wrld1 ens wrld) ans)) (t (make-ldds-command-sequence (scan-to-command (cdr cmd-wrld1)) cmd2 ens wrld markp (cons (make-command-ldd (and markp (cond ((null ans) #\\) (t nil))) nil cmd-wrld1 ens wrld) ans)))))
make-ldds-command-block1function
(defun make-ldds-command-block1 (wrld1 cmd-ldd indent fullp super-stk ens wrld ans) (cond ((or (null wrld1) (and (eq (caar wrld1) 'command-landmark) (eq (cadar wrld1) 'global-value))) (cond (super-stk (make-ldds-command-block1 wrld1 cmd-ldd (1- indent) fullp (cdr super-stk) ens wrld (cons (make-event-ldd nil (1- indent) fullp (car super-stk) ens wrld) ans))) (t (cons cmd-ldd ans)))) ((and (eq (caar wrld1) 'event-landmark) (eq (cadar wrld1) 'global-value)) (cond ((and super-stk (<= (access-event-tuple-depth (cddar wrld1)) (access-event-tuple-depth (car super-stk)))) (make-ldds-command-block1 wrld1 cmd-ldd (1- indent) fullp (cdr super-stk) ens wrld (cons (make-event-ldd nil (1- indent) fullp (car super-stk) ens wrld) ans))) ((or (eq (access-event-tuple-type (cddar wrld1)) 'encapsulate) (eq (access-event-tuple-type (cddar wrld1)) 'include-book)) (make-ldds-command-block1 (cdr wrld1) cmd-ldd (1+ indent) fullp (cons (cddar wrld1) super-stk) ens wrld ans)) (t (make-ldds-command-block1 (cdr wrld1) cmd-ldd indent fullp super-stk ens wrld (cons (make-event-ldd nil indent fullp (cddar wrld1) ens wrld) ans))))) (t (make-ldds-command-block1 (cdr wrld1) cmd-ldd indent fullp super-stk ens wrld ans))))
make-ldds-command-blockfunction
(defun make-ldds-command-block (cmd-wrld ens wrld fullp ans) (let ((cmd-ldd (make-command-ldd nil fullp cmd-wrld ens wrld)) (wrld1 (scan-to-event (cdr cmd-wrld)))) (cond ((equal (pe-event-form (cddar wrld1) wrld) (access-command-tuple-form (cddar cmd-wrld))) (make-ldds-command-block1 (cdr wrld1) cmd-ldd 1 fullp nil ens wrld ans)) (t (make-ldds-command-block1 wrld1 cmd-ldd 1 fullp nil ens wrld ans)))))
ens-maybe-brrfunction
(defun ens-maybe-brr (state) (or (and (eq (f-get-global 'wormhole-name state) 'brr) (access rewrite-constant (get-brr-local 'rcnst state) :current-enabled-structure)) (ens state)))
pcb-pcb!-fnfunction
(defun pcb-pcb!-fn (cd fullp state) (io? history nil (mv erp val state) (cd fullp) (let ((wrld (w state)) (ens (ens-maybe-brr state))) (er-let* ((cmd-wrld (er-decode-cd cd wrld :pcb state))) (pprogn (print-ldds (make-ldds-command-block cmd-wrld ens wrld fullp nil) (standard-co state) state) (value :invisible))))))
pcb!-fnfunction
(defun pcb!-fn (cd state) (pcb-pcb!-fn cd t state))
pcb-fnfunction
(defun pcb-fn (cd state) (pcb-pcb!-fn cd nil state))
pc-fnfunction
(defun pc-fn (cd state) (io? history nil (mv erp val state) (cd) (let ((wrld (w state))) (er-let* ((cmd-wrld (er-decode-cd cd wrld :pc state))) (pprogn (print-ldd (make-command-ldd nil t cmd-wrld (ens-maybe-brr state) wrld) (standard-co state) state) (value :invisible))))))
pcs-fnfunction
(defun pcs-fn (cd1 cd2 markp state) (io? history nil (mv erp val state) (cd1 markp cd2) (let ((wrld (w state)) (ens (ens-maybe-brr state))) (er-let* ((cmd-wrld1 (er-decode-cd cd1 wrld :ps state)) (cmd-wrld2 (er-decode-cd cd2 wrld :ps state))) (let ((later-wrld (if (>= (access-command-tuple-number (cddar cmd-wrld1)) (access-command-tuple-number (cddar cmd-wrld2))) cmd-wrld1 cmd-wrld2)) (earlier-wrld (if (>= (access-command-tuple-number (cddar cmd-wrld1)) (access-command-tuple-number (cddar cmd-wrld2))) cmd-wrld2 cmd-wrld1))) (pprogn (print-ldds (make-ldds-command-sequence later-wrld (cddar earlier-wrld) ens wrld markp nil) (standard-co state) state) (cond ((= (access-command-tuple-number (cddar later-wrld)) (max-absolute-command-number wrld)) state) ((= (1+ (access-command-tuple-number (cddar later-wrld))) (max-absolute-command-number wrld)) (print-ldd (make-command-ldd nil nil wrld ens wrld) (standard-co state) state)) (t (pprogn (mv-let (col state) (fmt1 "~t0: ...~%" (list (cons #\0 (- (print-ldd-formula-column) 2))) 0 (standard-co state) state nil) (declare (ignore col)) state) (print-ldd (make-command-ldd nil nil wrld ens wrld) (standard-co state) state)))) (value :invisible)))))))
get-command-sequence-fn1function
(defun get-command-sequence-fn1 (cmd-wrld1 cmd2 ans) (cond ((equal (cddar cmd-wrld1) cmd2) (cons (access-command-tuple-form (cddar cmd-wrld1)) ans)) (t (get-command-sequence-fn1 (scan-to-command (cdr cmd-wrld1)) cmd2 (cons (access-command-tuple-form (cddar cmd-wrld1)) ans)))))
get-command-sequence-fnfunction
(defun get-command-sequence-fn (cd1 cd2 state) (let ((wrld (w state)) (ctx 'get-command-sequence)) (er-let* ((cmd-wrld1 (er-decode-cd cd1 wrld ctx state)) (cmd-wrld2 (er-decode-cd cd2 wrld ctx state))) (let ((later-wrld (if (>= (access-command-tuple-number (cddar cmd-wrld1)) (access-command-tuple-number (cddar cmd-wrld2))) cmd-wrld1 cmd-wrld2)) (earlier-wrld (if (>= (access-command-tuple-number (cddar cmd-wrld1)) (access-command-tuple-number (cddar cmd-wrld2))) cmd-wrld2 cmd-wrld1))) (value (get-command-sequence-fn1 later-wrld (cddar earlier-wrld) nil))))))
get-command-sequencemacro
(defmacro get-command-sequence (cd1 cd2) (list 'get-command-sequence-fn cd1 cd2 'state))
gcsmacro
(defmacro gcs (cd1 cd2) `(get-command-sequence ,CD1 ,CD2))
print-indented-list-msgfunction
(defun print-indented-list-msg (objects indent final-string) (cond ((null objects) "") ((and final-string (null (cdr objects))) (msg (concatenate 'string "~_0~y1" final-string) indent (car objects))) (t (msg "~_0~y1~@2" indent (car objects) (print-indented-list-msg (cdr objects) indent final-string)))))
print-indented-listfunction
(defun print-indented-list (objects indent last-col channel evisc-tuple state) (cond ((null objects) (mv last-col state)) (t (fmt1 "~@0" (list (cons #\0 (print-indented-list-msg objects indent nil))) 0 channel state evisc-tuple))))
print-book-pathfunction
(defun print-book-path (book-path indent channel ctx state) (assert$ book-path (mv-let (col state) (fmt1 "~_0[Included books, outermost to innermost:~|" (list (cons #\0 indent)) 0 channel state nil) (declare (ignore col)) (mv-let (col state) (print-indented-list (cond ((f-get-global 'script-mode state) book-path) (t (book-name-lst-to-filename-lst book-path (project-dir-alist (w state)) ctx))) (1+ indent) 0 channel nil state) (pprogn (if (eql col 0) (spaces indent col channel state) state) (princ$ #\] channel state))))))
pe-fn1function
(defun pe-fn1 (wrld channel ev-wrld cmd-wrld state) (cond ((equal (pe-event-form (cddar ev-wrld) wrld) (access-command-tuple-form (cddar cmd-wrld))) (print-ldd (make-command-ldd nil t cmd-wrld (ens-maybe-brr state) wrld) channel state)) (t (let ((indent (print-ldd-formula-column)) (ens (ens-maybe-brr state))) (pprogn (print-ldd (make-command-ldd nil nil cmd-wrld ens wrld) channel state) (mv-let (col state) (fmt1 "~_0\~%" (list (cons #\0 indent)) 0 channel state nil) (declare (ignore col)) state) (let ((book-path (global-val 'include-book-path ev-wrld))) (cond (book-path (pprogn (print-book-path (reverse book-path) indent channel 'pe state) (fms "~_0\~%" (list (cons #\0 indent)) channel state nil))) (t state))) (print-ldd (make-event-ldd #\> 1 t (cddar ev-wrld) ens wrld) channel state))))))
pe-fn2function
(defun pe-fn2 (logical-name wrld channel ev-wrld state) (er-let* ((cmd-wrld (superior-command-world ev-wrld wrld :pe state))) (pprogn (pe-fn1 wrld channel ev-wrld cmd-wrld state) (let ((new-ev-wrld (decode-logical-name logical-name (scan-to-event (cdr ev-wrld))))) (if new-ev-wrld (pe-fn2 logical-name wrld channel new-ev-wrld state) (value :invisible))))))
pe-fn-mainfunction
(defun pe-fn-main (logical-name wrld channel state) (er-let* ((ev-wrld (er-decode-logical-name logical-name wrld :pe state)) (cmd-wrld (superior-command-world ev-wrld wrld :pe state))) (pprogn (pe-fn1 wrld channel ev-wrld cmd-wrld state) (let ((new-ev-wrld (and (not (eq logical-name :here)) (decode-logical-name logical-name (scan-to-event (cdr ev-wrld)))))) (if (null new-ev-wrld) (value :invisible) (pprogn (fms "Additional events for the logical name ~x0:~%" (list (cons #\0 logical-name)) channel state nil) (pe-fn2 logical-name wrld channel new-ev-wrld state)))))))
print-undefined-primitive-msgfunction
(defun print-undefined-primitive-msg (name channel state) (fms "~x0 is built into ACL2 without a defining event.~#1~[ See :DOC ~ ~x0.~/~]~|See :DOC ARGS for a way to get more information about such ~ primitives.~|See :DOC primitive for a list containing each built-in ~ function without a definition, each associated with its formals and ~ guard.~|" (list (cons #\0 name) (cons #\1 (if (assoc-eq name *acl2-system-documentation*) 0 1))) channel state nil))
pe-fnfunction
(defun pe-fn (logical-name state) (io? history nil (mv erp val state) (logical-name) (let ((wrld (w state)) (channel (standard-co state))) (cond ((and (symbolp logical-name) (not (eq logical-name :here)) (or (member-eq logical-name '(declare flet macrolet lambda lambda$ let loop$ quote with-local-stobj)) (eql (getpropc logical-name 'absolute-event-number nil wrld) 0))) (pprogn (print-undefined-primitive-msg logical-name channel state) (value :invisible))) (t (let ((fn (deref-macro-name logical-name (macro-aliases wrld)))) (cond ((eq fn logical-name) (pe-fn-main logical-name wrld channel state)) (t (pprogn (fms "Note that macro ~x0 is a macro alias for the function ~ ~x1; so we print event information for each in turn.~|" (list (cons #\0 logical-name) (cons #\1 fn)) channel state nil) (fms "Printing event information for ~x0:~|" (list (cons #\0 logical-name)) channel state nil) (er-progn (pe-fn-main logical-name wrld channel state) (pprogn (fms "Printing event information for ~x0:~|" (list (cons #\0 fn)) channel state nil) (pe-fn-main fn wrld channel state))))))))))))
pe!macro
(defmacro pe! (logical-name) `(with-output :off (summary event) (make-event (er-progn (let ((logical-name ,LOGICAL-NAME)) (cond ((eq logical-name :here) (pe :here)) (t (er-progn (table pe-table nil nil :clear) (pe ,LOGICAL-NAME))))) (value '(value-triple :invisible))))))
gthmmacro
(defmacro gthm (fn &optional (simplify ':limited) guard-debug) `(untranslate (guard-theorem ,FN ,SIMPLIFY ,GUARD-DEBUG (w state) state) t (w state)))
tthmmacro
(defmacro tthm (fn) `(let* ((fn ,FN) (term (termination-theorem fn (w state)))) (cond ((and (consp term) (eq (car term) :failed)) (er soft 'top "There is no termination theorem for ~x0. ~@1." fn (cdr term))) (t (value (untranslate term t (w state)))))))
command-block-names1function
(defun command-block-names1 (wrld ans symbol-classes) (cond ((or (null wrld) (and (eq (caar wrld) 'command-landmark) (eq (cadar wrld) 'global-value))) (mv ans wrld)) ((and (eq (caar wrld) 'event-landmark) (eq (cadar wrld) 'global-value)) (cond ((or (eq symbol-classes t) (member-eq (access-event-tuple-symbol-class (cddar wrld)) symbol-classes)) (let ((namex (access-event-tuple-namex (cddar wrld)))) (command-block-names1 (cdr wrld) (cond ((equal namex 0) ans) ((equal namex nil) ans) ((atom namex) (add-to-set-equal namex ans)) (t (union-equal namex ans))) symbol-classes))) (t (command-block-names1 (cdr wrld) ans symbol-classes)))) (t (command-block-names1 (cdr wrld) ans symbol-classes))))
command-block-namesfunction
(defun command-block-names (wrld symbol-classes) (command-block-names1 (cdr wrld) nil symbol-classes))
collect-names-in-defun-modesfunction
(defun collect-names-in-defun-modes (names defun-modes wrld) (cond ((null names) nil) ((member-eq (fdefun-mode (car names) wrld) defun-modes) (cons (car names) (collect-names-in-defun-modes (cdr names) defun-modes wrld))) (t (collect-names-in-defun-modes (cdr names) defun-modes wrld))))
ubt-ubu-queryfunction
(defun ubt-ubu-query (kwd wrld1 wrld0 seen kept-commands wrld state banger) (cond ((or (null wrld1) (equal wrld1 wrld0)) (value kept-commands)) (t (mv-let (names wrld2) (command-block-names wrld1 '(:program)) (cond ((and names (set-difference-eq names seen)) (er-let* ((ans (if banger (value banger) (let ((logic-names (collect-names-in-defun-modes names '(:logic) wrld))) (acl2-query kwd '("The command ~X01 introduced the :program ~ name~#2~[~/s~] ~&2.~#5~[~/ ~&3 ~#4~[has~/have~] ~ since been made logical.~] Do you wish to ~ re-execute this command after the ~xi?" :y t :n nil :y! :all :n! :none :q :q :? ("We are undoing some commands. We have ~ encountered a command, printed above, that ~ introduced a :program function symbol. It is ~ unusual to use ~xi while defining :program ~ functions, since redefinition is permitted. ~ Therefore, we suspect that you are mixing ~ :program and :logic definitions, as when one is ~ developing utilities for the prover. When ~ undoing through such a mixed session, it is ~ often intended that the :logic functions be ~ undone while the :program ones not be, since the ~ latter ones are just utilities. While we cannot ~ selectively undo commands, we do offer to redo ~ selected commands when we have finished undoing. ~ The situation is complicated by the fact that ~ :programs can become :logic functions after the ~ introductory event and that the same name can be ~ redefined several times. Unless noted in the ~ question above, the functions discussed are all ~ still :program. The commands we offer for ~ re-execution are those responsible for ~ introducing the most recent definitions of ~ :program names, whether the names are still ~ :program or not. That is, if in the region ~ undone there is more than one :program ~ definition of a name, we will offer to redo the ~ chronologically latest one.~%~%If you answer Y, ~ the command printed above will be re-executed. ~ If you answer N, it will not be. The answer Y! ~ means the same thing as answering Y to this and ~ all subsequent queries in this ~xi The answer ~ N! is analogous. Finally, Q means to abort the ~ ~xi without undoing anything." :y t :n nil :y! :all :n! :none :q :q)) (list (cons #\i kwd) (cons #\0 (access-command-tuple-form (cddar wrld1))) (cons #\1 (term-evisc-tuple t state)) (cons #\2 names) (cons #\3 logic-names) (cons #\4 (if (cdr logic-names) 1 0)) (cons #\5 (if (null logic-names) 0 1))) state))))) (cond ((eq ans :q) (mv t nil state)) (t (ubt-ubu-query kwd wrld2 wrld0 (union-eq names seen) (if (or (eq ans t) (eq ans :all)) (cons (access-command-tuple-defun-mode (cddar wrld1)) (cons (access-command-tuple-form (cddar wrld1)) (cond ((eq (access-command-tuple-defun-mode (cddar wrld1)) (car kept-commands)) (cdr kept-commands)) (t kept-commands)))) kept-commands) wrld state (or banger (if (eq ans :all) :all nil) (if (eq ans :none) :none nil))))))) (t (ubt-ubu-query kwd wrld2 wrld0 seen kept-commands wrld state banger)))))))
chk-virgin-msgfunction
(defun chk-virgin-msg (name new-type wrld state) (declare (ignore name new-type wrld)) (mv-let (erp val state) (read-acl2-oracle state) (let ((msg (or erp val))) (mv (and (msgp msg) msg) state))))
chk-virginfunction
(defun chk-virgin (name new-type ctx wrld state) (mv-let (msg state) (chk-virgin-msg name new-type wrld state) (cond (msg (er soft ctx "~@0" msg)) (t (value nil)))))
chk-boot-strap-redefineable-namepfunction
(defun chk-boot-strap-redefineable-namep (name ctx wrld state) (cond ((global-val 'boot-strap-pass-2 wrld) (value nil)) ((not (member-eq name (global-val 'chk-new-name-lst wrld))) (er soft ctx "The name ~x0 is already in use and is not among those expected ~ by chk-boot-strap-redefineable-namep to be redundantly defined ~ during initialization. If you wish it to be, add ~x0 to the ~ global-val setting of 'chk-new-name-lst in ~ primordial-world-globals." name)) (t (chk-virgin name t ctx wrld state))))
maybe-coerce-overwrite-to-erasefunction
(defun maybe-coerce-overwrite-to-erase (old-type new-type mode) (cond ((and (eq old-type 'function) (eq new-type 'function)) mode) (t :erase)))
redefinition-renewal-modefunction
(defun redefinition-renewal-mode (name all-names old-type new-type reclassifyingp ctx wrld state) (let ((act (f-get-global 'ld-redefinition-action state)) (proxy-upgrade-p (and (eq old-type 'function) (consp new-type) (eq (car new-type) 'function) (eq (getpropc name 'non-executablep nil wrld) :program) (equal (stobjs-in name wrld) (cadr new-type)) (equal (stobjs-out name wrld) (cddr new-type)))) (attachment-alist (attachment-alist name wrld))) (cond ((and reclassifyingp (not (consp reclassifyingp))) (cond ((and (let ((okp (f-get-global 'verify-termination-on-raw-program-okp state))) (not (or (eq okp t) (member-eq name okp)))) (member-eq name (f-get-global 'program-fns-with-raw-code state))) (er soft ctx "The function ~x0 must remain in :PROGRAM mode, because it ~ has been marked as a function that has special raw Lisp ~ code. To avoid this error, ~#1~[see :DOC ~ verify-termination-on-raw-program-okp~/consider removing ~ ~x0 from *initial-program-fns-with-raw-code*~]." name (if (f-get-global 'boot-strap-flg state) 1 0))) (t (value :reclassifying-overwrite)))) ((and attachment-alist (not (eq (car attachment-alist) :attachment-disallowed)) (not (f-get-global 'boot-strap-flg state))) (er soft ctx "The name ~x0 is in use as a ~@1, and it has an attachment. Before ~ redefining it you must remove its attachment, for example by ~ executing the form ~x2. We hope that this is not a significant ~ inconvenience; it seemed potentially too complex to execute such a ~ defattach form safely on your behalf." name (logical-name-type-string old-type) (cond ((programp name wrld) `(defattach (,NAME nil) :skip-checks t)) (t `(defattach ,NAME nil))))) ((and (null act) (not proxy-upgrade-p)) (mv-let (erp val state) (er soft ctx "The name ~x0 is in use as a ~@1.~#2~[ ~/ (This name is used in ~ the implementation of single-threaded objects.) ~/ Note that ~ ~@3~|~]The redefinition feature is currently off. See :DOC ~ ld-redefinition-action.~@4" name (logical-name-type-string old-type) (cond ((eq new-type 'stobj-live-var) 1) ((consp reclassifyingp) 2) (t 0)) reclassifyingp (cond ((eq (getpropc name 'non-executablep nil wrld) :program) (msg " Note that you are attempting to upgrade a proxy, ~ which is only legal using an encapsulate signature ~ that matches the original signature of the function; ~ see :DOC defproxy.")) (t ""))) (declare (ignore erp val)) (er-let* ((ev-wrld (er-decode-logical-name name wrld ctx state))) (pprogn (let ((book-path-rev (reverse (global-val 'include-book-path ev-wrld))) (current-path-rev (reverse (global-val 'include-book-path wrld)))) (io? error nil state (name book-path-rev current-path-rev ctx wrld) (pprogn (cond ((and (null book-path-rev) (acl2-system-namep name wrld)) (fms "Note: ~x0 has already been defined as a system ~ name; that is, it is built into ACL2.~|~%" (list (cons #\0 name)) (standard-co state) state nil)) ((null book-path-rev) (fms "Note: ~x0 was previously defined at the top ~ level~#1~[~/ of the book being certified~].~|~%" (list (cons #\0 name) (cons #\1 (if (f-get-global 'certify-book-info state) 1 0))) (standard-co state) state nil)) (t (pprogn (fms "Note: ~x0 was previously defined in the last ~ of the following books.~|~%" (list (cons #\0 name)) (standard-co state) state nil) (print-book-path book-path-rev 3 (standard-co state) ctx state) (newline (standard-co state) state)))) (cond ((null current-path-rev) state) (t (pprogn (fms "Note: the current attempt to define ~x0 is ~ being made in the last of the following ~ books.~|~%" (list (cons #\0 name)) (standard-co state) state nil) (print-book-path current-path-rev 3 (standard-co state) ctx state) (newline (standard-co state) state))))))) (silent-error state))))) ((cdr (assoc-eq name (table-alist 'memoize-table wrld))) (er soft ctx "The name ~x0 is in use as a ~@1, and it is currently memoized. ~ You must execute ~x2 before attempting to redefine it." name (logical-name-type-string old-type) (list 'unmemoize (kwote name)))) ((eq new-type 'package) (er soft ctx "When a package is introduced, a rule is added describing the ~ result produced by (symbol-package-name (intern x pkg)). That ~ rule has a name, i.e., a rune, based on some symbol which must ~ be new. In the case of the current package definition the base ~ symbol for the rune in question is ~x0. The symbol is not new. ~ Furthermore, the redefinition facility makes no provision for ~ packages. Please rename the package or :ubt ~x0. Sorry." name)) ((null (getpropc name 'absolute-event-number nil wrld)) (er soft ctx "The name ~x0 appears to have been introduced in the signature list ~ of an encapsulate, yet is being defined non-locally." name)) ((and (defstobj-supporterp name wrld) (not (and (eq new-type 'stobj) (eq old-type 'stobj)))) (er soft ctx "The name ~x0 is in use supporting the implementation of ~ the single-threaded object ~x1. We do not permit such ~ names to be redefined except by redefining ~x1 itself with ~ a new DEFSTOBJ." name (defstobj-supporterp name wrld))) (t (let ((sysdefp (acl2-system-namep name wrld))) (cond ((and sysdefp (not (ttag (w state))) (not (and proxy-upgrade-p (f-get-global 'boot-strap-flg state)))) (er soft ctx "Redefinition of system names, such as ~x0, is not permitted ~ unless there is an active trust tag (ttag). See :DOC defttag." name)) (proxy-upgrade-p (cond ((eq (car attachment-alist) :attachment-disallowed) (er soft ctx "Implementation error: It is surprising to see ~ attachments disallowed for a non-executable :program ~ mode function (a proxy). See ~ redefinition-renewal-mode.")) (t (value :erase)))) ((eq (car act) :doit!) (value (maybe-coerce-overwrite-to-erase old-type new-type (cdr act)))) ((or (eq (car act) :query) (and sysdefp (or (eq (car act) :warn) (eq (car act) :doit)))) (let ((rest (cdr (member-eq name all-names)))) (er-let* ((ans (acl2-query :redef `("~#0~[~x1 is an ACL2 system~/The name ~x1 is in use ~ as a~] ~@2.~#3~[~/ Its current defun-mode is ~ ~@4.~] Do you ~#0~[really ~/~]want to redefine ~ it?~#6~[~/ Note: if you redefine it we will first ~ erase its supporters, ~&7.~]" :n nil :y t :e erase :o overwrite ,@(AND REST '(:Y! Y!)) :? ("N means ``no'' and answering that way will abort ~ the attempted redefinition. All other responses ~ allow the redefinition and may render ACL2 unsafe ~ and/or unsound. Y in the current context is the ~ same as ~#5~[E~/O~]~@8. E means ``erase the ~ property list of ~x1 before redefining it.'' O ~ means ``Overwrite existing properties of ~x1 ~ while redefining it'' but is different from ~ erasure only when a function is being redefined ~ as another function. Neither alternative is ~ guaranteed to produce a sensible ACL2 state. If ~ you are unsure of what all this means, abort with ~ N and see :DOC ld-redefinition-action for details." :n nil :y t :e erase :o overwrite ,@(AND REST '(:Y! Y!)))) (list (cons #\0 (if sysdefp 0 1)) (cons #\1 name) (cons #\2 (logical-name-type-string old-type)) (cons #\3 (if (eq old-type 'function) 1 0)) (cons #\4 (if (eq old-type 'function) (defun-mode-string (fdefun-mode name wrld)) nil)) (cons #\5 (if (eq (cdr act) :erase) 0 1)) (cons #\6 (if (defstobj-supporterp name wrld) 1 0)) (cons #\7 (let ((prop (getpropc (defstobj-supporterp name wrld) 'stobj nil wrld))) (and prop (list* name (access stobj-property prop :recognizer) (access stobj-property prop :creator) (access stobj-property prop :names))))) (cons #\8 (if rest (msg ", and Y! will assume a Y ~ response without further query ~ for the list of related names ~ not yet redefined, ~X01" rest (abbrev-evisc-tuple state)) ""))) state))) (cond ((null ans) (mv t nil state)) ((eq ans t) (value (maybe-coerce-overwrite-to-erase old-type new-type (cdr act)))) ((eq ans 'y!) (er-progn (set-ld-redefinition-action (cons ':doit! (cdr act)) state) (value (maybe-coerce-overwrite-to-erase old-type new-type (cdr act))))) ((eq ans 'erase) (value :erase)) (t (value (maybe-coerce-overwrite-to-erase old-type new-type :overwrite))))))) (t (value (maybe-coerce-overwrite-to-erase old-type new-type (cdr act))))))))))
redefined-names1function
(defun redefined-names1 (wrld ans) (cond ((null wrld) ans) ((eq (cadar wrld) 'redefined) (cond ((eq (car (cddar wrld)) :reclassifying-overwrite) (redefined-names1 (cdr wrld) ans)) (t (redefined-names1 (cdr wrld) (add-to-set-eq (caar wrld) ans))))) (t (redefined-names1 (cdr wrld) ans))))
redefined-namesfunction
(defun redefined-names (state) (redefined-names1 (w state) nil))
chk-redefineable-namepfunction
(defun chk-redefineable-namep (name all-names new-type reclassifyingp ctx wrld state) (let ((old-type (logical-name-type name wrld nil))) (cond ((and (f-get-global 'boot-strap-flg state) (not (global-val 'boot-strap-pass-2 wrld)) (or (not reclassifyingp) (consp reclassifyingp))) (er-progn (chk-boot-strap-redefineable-namep name ctx wrld state) (value wrld))) (t (er-let* ((renewal-mode (redefinition-renewal-mode name all-names old-type new-type reclassifyingp ctx wrld state))) (cond ((defstobj-supporterp name wrld) (value (renew-names (let ((prop (getpropc (defstobj-supporterp name wrld) 'stobj nil wrld))) (list* name (access stobj-property prop :live-var) (access stobj-property prop :recognizer) (access stobj-property prop :creator) (access stobj-property prop :names))) renewal-mode wrld))) (t (value (renew-name name renewal-mode wrld)))))))))
chk-just-new-namefunction
(defun chk-just-new-name (name all-names new-type reclassifyingp ctx w state) (cond ((new-namep name w) (let ((actual-new-type (cond ((and (consp new-type) (eq (car new-type) 'function)) 'function) (t new-type)))) (er-progn (chk-virgin name actual-new-type ctx w state) (value w)))) ((and (f-get-global 'boot-strap-flg state) (not (global-val 'boot-strap-pass-2 w)) (or (not reclassifyingp) (consp reclassifyingp))) (er-progn (chk-boot-strap-redefineable-namep name ctx w state) (value w))) (t (chk-redefineable-namep name all-names new-type reclassifyingp ctx w state))))
no-new-namespfunction
(defun no-new-namesp (lst wrld) (cond ((null lst) t) ((new-namep (car lst) wrld) nil) (t (no-new-namesp (cdr lst) wrld))))
chk-just-new-names-recfunction
(defun chk-just-new-names-rec (names all-names new-type reclassifyingp ctx w state) (cond ((null names) (value w)) (t (er-let* ((wrld1 (chk-just-new-name (car names) all-names new-type reclassifyingp ctx w state))) (chk-just-new-names-rec (cdr names) all-names new-type reclassifyingp ctx wrld1 state)))))
chk-just-new-namesfunction
(defun chk-just-new-names (names new-type reclassifyingp ctx w state) (cond ((null names) (value w)) (t (state-global-let* ((ld-redefinition-action (ld-redefinition-action state))) (chk-just-new-names-rec names names new-type reclassifyingp ctx w state)))))
alpha-<function
(defun alpha-< (x y) (let ((xstr (if (symbolp x) (symbol-name x) x)) (ystr (if (symbolp y) (symbol-name y) y))) (cond ((string< xstr ystr) t) ((equal xstr ystr) (if (symbolp x) (if (symbolp y) (string< (symbol-package-name x) (symbol-package-name y)) t) nil)) (t nil))))
merge-alpha-<function
(defun merge-alpha-< (l1 l2) (cond ((null l1) l2) ((null l2) l1) ((alpha-< (car l1) (car l2)) (cons (car l1) (merge-alpha-< (cdr l1) l2))) (t (cons (car l2) (merge-alpha-< l1 (cdr l2))))))
merge-sort-alpha-<function
(defun merge-sort-alpha-< (l) (cond ((null (cdr l)) l) (t (merge-alpha-< (merge-sort-alpha-< (evens l)) (merge-sort-alpha-< (odds l))))))
putprop-unlessfunction
(defun putprop-unless (sym key val exception wrld) (cond ((equal val exception) wrld) (t (putprop sym key val wrld))))
redefined-warningfunction
(defun redefined-warning (redef ctx state) (if redef (warning$ ctx "Redef" "~&0 redefined.~%~%" (if (atom redef) (list redef) redef)) state))
redundant-labelpfunction
(defun redundant-labelp (name event-form wrld) (and (global-val 'boot-strap-pass-2 wrld) (getpropc name 'label nil wrld) (equal event-form (get-event name wrld))))
deflabel-fnfunction
(defun deflabel-fn (name state event-form) (with-ctx-summarized (cons 'deflabel name) (let ((wrld1 (w state)) (event-form (or event-form (list 'deflabel name)))) (cond ((redundant-labelp name event-form wrld1) (stop-redundant-event ctx state)) (t (er-progn (chk-all-but-new-name name ctx 'label wrld1 state) (er-let* ((wrld2 (chk-just-new-name name nil 'label nil ctx wrld1 state))) (let ((wrld3 (putprop name 'label t wrld2))) (install-event name event-form 'deflabel name nil nil nil nil wrld3 state)))))))))
degree-of-match2function
(defun degree-of-match2 (ch1 ch2 str i maximum) (cond ((< (1+ i) maximum) (if (and (eql ch1 (normalize-char (char str i) nil)) (eql ch2 (normalize-char (char str (1+ i)) nil))) 1 (degree-of-match2 ch1 ch2 str (1+ i) maximum))) (t 0)))
degree-of-match1function
(defun degree-of-match1 (pat-lst str maximum) (cond ((null pat-lst) 0) ((null (cdr pat-lst)) 0) (t (+ (degree-of-match2 (car pat-lst) (cadr pat-lst) str 0 maximum) (degree-of-match1 (cdr pat-lst) str maximum)))))
degree-of-matchfunction
(defun degree-of-match (pat-lst str) (if (< (length pat-lst) 2) 0 (/ (degree-of-match1 pat-lst str (length str)) (1- (length pat-lst)))))
find-likely-near-missesfunction
(defun find-likely-near-misses (pat-lst alist) (cond ((null alist) nil) (t (let ((d (degree-of-match pat-lst (if (stringp (caar alist)) (caar alist) (symbol-name (caar alist)))))) (cond ((<= d 1/2) (find-likely-near-misses pat-lst (cdr alist))) (t (cons (cons d (caar alist)) (find-likely-near-misses pat-lst (cdr alist)))))))))
print-doc-dwimfunction
(defun print-doc-dwim (name ctx state) (let ((lst (merge-sort-car-> (find-likely-near-misses (normalize-string (if (stringp name) name (symbol-name name)) nil) *acl2-system-documentation*)))) (er soft ctx "There is no documentation for ~x0.~#1~[~/ A similar documented name ~ is ~&2.~/ Similar documented names are ~&2.~]~|~%NOTE: See also ~ :DOC finding-documentation." name (zero-one-or-more (length lst)) (strip-cdrs lst))))
doc-fnfunction
(defun doc-fn (name state) (cond ((not (symbolp name)) (er soft 'doc "Documentation topics are symbols.")) (t (let ((entry (assoc name *acl2-system-documentation*))) (cond (entry (mv-let (col state) (fmt1 "Parent~#0~[~/s~]: ~&0.~|~%" (list (cons #\0 (cadr entry))) 0 *standard-co* state nil) (declare (ignore col)) (pprogn (princ$ (caddr entry) *standard-co* state) (newline *standard-co* state) (value :invisible)))) (t (print-doc-dwim name :doc state)))))))
helpmacro
(defmacro help nil '(pprogn (fms "For information about <name>, type :DOC <name>. For an ~ introduction to the ACL2 documentation, type :DOC ~ documentation.~|" nil (standard-co state) state nil) (value :invisible)))
trans-fnfunction
(defun trans-fn (form state) (io? temporary nil (mv erp val state) (form) (let ((wrld (w state)) (channel (standard-co state))) (mv-let (flg val bindings state) (translate1 form :stobjs-out '((:stobjs-out . :stobjs-out)) t 'top-level wrld state) (cond ((null flg) (pprogn (fms "~Y01~%=> ~y2~|~%" (list (cons #\0 val) (cons #\1 (term-evisc-tuple nil state)) (cons #\2 (prettyify-stobjs-out (translate-deref :stobjs-out bindings)))) channel state nil) (value :invisible))) (t (er soft 'trans ":Trans has failed. Consider trying :trans! ~ instead; see :DOC trans!.")))))))
trans!-fnfunction
(defun trans!-fn (form state) (io? temporary nil (mv erp val state) (form) (let ((wrld (w state)) (channel (standard-co state))) (mv-let (flg val bindings state) (translate1 form t nil t 'top-level wrld state) (declare (ignore bindings)) (cond ((null flg) (pprogn (fms "~Y01~|~%" (list (cons #\0 val) (cons #\1 (term-evisc-tuple nil state))) channel state nil) (value :invisible))) (t (value :invisible)))))))
trans1-fnfunction
(defun trans1-fn (form state) (if (and (consp form) (true-listp form) (symbolp (car form)) (getpropc (car form) 'macro-body)) (macroexpand1 form 'top-level state) (er soft 'top-level "TRANS1 may only be applied to a form (m t1 ... tk) where m is a ~ symbol with a 'macro-body property.")))
translammacro
(defmacro translam (x) `(mv-let (flg val bindings state) (cmp-and-value-to-error-quadruple (translate11-lambda-object ,X '(nil) nil nil nil nil 'translam (w state) (default-state-vars state) nil)) (declare (ignore bindings)) (mv flg val state)))
tc-fnfunction
(defun tc-fn (level form state) (declare (xargs :mode :program)) (let ((wrld (w state))) (mv-let (flg term bindings state) (translate1 form :stobjs-out '((:stobjs-out . :stobjs-out)) t 'top-level wrld state) (declare (ignore bindings)) (cond ((null flg) (let ((hyps (mv-let (warrants unwarranteds) (warrants-for-tamep-lambdap term wrld nil nil) (declare (ignore unwarranteds)) warrants))) (cond ((eql level 0) (value (untranslate term nil wrld))) ((eql level 1) (value (possibly-clean-up-dirty-lambda-objects hyps (remove-guard-holders-weak term (remove-guard-holders-lamp)) wrld (remove-guard-holders-lamp)))) (t (value (untranslate (possibly-clean-up-dirty-lambda-objects hyps (remove-guard-holders-weak term (remove-guard-holders-lamp)) wrld (remove-guard-holders-lamp)) nil wrld)))))) (t (mv t :invisible state))))))
tilde-*-props-fn-phrase1function
(defun tilde-*-props-fn-phrase1 (alist) (cond ((null alist) nil) (t (cons (msg "~y0~|~ ~y1~|" (caar alist) (cdar alist)) (tilde-*-props-fn-phrase1 (cdr alist))))))
tilde-*-props-fn-phrasefunction
(defun tilde-*-props-fn-phrase (alist) (list "none" "~@*" "~@*" "~@*" (tilde-*-props-fn-phrase1 alist)))
props-fnfunction
(defun props-fn (sym state) (cond ((symbolp sym) (io? temporary nil (mv erp val state) (sym) (pprogn (fms "ACL2 Properties of ~y0:~%~*1~%" (list (cons #\0 sym) (cons #\1 (tilde-*-props-fn-phrase (getprops sym 'current-acl2-world (w state))))) (standard-co state) state (ld-evisc-tuple state)) (value :invisible)))) (t (er soft :props "~x0 is not a symbol." sym))))
walkabout-nthfunction
(defun walkabout-nth (i x) (cond ((int= i 0) (cond ((atom x) (mv t #\.)) (t (mv nil (car x))))) ((atom x) (mv nil x)) (t (walkabout-nth (1- i) (cdr x)))))
walkabout-ipfunction
(defun walkabout-ip (i x) (cond ((null x) nil) ((atom x) (or (int= i 0) (int= i 1))) ((int= i 0) t) (t (walkabout-ip (1- i) (cdr x)))))
walkabout-huhfunction
(defun walkabout-huh (state) (pprogn (princ$ "Huh?" *standard-co* state) (newline *standard-co* state) (mv 'continue nil nil state)))
walkabout1function
(defun walkabout1 (i x cmds state intern-flg evisc-tuple alt-evisc-tuple) (let ((skip-printingp (consp i)) (i (if (consp i) (cdr i) i))) (mv-let (dotp xi) (walkabout-nth i x) (pprogn (if skip-printingp state (mv-let (col state) (fmt1 (if dotp ".~%:" "~y0~|:") (list (cons #\0 xi)) 0 *standard-co* state (if (eq alt-evisc-tuple :none) evisc-tuple alt-evisc-tuple)) (declare (ignore col)) state)) (mv-let (signal val cmds state) (mv-let (erp obj cmds state) (if cmds (mv-let (col state) (fmt1 "~x0~|" (list (cons #\0 (car cmds))) 0 *standard-co* state nil) (declare (ignore col)) (mv nil (car cmds) (cdr cmds) state)) (mv-let (erp obj state) (read-object *standard-oi* state) (mv erp (if (and (symbolp obj) (equal (symbol-name obj) "UP")) 0 obj) nil state))) (cond (erp (mv 'exit nil nil state)) (t (let ((obj (cond ((not intern-flg) obj) ((symbolp obj) (intern (symbol-name obj) "ACL2")) ((atom obj) obj) ((symbolp (car obj)) (cons (intern (symbol-name (car obj)) "ACL2") (cdr obj))) (t obj)))) (case obj (nx (if (walkabout-ip (1+ i) x) (mv 'continue (1+ i) cmds state) (walkabout-huh state))) (bk (if (= i 0) (walkabout-huh state) (mv 'continue (1- i) cmds state))) (0 (mv 'up nil cmds state)) (pp (mv 'continue-fullp nil cmds state)) (= (mv 'exit xi cmds state)) (q (mv 'exit :invisible nil state)) (otherwise (cond ((and (integerp obj) (> obj 0)) (cond ((atom xi) (walkabout-huh state)) ((walkabout-ip (1- obj) xi) (walkabout1 (1- obj) xi cmds state intern-flg evisc-tuple :none)) (t (walkabout-huh state)))) ((and (consp obj) (eq (car obj) 'pp)) (mv-let (print-level print-length) (let ((args (cdr obj))) (case-match args ((print-level print-length) (mv print-level print-length)) ((n) (mv n n)) (& (mv :bad nil)))) (cond ((and (or (natp print-level) (null print-level)) (or (natp print-length) (null print-length))) (mv 'continue-fullp (evisc-tuple print-level print-length nil nil) cmds state)) (t (walkabout-huh state))))) ((and (consp obj) (eq (car obj) '=) (consp (cdr obj)) (symbolp (cadr obj)) (null (cddr obj))) (pprogn (f-put-global 'walkabout-alist (cons (cons (cadr obj) xi) (f-get-global 'walkabout-alist state)) state) (mv-let (col state) (fmt1 "(walkabout= ~x0) is~%" (list (cons #\0 (cadr obj))) 0 *standard-co* state (ld-evisc-tuple state)) (declare (ignore col)) (mv 'continue nil cmds state)))) ((and (consp obj) (eq (car obj) 'cmds) (true-listp (cdr obj))) (mv 'continue (cons 'skip-printing i) (append (cdr obj) cmds) state)) (t (walkabout-huh state))))))))) (cond ((eq signal 'continue) (walkabout1 (or val i) x cmds state intern-flg evisc-tuple :none)) ((eq signal 'up) (mv 'continue nil cmds state)) ((eq signal 'continue-fullp) (walkabout1 i x cmds state intern-flg evisc-tuple val)) (t (mv 'exit val nil state))))))))
walkaboutfunction
(defun walkabout (x state) (pprogn (fms "Commands:~|1, 2, ..., up, nx, bk, pp, (pp n), (pp lev len), =, (= ~ symb), (cmds c1 c2 ... cn), and q.~%~%" nil *standard-co* state nil) (mv-let (signal val cmds state) (walkabout1 0 (list x) nil state (not (equal (current-package state) "ACL2")) (evisc-tuple 2 3 nil nil) :none) (declare (ignore signal cmds)) (value val))))
walkabout=-fnfunction
(defun walkabout=-fn (var state) (cond ((symbolp var) (cdr (assoc-eq var (f-get-global 'walkabout-alist state)))) (t nil)))
walkabout=macro
(defmacro walkabout= (var) `(walkabout=-fn ',VAR state))
lookup-bddnotefunction
(defun lookup-bddnote (cl-id bddnotes) (cond ((endp bddnotes) nil) ((equal cl-id (access bddnote (car bddnotes) :cl-id)) (car bddnotes)) (t (lookup-bddnote cl-id (cdr bddnotes)))))
update-bddnote-with-termfunction
(defun update-bddnote-with-term (cl-id term bddnotes) (cond ((endp bddnotes) (er hard 'update-bddnote-with-term "Expected to find clause with name ~@0, but did not!" (tilde-@-clause-id-phrase cl-id))) ((equal cl-id (access bddnote (car bddnotes) :cl-id)) (cons (change bddnote (car bddnotes) :term term) (cdr bddnotes))) (t (cons (car bddnotes) (update-bddnote-with-term cl-id term (cdr bddnotes))))))
show-bddmacro
(defmacro show-bdd (&optional str goal-query-response counterex-query-response term-query-response) (cond ((not (symbolp goal-query-response)) `(er soft 'show-bdd "The optional second argument of show-bdd must be a symbol, but ~x0 ~ is not." ',GOAL-QUERY-RESPONSE)) ((not (symbolp counterex-query-response)) `(er soft 'show-bdd "The optional third argument of show-bdd must be a symbol, but ~x0 ~ is not." ',COUNTEREX-QUERY-RESPONSE)) ((not (symbolp term-query-response)) `(er soft 'show-bdd "The optional fourth argument of show-bdd must be a symbol, but ~x0 ~ is not." ',TERM-QUERY-RESPONSE)) (t `(show-bdd-fn ,STR ',GOAL-QUERY-RESPONSE ',COUNTEREX-QUERY-RESPONSE ',TERM-QUERY-RESPONSE state))))
show-bdd-goalfunction
(defun show-bdd-goal (query-response bddnote chan state) (let* ((goal (untranslate (access bddnote bddnote :goal-term) t (w state)))) (pprogn (fms "BDD input term (derived from ~@1):~|" (list (cons #\1 (tilde-@-clause-id-phrase (access bddnote bddnote :cl-id)))) (standard-co state) state nil) (cond (query-response state) (t (fms "~q2~|" (list (cons #\2 goal)) (standard-co state) state (evisc-tuple 5 7 nil nil)))) (cond ((equal goal (eviscerate-simple goal 5 7 nil (table-alist 'evisc-table (w state)) nil)) state) (t (mv-let (erp ans state) (if query-response (let ((query-response (intern (symbol-name query-response) "KEYWORD"))) (value (case query-response (:w :w) (:nil nil) (otherwise t)))) (acl2-query :show-bdd '("Print the goal in full?" :n nil :y t :w :w :? ("Y will print the goal in full. W will put you in a ~ structural display editor that lets you type a ~ positive integer N to dive to the Nth element of the ~ current list, 0 to go up a level, PP to print the ~ current object in full, and Q to quit." :n nil :y t :w :w)) nil state)) (declare (ignore erp)) (cond ((eq ans :w) (mv-let (erp ans state) (walkabout goal state) (declare (ignore erp ans)) state)) (ans (fms "~x0~|" (list (cons #\0 goal)) chan state nil)) (t state))))))))
merge-car-term-orderfunction
(defun merge-car-term-order (l1 l2) (cond ((null l1) l2) ((null l2) l1) ((term-order (car (car l1)) (car (car l2))) (cons (car l1) (merge-car-term-order (cdr l1) l2))) (t (cons (car l2) (merge-car-term-order l1 (cdr l2))))))
merge-sort-car-term-orderfunction
(defun merge-sort-car-term-order (l) (cond ((null (cdr l)) l) (t (merge-car-term-order (merge-sort-car-term-order (evens l)) (merge-sort-car-term-order (odds l))))))
falsifying-pair-pfunction
(defun falsifying-pair-p (term val asst) (cond ((endp asst) nil) ((equal term (caar asst)) (or (and (null val) (equal (cadar asst) *some-non-nil-value*)) (and (null (cadar asst)) (equal val *some-non-nil-value*)) (falsifying-pair-p term val (cdr asst)))) (t nil)))
bogus-falsifying-assignment-varfunction
(defun bogus-falsifying-assignment-var (asst) (cond ((endp asst) nil) ((falsifying-pair-p (caar asst) (cadar asst) (cdr asst)) (caar asst)) (t (bogus-falsifying-assignment-var (cdr asst)))))
show-falsifying-assignmentfunction
(defun show-falsifying-assignment (query-response bddnote chan state) (let ((cst (access bddnote bddnote :cst))) (cond ((cst-tp cst) (fms "There is no falsifying assignment, since ~@0 was proved." (list (cons #\0 (tilde-@-clause-id-phrase (access bddnote bddnote :cl-id)))) chan state nil)) (t (let ((asst (falsifying-assignment cst (access bddnote bddnote :mx-id)))) (pprogn (let ((var (bogus-falsifying-assignment-var (merge-sort-car-term-order asst)))) (cond (var (fms "WARNING: The term ~p0 is assigned both to ~ nil and a non-nil value in the following ~ assignment. This generally occurs because ~ the term is not known to be Boolean. ~ Consider adding appropriate booleanp or ~ boolean-listp hypotheses. See :DOC ~ bdd-introduction." (list (cons #\0 var)) (standard-co state) state (evisc-tuple 5 7 nil nil))) (t state))) (fms "Falsifying constraints:~%" nil chan state nil) (cond (query-response state) (t (fms "~x0~|" (list (cons #\0 asst)) chan state (evisc-tuple 5 (max 7 (length asst)) nil nil)))) (cond ((equal asst (eviscerate-simple asst 5 (max 7 (length asst)) nil (table-alist 'evisc-table (w state)) nil)) state) (t (mv-let (erp ans state) (if query-response (let ((query-response (intern (symbol-name query-response) "KEYWORD"))) (value (case query-response (:w :w) (:nil nil) (otherwise t)))) (acl2-query :show-bdd '("Print the falsifying constraints in full?" :n nil :y t :w :w :? ("Y will print the constraints in full. W will put ~ you in a structural display editor that lets you ~ type a positive integer N to dive to the Nth ~ element of the current list, 0 to go up a level, ~ PP to print the current object in full, and Q to ~ quit." :n nil :y t :w :w)) nil state)) (declare (ignore erp)) (cond ((eq ans :w) (mv-let (erp ans state) (walkabout asst state) (declare (ignore erp ans)) state)) (ans (fms "~x0~|" (list (cons #\0 asst)) chan state nil)) (t state)))))))))))
show-bdd-termfunction
(defun show-bdd-term (query-response bddnote chan state) (let* ((orig-term (access bddnote bddnote :term)) (term (if orig-term orig-term (mv-let (term cst-array) (decode-cst (access bddnote bddnote :cst) (leaf-cst-list-array (access bddnote bddnote :mx-id))) (declare (ignore cst-array)) term)))) (pprogn (cond ((null orig-term) (f-put-global 'bddnotes (update-bddnote-with-term (access bddnote bddnote :cl-id) term (f-get-global 'bddnotes state)) state)) (t state)) (fms "Term obtained from BDD computation on ~@1:~|" (list (cons #\1 (tilde-@-clause-id-phrase (access bddnote bddnote :cl-id)))) (standard-co state) state nil) (cond (query-response state) (t (fms "~x2~|" (list (cons #\2 term)) (standard-co state) state (evisc-tuple 5 7 nil nil)))) (cond ((equal term (eviscerate-simple term 5 7 nil (table-alist 'evisc-table (w state)) nil)) state) (t (mv-let (erp ans state) (if query-response (let ((query-response (intern (symbol-name query-response) "KEYWORD"))) (value (case query-response (:w :w) (:nil nil) (otherwise t)))) (acl2-query :show-bdd '("Print the term in full?" :n nil :y t :w :w :? ("Y will print the term in full. W will put you in a ~ structural display editor that lets you type a ~ positive integer N to dive to the Nth element of the ~ current list, 0 to go up a level, PP to print the ~ current object in full, and Q to quit." :n nil :y t :w :w)) nil state)) (declare (ignore erp)) (cond ((eq ans :w) (mv-let (erp ans state) (walkabout term state) (declare (ignore erp ans)) state)) (ans (fms "~x0~|" (list (cons #\0 term)) chan state nil)) (t state))))))))
tilde-*-substitution-phrase1function
(defun tilde-*-substitution-phrase1 (alist is-replaced-by-str evisc-tuple wrld) (cond ((null alist) nil) (t (cons (msg "~P01 ~s2 ~P31" (untranslate (caar alist) nil wrld) evisc-tuple is-replaced-by-str (untranslate (cdar alist) nil wrld)) (tilde-*-substitution-phrase1 (cdr alist) is-replaced-by-str evisc-tuple wrld)))))
tilde-*-substitution-phrasefunction
(defun tilde-*-substitution-phrase (alist is-replaced-by-str evisc-tuple wrld) (list* "" "~@*" "~@* and " "~@*, " (tilde-*-substitution-phrase1 alist is-replaced-by-str evisc-tuple wrld) nil))
show-bdd-backtracefunction
(defun show-bdd-backtrace (call-stack cst-array chan state) (cond ((endp call-stack) state) (t (mv-let (term-list cst-array) (decode-cst-lst (strip-cdrs (cdar call-stack)) cst-array) (let ((term (untranslate (caar call-stack) nil (w state))) (alist (pairlis$ (strip-cars (cdar call-stack)) term-list))) (pprogn (fms "~X02~| alist: ~*1~|" (list (cons #\0 term) (cons #\1 (tilde-*-substitution-phrase alist ":=" (evisc-tuple 5 (max 7 (length alist)) nil nil) (w state))) (cons #\2 (evisc-tuple 5 7 nil nil))) chan state nil) (show-bdd-backtrace (cdr call-stack) cst-array chan state)))))))
show-bdd-fnfunction
(defun show-bdd-fn (str goal-query-response counterex-query-response term-query-response state) (let ((bddnotes (f-get-global 'bddnotes state)) (cl-id (parse-clause-id str)) (separator "==============================~%")) (cond ((and str (null cl-id)) (er soft 'show-bdd "The string ~x0 does not have the syntax of a goal name. See :DOC ~ goal-spec." str)) (t (let ((bddnote (if cl-id (lookup-bddnote cl-id bddnotes) (car bddnotes))) (chan (standard-co state))) (cond ((null bddnote) (er soft 'show-bdd "There is no recent record of applying BDDs~#0~[~/ to ~s1~]." (if str 1 0) (if (eq str t) "Goal" str))) (t (pprogn (show-bdd-goal goal-query-response bddnote chan state) (fms "~@0" (list (cons #\0 separator)) chan state nil) (fms "BDD computation on ~@0 yielded ~x1 nodes.~|~@2" (list (cons #\0 (tilde-@-clause-id-phrase (access bddnote bddnote :cl-id))) (cons #\1 (access bddnote bddnote :mx-id)) (cons #\2 separator)) chan state nil) (cond ((access bddnote bddnote :err-string) (pprogn (fms "BDD computation was aborted on ~@0, and hence there is ~ no falsifying assignment that can be constructed. ~ Here is a backtrace of calls, starting with the ~ top-level call and ending with the one that led to the ~ abort. See :DOC show-bdd.~|" (list (cons #\0 (tilde-@-clause-id-phrase (access bddnote bddnote :cl-id)))) chan state nil) (show-bdd-backtrace (access bddnote bddnote :bdd-call-stack) (leaf-cst-list-array (access bddnote bddnote :mx-id)) chan state) (value :invisible))) (t (pprogn (show-falsifying-assignment counterex-query-response bddnote chan state) (fms "~@0" (list (cons #\0 separator)) chan state nil) (show-bdd-term term-query-response bddnote chan state) (value :invisible))))))))))))
get-docsfunction
(defun get-docs (lst) (cond ((null lst) nil) (t (cons (third (car lst)) (get-docs (cdr lst))))))
get-guardspfunction
(defun get-guardsp (lst wrld) (cond ((null lst) nil) ((get-guards1 (fourth (car lst)) '(guards types) nil nil wrld) t) (t (get-guardsp (cdr lst) wrld))))
*no-measure*constant
(defconst *no-measure* *nil*)
get-measures1function
(defun get-measures1 (m edcls ctx state) (cond ((null edcls) (value m)) ((eq (caar edcls) 'xargs) (let ((temp (assoc-keyword :measure (cdar edcls)))) (cond ((null temp) (get-measures1 m (cdr edcls) ctx state)) ((equal m *no-measure*) (get-measures1 (cadr temp) (cdr edcls) ctx state)) ((equal m (cadr temp)) (get-measures1 m (cdr edcls) ctx state)) (t (er soft ctx "It is illegal to declare two different ~ measures for the admission of a single ~ function. But you have specified :MEASURE ~ ~x0 and :MEASURE ~x1." m (cadr temp)))))) (t (get-measures1 m (cdr edcls) ctx state))))
get-measures2function
(defun get-measures2 (lst ctx state) (cond ((null lst) (value nil)) (t (er-let* ((m (get-measures1 *no-measure* (fourth (car lst)) ctx state)) (rst (get-measures2 (cdr lst) ctx state))) (value (cons m rst))))))
get-measuresfunction
(defun get-measures (lst ctx state) (get-measures2 lst ctx state))
get-hints1function
(defun get-hints1 (edcls) (cond ((null edcls) nil) ((eq (caar edcls) 'xargs) (let ((temp (assoc-keyword :hints (cdar edcls)))) (cond ((null temp) (get-hints1 (cdr edcls))) ((true-listp (cadr temp)) (append (cadr temp) (get-hints1 (cdr edcls)))) (t (er hard 'get-hints "The value of :HINTS must satisfy the predicate ~x0. ~ The value ~x1 is thus illegal. See :DOC hints." 'true-listp (cadr temp)))))) (t (get-hints1 (cdr edcls)))))
get-hintsfunction
(defun get-hints (lst) (cond ((null lst) nil) (t (append (get-hints1 (fourth (car lst))) (get-hints (cdr lst))))))
get-guard-hints1function
(defun get-guard-hints1 (edcls) (cond ((null edcls) nil) ((eq (caar edcls) 'xargs) (let ((temp (assoc-keyword :guard-hints (cdar edcls)))) (cond ((null temp) (get-guard-hints1 (cdr edcls))) ((true-listp (cadr temp)) (append (cadr temp) (get-guard-hints1 (cdr edcls)))) (t (er hard 'get-guard-hints "The value of :GUARD-HINTS must satisfy the predicate ~ ~x0. The value ~x1 is thus illegal. See :DOC hints." 'true-listp (cadr temp)))))) (t (get-guard-hints1 (cdr edcls)))))
get-guard-hintsfunction
(defun get-guard-hints (lst) (cond ((null lst) nil) (t (append (get-guard-hints1 (fourth (car lst))) (get-guard-hints (cdr lst))))))
get-normalizepfunction
(defun get-normalizep (edcls ans ctx state) (cond ((null edcls) (value (if (eq ans :absent) t ans))) ((eq (caar edcls) 'xargs) (let ((temp (assoc-keyword :normalize (cdar edcls)))) (cond ((null temp) (get-normalizep (cdr edcls) ans ctx state)) ((not (member-eq (cadr temp) '(t nil))) (er soft ctx "The :NORMALIZE keyword specified by XARGS must have value t ~ or nil, but the following has been supplied: ~p0." (cadr temp))) ((eq ans :absent) (get-normalizep (cdr edcls) (cadr temp) ctx state)) (t (er soft ctx "Only one :NORMALIZE keyword may be specified by XARGS."))))) (t (get-normalizep (cdr edcls) ans ctx state))))
get-normalizepsfunction
(defun get-normalizeps (lst acc ctx state) (cond ((null lst) (value (reverse acc))) (t (er-let* ((normalizep (get-normalizep (fourth (car lst)) :absent ctx state))) (get-normalizeps (cdr lst) (cons normalizep acc) ctx state)))))
chk-xargs-keywords1function
(defun chk-xargs-keywords1 (edcls keywords ctx state) (cond ((null edcls) (value nil)) ((eq (caar edcls) 'xargs) (cond ((null keywords) (er soft ctx "No XARGS declaration is legal in this context.")) ((subsetp-eq (evens (cdar edcls)) keywords) (chk-xargs-keywords1 (cdr edcls) keywords ctx state)) (t (er soft ctx "The only acceptable XARGS keyword~#0~[ in this context ~ is~/s in this context are~] ~&0. Thus, the ~ keyword~#1~[ ~&1 is~/s ~&1 are~] illegal.~#2~[~/ ~ Perhaps you meant :HINTS instead of :MEASURE-HINTS.~]" keywords (set-difference-eq (evens (cdar edcls)) keywords) (if (member-eq :measure-hints (evens (cdar edcls))) 1 0))))) (t (chk-xargs-keywords1 (cdr edcls) keywords ctx state))))
chk-xargs-keywordsfunction
(defun chk-xargs-keywords (lst keywords ctx state) (cond ((null lst) (value nil)) (t (er-progn (chk-xargs-keywords1 (fourth (car lst)) keywords ctx state) (chk-xargs-keywords (cdr lst) keywords ctx state)))))
get-namesfunction
(defun get-names (lst) (cond ((null lst) nil) (t (cons (caar lst) (get-names (cdr lst))))))
get-bodiesfunction
(defun get-bodies (lst) (cond ((null lst) nil) (t (cons (fifth (car lst)) (get-bodies (cdr lst))))))
find-nontrivial-rulersmutual-recursion
(mutual-recursion (defun find-nontrivial-rulers (var term) (cond ((variablep term) (if (eq var term) :none nil)) ((fquotep term) nil) ((eq (ffn-symb term) 'if) (let ((x (find-nontrivial-rulers var (fargn term 2)))) (cond (x (cons (fargn term 1) (if (eq x :none) nil x))) (t (let ((x (find-nontrivial-rulers var (fargn term 3)))) (cond (x (cons (dumb-negate-lit (fargn term 1)) (if (eq x :none) nil x))) (t (find-nontrivial-rulers var (fargn term 1))))))))) (t (find-nontrivial-rulers-lst var (fargs term) nil)))) (defun find-nontrivial-rulers-lst (var termlist flg) (cond ((endp termlist) flg) (t (let ((x (find-nontrivial-rulers var (car termlist)))) (cond ((or (null x) (eq x :none)) (find-nontrivial-rulers-lst var (cdr termlist) (or flg x))) (t x)))))))
tilde-@-free-vars-phrasefunction
(defun tilde-@-free-vars-phrase (vars term wrld) (declare (xargs :guard (and (symbol-listp vars) (pseudo-termp term) (nvariablep term) (not (fquotep term)) (plist-worldp wrld)))) (cond ((endp vars) "") (t (let ((rulers (find-nontrivial-rulers (car vars) term))) (assert$ rulers (cond ((eq rulers :none) (tilde-@-free-vars-phrase (cdr vars) term wrld)) ((null (cdr rulers)) (msg " Note that ~x0 occurs in the context of condition ~ ~x1 from a surrounding IF test." (car vars) (untranslate (car rulers) t wrld))) (t (msg " Note that ~x0 occurs in the following context, ~ i.e., governed by these conditions from ~ surrounding IF tests.~|~% (AND~|~@1" (car vars) (print-indented-list-msg (untranslate-lst rulers t wrld) 3 ")")))))))))
chk-free-varsfunction
(defun chk-free-vars (name formals term loc-str ctx state) (declare (xargs :guard (and (symbol-listp formals) (pseudo-termp term)))) (cond ((subsetp (all-vars term) formals) (value nil)) ((variablep term) (er soft ctx "The ~@0 ~x1 is a free variable occurrence." loc-str name)) (t (assert$ (not (fquotep term)) (let ((vars (set-difference-eq (all-vars term) formals))) (er soft ctx "The ~@0 ~x1 contains ~#2~[a free occurrence of the ~ variable symbol~/free occurrences of the variable ~ symbols~] ~&2.~@3" loc-str name (set-difference-eq vars formals) (tilde-@-free-vars-phrase vars term (w state))))))))
chk-declared-ignoresfunction
(defun chk-declared-ignores (name ignores term loc-str ctx state) (declare (xargs :guard (and (symbol-listp ignores) (pseudo-termp term)))) (cond ((intersectp-eq (all-vars term) ignores) (er soft ctx "The ~@0 ~x1 uses the variable symbol~#2~[~/s~] ~&2, ~ contrary to the declaration that ~#2~[it is~/they are~] ~ IGNOREd." loc-str name (reverse (intersection-eq (all-vars term) ignores)))) (t (value nil))))
chk-free-and-ignored-varsfunction
(defun chk-free-and-ignored-vars (name formals guard split-types-term measure ignores ignorables body ctx state) (er-progn (chk-free-vars name formals guard "guard for" ctx state) (chk-free-vars name formals split-types-term "split-types expression for" ctx state) (chk-free-vars name formals measure "measure supplied with" ctx state) (chk-free-vars name formals (cons 'list ignores) "list of variables declared IGNOREd in" ctx state) (chk-free-vars name formals (cons 'list ignorables) "list of variables declared IGNORABLE in" ctx state) (chk-free-vars name formals body "body of" ctx state) (chk-declared-ignores name ignores body "body of" ctx state) (let* ((ignore-ok (cdr (assoc-eq :ignore-ok (table-alist 'acl2-defaults-table (w state))))) (undeclared-ignores (cond ((or (eq ignore-ok t) (and (not (eq ignore-ok nil)) (warning-disabled-p "Ignored-variables"))) nil) (t (set-difference-eq formals (union-eq (all-vars body) (union-eq ignorables ignores))))))) (cond ((and undeclared-ignores (eq ignore-ok nil)) (er soft ctx "The formal variable~#0~[ ~&0 is~/s ~&0 are~] not used in the ~ definition of ~x1 but ~#0~[is~/are~] not DECLAREd IGNOREd or ~ IGNORABLE. Any formal variable not used in the body of a ~ definition must be so declared. To remove this requirement, ~ see :DOC set-ignore-ok." undeclared-ignores name)) (undeclared-ignores (pprogn (warning$ ctx ("Ignored-variables") "The formal variable~#0~[ ~&0 is~/s ~&0 are~] not used ~ in the definition of ~x1 but ~#0~[is~/are~] not ~ DECLAREd IGNOREd or IGNORABLE. See :DOC set-ignore-ok ~ for how to either remove this warning or to enforce it ~ by causing an error." undeclared-ignores name) (value nil))) (t (value nil))))))
chk-free-and-ignored-vars-lstsfunction
(defun chk-free-and-ignored-vars-lsts (names arglists guards split-types-terms measures ignores ignorables bodies ctx state) (declare (xargs :guard (and (symbol-listp names) (symbol-list-listp arglists) (pseudo-term-listp guards) (pseudo-term-listp split-types-terms) (pseudo-term-listp measures) (pseudo-term-listp bodies) (symbol-list-listp ignores) (symbol-list-listp ignorables)))) (cond ((null names) (value nil)) (t (er-progn (chk-free-and-ignored-vars (car names) (car arglists) (car guards) (car split-types-terms) (car measures) (car ignores) (car ignorables) (car bodies) ctx state) (chk-free-and-ignored-vars-lsts (cdr names) (cdr arglists) (cdr guards) (cdr split-types-terms) (cdr measures) (cdr ignores) (cdr ignorables) (cdr bodies) ctx state)))))
putprop-x-lst1function
(defun putprop-x-lst1 (symbols key value wrld) (cond ((null symbols) wrld) (t (putprop-x-lst1 (cdr symbols) key value (putprop (car symbols) key value wrld)))))
putprop-x-lst2function
(defun putprop-x-lst2 (symbols key vals wrld) (cond ((null symbols) wrld) (t (putprop-x-lst2 (cdr symbols) key (cdr vals) (putprop (car symbols) key (car vals) wrld)))))
putprop-x-lst2-unlessfunction
(defun putprop-x-lst2-unless (symbols key vals exception wrld) (cond ((null symbols) wrld) (t (putprop-x-lst2-unless (cdr symbols) key (cdr vals) exception (putprop-unless (car symbols) key (car vals) exception wrld)))))
other
(defun@par translate-term-lst (terms stobjs-out logic-modep known-stobjs-lst ctx wrld state) (cond ((null terms) (value@par nil)) (t (er-let*@par ((term (translate@par (car terms) stobjs-out logic-modep (if (eq known-stobjs-lst t) t (car known-stobjs-lst)) ctx wrld state)) (rst (translate-term-lst@par (cdr terms) stobjs-out logic-modep (if (eq known-stobjs-lst t) t (cdr known-stobjs-lst)) ctx wrld state))) (value@par (cons term rst))))))
find-named-lemmafunction
(defun find-named-lemma (sym lst top-level) (cond ((null lst) nil) ((and (equal sym (base-symbol (access rewrite-rule (car lst) :rune))) (not (eq (access rewrite-rule (car lst) :subclass) 'meta))) (cond ((and top-level (null (find-named-lemma sym (cdr lst) nil))) (car lst)) (top-level nil) (t :several))) (t (find-named-lemma sym (cdr lst) top-level))))
find-runed-lemmafunction
(defun find-runed-lemma (rune lst) (cond ((null lst) nil) ((equal rune (access rewrite-rule (car lst) :rune)) (car lst)) (t (find-runed-lemma rune (cdr lst)))))
free-varsp-membermutual-recursion
(mutual-recursion (defun free-varsp-member (term vars) (cond ((variablep term) (not (member-eq term vars))) ((fquotep term) nil) (t (free-varsp-member-lst (fargs term) vars)))) (defun free-varsp-member-lst (args vars) (cond ((null args) nil) (t (or (free-varsp-member (car args) vars) (free-varsp-member-lst (cdr args) vars))))))
other
(defun@par translate-expand-term1 (name form free-vars ctx wrld state) (cond ((not (arglistp free-vars)) (er@par soft ctx "The use of :FREE in :expand hints should be of the form (:FREE ~ var-list x), where var-list is a list of distinct variables, unlike ~ ~x0." free-vars)) (t (er-let*@par ((term (translate@par form t t t ctx wrld state))) (let ((term (remove-guard-holders term wrld))) (cond ((or (variablep term) (fquotep term)) (er@par soft ctx "The term ~x0 is not expandable. See the :expand discussion in ~ :DOC hints." form)) ((flambda-applicationp term) (cond (name (er@par soft ctx "An :expand hint may only specify :WITH for an expression ~ that is the application of a function, unlike ~x0." form)) (t (value@par (make expand-hint :pattern term :alist (if (null free-vars) :none (let ((bound-vars (set-difference-eq (all-vars term) free-vars))) (pairlis$ bound-vars bound-vars))) :rune nil :equiv 'equal :hyp nil :lhs term :rhs (subcor-var (lambda-formals (ffn-symb term)) (fargs term) (lambda-body (ffn-symb term)))))))) (t (mv-let (er-msg rune equiv hyp lhs rhs) (cond (name (let* ((fn (ffn-symb term)) (lemmas (getpropc fn 'lemmas nil wrld)) (lemma (cond ((symbolp name) (find-named-lemma (deref-macro-name name (macro-aliases wrld)) lemmas t)) (t (find-runed-lemma name lemmas))))) (cond (lemma (let* ((hyps (access rewrite-rule lemma :hyps)) (lhs (access rewrite-rule lemma :lhs)) (lhs-vars (all-vars lhs)) (rhs (access rewrite-rule lemma :rhs))) (cond ((or (free-varsp-member-lst hyps lhs-vars) (free-varsp-member rhs lhs-vars)) (mv (msg "The ~@0 of a rule given to :with in an :expand ~ hint must not contain free variables that are ~ not among the variables on its left-hand side. ~ ~ The ~#1~[variable ~&1 violates~/variables ~ ~&1 violate~] this requirement." (if (free-varsp-member rhs lhs-vars) "left-hand side" "hypotheses") (if (free-varsp-member rhs lhs-vars) (reverse (set-difference-eq (all-vars rhs) lhs-vars)) (reverse (set-difference-eq (all-vars1-lst hyps nil) lhs-vars)))) nil nil nil nil nil)) (t (mv nil (access rewrite-rule lemma :rune) (access rewrite-rule lemma :equiv) (and hyps (conjoin hyps)) lhs rhs))))) (t (mv (msg "Unable to find a lemma for :expand hint (:WITH ~ ~x0 ...)." name) nil nil nil nil nil))))) (t (let ((def-body (def-body (ffn-symb term) wrld))) (cond (def-body (let ((formals (access def-body def-body :formals))) (mv nil (access def-body def-body :rune) (access def-body def-body :equiv) (access def-body def-body :hyp) (cons-term (ffn-symb term) formals) (access def-body def-body :concl)))) (t (mv (msg "The :expand hint for ~x0 is illegal, because ~ ~x1 is not a defined function." form (ffn-symb term)) nil nil nil nil nil)))))) (cond (er-msg (er@par soft ctx "~@0" er-msg)) (t (value@par (make expand-hint :pattern term :alist (if (null free-vars) :none (let ((bound-vars (set-difference-eq (all-vars term) free-vars))) (pairlis$ bound-vars bound-vars))) :rune rune :equiv equiv :hyp hyp :lhs lhs :rhs rhs))))))))))))
other
(defun@par translate-expand-term (x ctx wrld state) (case-match x (':lambdas (value@par x)) ((':free vars (':with name form)) (translate-expand-term1@par name form vars ctx wrld state)) ((':with name (':free vars form)) (translate-expand-term1@par name form vars ctx wrld state)) ((':with name form) (translate-expand-term1@par name form nil ctx wrld state)) ((':free vars form) (translate-expand-term1@par nil form vars ctx wrld state)) (& (cond ((or (atom x) (keywordp (car x))) (er@par soft ctx "An :expand hint must either be a term, the keyword :lambdas, ~ one of the forms (:free vars term) or (:with name term), or a ~ combination of those final two forms. The form ~x0 is thus ~ illegal for an :expand hint. See :DOC hints." x)) (t (translate-expand-term1@par nil x nil ctx wrld state))))))
other
(defun@par translate-expand-hint1 (arg acc ctx wrld state) (cond ((atom arg) (cond ((null arg) (value@par (reverse acc))) (t (er@par soft ctx "The value of the :expand hint must be a true list, but your ~ list ends in ~x0. See :DOC hints." arg)))) (t (er-let*@par ((xtrans (translate-expand-term@par (car arg) ctx wrld state))) (translate-expand-hint1@par (cdr arg) (cons xtrans acc) ctx wrld state)))))
other
(defun@par translate-expand-hint (arg ctx wrld state) (cond ((eq arg :lambdas) (translate-expand-hint1@par (list arg) nil ctx wrld state)) ((atom arg) (translate-expand-hint1@par arg nil ctx wrld state)) ((and (consp arg) (symbolp (car arg)) (not (eq (car arg) :lambdas))) (translate-expand-hint1@par (list arg) nil ctx wrld state)) ((and (consp arg) (consp (car arg)) (eq (caar arg) 'lambda)) (translate-expand-hint1@par (list arg) nil ctx wrld state)) (t (translate-expand-hint1@par arg nil ctx wrld state))))
cons-all-to-lstfunction
(defun cons-all-to-lst (new-members lst) (cond ((null new-members) nil) (t (cons (cons (car new-members) lst) (cons-all-to-lst (cdr new-members) lst)))))
other
(defun@par translate-substitution (substn ctx wrld state) (cond ((null substn) (value@par nil)) ((not (and (true-listp (car substn)) (= (length (car substn)) 2))) (er@par soft ctx "Each element of a substitution must be a pair of the form (var term), ~ where var is a variable symbol and term is a term. Your alleged ~ substitution contains the element ~x0, which is not of this form. See ~ the discussion of :instance in :DOC lemma-instance." (car substn))) (t (let ((var (caar substn)) (term (cadar substn))) (cond ((not (legal-variablep var)) (mv-let (x str) (find-first-bad-arg (list var)) (declare (ignore x)) (er@par soft ctx "It is illegal to substitute for the non-variable ~x0. ~ It fails to be a variable because ~@1. See :DOC name ~ and see :DOC lemma-instance, in particular the ~ discussion of :instance." var (or str "LEGAL-VARIABLEP says so, but FIND-FIRST-BAD-ARG ~ can't see why")))) (t (er-let*@par ((term (translate@par term t t t ctx wrld state)) (y (translate-substitution@par (cdr substn) ctx wrld state))) (cond ((assoc-eq var y) (er@par soft ctx "It is illegal to bind ~x0 twice in a substitution. ~ See the discussion of :instance in :DOC lemma-instance." var)) (t (value@par (cons (cons var term) y)))))))))))
other
(defun@par translate-substitution-lst (substn-lst ctx wrld state) (cond ((null substn-lst) (value@par nil)) (t (er-let*@par ((tsubstn (translate-substitution@par (car substn-lst) ctx wrld state)) (rst (translate-substitution-lst@par (cdr substn-lst) ctx wrld state))) (value@par (cons tsubstn rst))))))
get-rewrite-and-defn-runes-from-runic-mapping-pairsfunction
(defun get-rewrite-and-defn-runes-from-runic-mapping-pairs (pairs) (cond ((null pairs) nil) ((member-eq (cadr (car pairs)) '(:rewrite :definition)) (cons (cdr (car pairs)) (get-rewrite-and-defn-runes-from-runic-mapping-pairs (cdr pairs)))) (t (get-rewrite-and-defn-runes-from-runic-mapping-pairs (cdr pairs)))))
other
(defun@par translate-restrict-hint (arg ctx wrld state) (cond ((atom arg) (cond ((null arg) (value@par nil)) (t (er@par soft ctx "The value of the :RESTRICT hint must be an alistp (association ~ list), and hence a true list, but your list ends in ~x0. See :DOC ~ hints." arg)))) ((not (and (true-listp (car arg)) (cdr (car arg)))) (er@par soft ctx "Each member of a :RESTRICT hint must be a true list associating a name ~ with at least one substitution, but the member ~x0 of your hint ~ violates this requirement. See :DOC hints." (car arg))) ((not (or (symbolp (caar arg)) (and (runep (caar arg) wrld) (member-eq (car (caar arg)) '(:rewrite :definition))))) (er@par soft ctx "Each member of a :RESTRICT hint must be a true list whose first ~ element is either a symbol or a :rewrite or :definition rune in the ~ current ACL2 world. The member ~x0 of your hint violates this ~ requirement." (car arg))) (t (let ((runes (if (symbolp (caar arg)) (get-rewrite-and-defn-runes-from-runic-mapping-pairs (getpropc (caar arg) 'runic-mapping-pairs nil wrld)) (list (caar arg))))) (cond ((null runes) (er@par soft ctx "The name ~x0 does not correspond to any :rewrite or :definition ~ runes, so the element ~x1 of your :RESTRICT hint is not valid. ~ See :DOC hints." (caar arg) (car arg))) (t (er-let*@par ((subst-lst (translate-substitution-lst@par (cdr (car arg)) ctx wrld state)) (rst (translate-restrict-hint@par (cdr arg) ctx wrld state))) (value@par (append (cons-all-to-lst runes subst-lst) rst)))))))))
*do-not-processes*constant
(defconst *do-not-processes* '(generalize preprocess simplify eliminate-destructors fertilize eliminate-irrelevance))
coerce-to-process-name-lstfunction
(defun coerce-to-process-name-lst (lst) (declare (xargs :guard (symbol-listp lst))) (if lst (cons (intern (string-append (symbol-name (car lst)) "-CLAUSE") "ACL2") (coerce-to-process-name-lst (cdr lst))) nil))
coerce-to-acl2-package-lstfunction
(defun coerce-to-acl2-package-lst (lst) (declare (xargs :guard (symbol-listp lst))) (if lst (cons (intern (symbol-name (car lst)) "ACL2") (coerce-to-acl2-package-lst (cdr lst))) nil))
other
(defun@par chk-do-not-expr-value (lst expr ctx state) (cond ((atom lst) (cond ((null lst) (value@par nil)) (t (er@par soft ctx "The value of the :DO-NOT expression ~x0 is not a true ~ list and, hence, is not legal. In particular, the final ~ non-consp cdr is the atom ~x1. See :DOC hints." expr lst)))) ((and (symbolp (car lst)) (member-eq (car lst) *do-not-processes*)) (chk-do-not-expr-value@par (cdr lst) expr ctx state)) ((eq (car lst) 'induct) (er@par soft ctx "The value of the alleged :DO-NOT expression ~x0 includes INDUCT, ~ which is not the name of a process to turn off. You probably ~ mean to use :DO-NOT-INDUCT T or :DO-NOT-INDUCT :BYE instead. The ~ legal names are ~&1." expr *do-not-processes*)) (t (er@par soft ctx "The value of the alleged :DO-NOT expression ~x0 includes the ~ element ~x1, which is not the name of a process to turn off. ~ The legal names are ~&2." expr (car lst) *do-not-processes*))))
other
(defun@par translate-do-not-hint (expr ctx state) (let ((wrld (w state))) (er-let*@par ((trans-ans (if (legal-variablep expr) (value@par (cons nil (list expr))) (serial-first-form-parallel-second-form@par (simple-translate-and-eval expr (list (cons 'world wrld)) nil "A :do-not hint" ctx wrld state t) (simple-translate-and-eval@par expr (list (cons 'world wrld)) nil "A :do-not hint" ctx wrld state t (f-get-global 'safe-mode state) (gc-off state)))))) (cond ((not (symbol-listp (cdr trans-ans))) (er@par soft ctx "The expression following :do-not is required either to be a symbol ~ or an expression whose value is a true list of symbols, but the ~ expression ~x0 has returned the value ~x1. See :DOC hints." expr (cdr trans-ans))) (t (er-progn@par (chk-do-not-expr-value@par (coerce-to-acl2-package-lst (cdr trans-ans)) expr ctx state) (value@par (coerce-to-process-name-lst (cdr trans-ans)))))))))
other
(defun@par translate-do-not-induct-hint (arg ctx wrld state) (declare (ignore wrld)) (cond ((symbolp arg) (cond ((member-eq arg '(:otf :otf-flg-override)) (value@par arg)) ((keywordp arg) (er@par soft ctx "We do not allow :do-not-induct hint values in the keyword ~ package other than :OTF and :OTF-FLG-OVERRIDE. The value ~ ~x0 is thus illegal." arg)) (t (value@par arg)))) (t (er@par soft ctx "The :do-not-induct hint should be followed by a symbol. ~x0 is ~ thus illegal. See the :do-not-induct discussion in :DOC hints." arg))))
other
(defun@par translate-hands-off-hint1 (arg ctx wrld state) (cond ((atom arg) (cond ((null arg) (value@par nil)) (t (er@par soft ctx "The value of the :hands-off hint must be a true list, but your ~ list ends in ~x0. See the :hands-off discussion in :DOC hints." arg)))) ((and (consp (car arg)) (eq (car (car arg)) 'lambda) (consp (cdr (car arg))) (true-listp (cadr (car arg)))) (er-let*@par ((term (translate@par (cons (car arg) (cadr (car arg))) t t t ctx wrld state)) (term (value@par (remove-guard-holders term wrld))) (rst (translate-hands-off-hint1@par (cdr arg) ctx wrld state)) (rst (value@par (remove-guard-holders-lst rst wrld)))) (value@par (cons (ffn-symb term) rst)))) ((and (symbolp (car arg)) (function-symbolp (car arg) wrld)) (er-let*@par ((rst (translate-hands-off-hint1@par (cdr arg) ctx wrld state))) (value@par (cons (car arg) rst)))) (t (er@par soft ctx "The object ~x0 is not a legal element of a :hands-off hint. See the ~ :hands-off discussion in :DOC hints." (car arg)))))
other
(defun@par translate-hands-off-hint (arg ctx wrld state) (cond ((atom arg) (cond ((null arg) (value@par nil)) ((symbolp arg) (translate-hands-off-hint1@par (list arg) ctx wrld state)) (t (translate-hands-off-hint1@par arg ctx wrld state)))) ((eq (car arg) 'lambda) (translate-hands-off-hint1@par (list arg) ctx wrld state)) (t (translate-hands-off-hint1@par arg ctx wrld state))))
truncated-classfunction
(defun truncated-class (rune mapping-pairs classes) (cond ((null classes) nil) ((equal rune (cdr (car mapping-pairs))) (car classes)) (t (truncated-class rune (cdr mapping-pairs) (cdr classes)))))
tests-and-alists-lst-from-fnfunction
(defun tests-and-alists-lst-from-fn (fn wrld) (let* ((formals (formals fn wrld)) (term (fcons-term fn formals)) (quick-block-info (getpropc fn 'quick-block-info '(:error "See SUGGESTED-INDUCTION-CANDS1.") wrld)) (justification (getpropc fn 'justification '(:error "See SUGGESTED-INDUCTION-CANDS1.") wrld)) (mask (sound-induction-principle-mask term formals quick-block-info (access justification justification :subset))) (machine (getpropc fn 'induction-machine nil wrld))) (tests-and-alists-lst (pairlis$ formals (fargs term)) (fargs term) mask machine)))
corollaryfunction
(defun corollary (rune wrld) (let* ((name (base-symbol rune)) (classes (getpropc name 'classes nil wrld))) (cond ((null classes) (cond ((or (eq (car rune) :definition) (eq (car rune) :executable-counterpart)) (let ((body (body name t wrld))) (cond ((null body) nil) ((eq (car rune) :definition) (let ((lemma (find-runed-lemma rune (getpropc name 'lemmas nil wrld)))) (and lemma (let ((concl (mcons-term* (access rewrite-rule lemma :equiv) (access rewrite-rule lemma :lhs) (access rewrite-rule lemma :rhs)))) (if (access rewrite-rule lemma :hyps) (mcons-term* 'implies (conjoin (access rewrite-rule lemma :hyps)) concl) concl))))) (t (mcons-term* 'equal (cons-term name (formals name wrld)) body))))) ((eq (car rune) :type-prescription) (let ((tp (find-runed-type-prescription rune (getpropc name 'type-prescriptions nil wrld)))) (cond ((null tp) *t*) (t (access type-prescription tp :corollary))))) ((and (eq (car rune) :induction) (equal (cddr rune) nil)) nil) (t (er hard 'corollary "It was thought to be impossible for a rune to have no ~ 'classes property except in the case of the four or five ~ definition runes described in the Essay on the ~ Assignment of Runes and Numes by DEFUNS. But ~x0 is a ~ counterexample." rune)))) (t (let ((term (cadr (assoc-keyword :corollary (cdr (truncated-class rune (getpropc name 'runic-mapping-pairs '(:error "See COROLLARY.") wrld) classes)))))) (or term (getpropc name 'theorem nil wrld)))))))
formulafunction
(defun formula (name normalp wrld) (cond ((consp name) (corollary name wrld)) (t (let ((body (body name normalp wrld))) (cond ((and body normalp) (corollary `(:definition ,NAME) wrld)) (body (mcons-term* 'equal (cons-term name (formals name wrld)) body)) (t (or (getpropc name 'theorem nil wrld) (getpropc name 'defchoose-axiom nil wrld))))))))
pf-induction-schemefunction
(defun pf-induction-scheme (x wrld state) (declare (xargs :guard (or (symbolp x) (runep x wrld)))) (flet ((induction-pretty-clause-set (name flg wrld) (prettyify-clause-set (induction-formula (list (list (cons :p (formals name wrld)))) (cons name (formals name wrld)) :all nil (tests-and-alists-lst-from-fn name wrld)) flg wrld))) (let* ((rune (if (symbolp x) (let ((r (list :induction x))) (and (runep r wrld) r)) (and (eq (car x) :induction) (null (cddr x)) x))) (name (and rune (base-symbol rune)))) (cond ((null rune) (mv nil nil)) ((function-symbolp name wrld) (mv (induction-pretty-clause-set name (let*-abstractionp state) wrld) nil)) (t (let* ((class (truncated-class rune (getpropc name 'runic-mapping-pairs '(:error "See COROLLARY.") wrld) (getpropc name 'classes nil wrld))) (scheme (and (consp class) (eq (car class) :induction) (cadr (member :scheme class)))) (fn (and scheme (ffn-symb scheme)))) (cond ((runep `(:induction ,FN) wrld) (mv (induction-pretty-clause-set fn (let*-abstractionp state) wrld) fn)) (t (mv nil nil)))))))))
pf-fnfunction
(defun pf-fn (name state) (io? temporary nil (mv erp val state) (name) (let ((wrld (w state))) (cond ((or (symbolp name) (runep name wrld)) (let* ((name (if (symbolp name) (deref-macro-name name (macro-aliases (w state))) name)) (term (if (and (not (symbolp name)) (eq (car name) :induction)) nil (formula name t wrld)))) (mv-let (col state) (cond ((or (null term) (equal term *t*)) (fmt1 (if (null term) "There is no formula associated with ~x0.~@1" "The formula associated with ~x0 is simply T.~@1") (list (cons #\0 name) (cons #\1 (mv-let (s fn) (pf-induction-scheme name wrld state) (if s (msg "~|However, there is the ~ following associated induction ~ scheme~@0.~|~x1~|" (if fn (msg " based on the ~ function symbol, ~x0" fn) "") s) "~|")))) 0 (standard-co state) state nil)) (term (fmt1 "~p0~|" (list (cons #\0 (untranslate term t wrld))) 0 (standard-co state) state (term-evisc-tuple nil state))) (t (fmt1 "There is no formula associated with ~x0.~|" (list (cons #\0 name)) 0 (standard-co state) state nil))) (declare (ignore col)) (value :invisible)))) (t (er soft 'pf "~x0 is neither a symbol nor a rune in the current world." name))))))
merge-symbol<function
(defun merge-symbol< (l1 l2 acc) (declare (xargs :guard (and (symbol-listp l1) (symbol-listp l2) (true-listp acc)))) (cond ((endp l1) (revappend acc l2)) ((endp l2) (revappend acc l1)) ((symbol< (car l1) (car l2)) (merge-symbol< (cdr l1) l2 (cons (car l1) acc))) (t (merge-symbol< l1 (cdr l2) (cons (car l2) acc)))))
merge-sort-symbol<function
(defun merge-sort-symbol< (l) (declare (xargs :guard (symbol-listp l))) (cond ((endp (cdr l)) l) (t (merge-symbol< (merge-sort-symbol< (evens l)) (merge-sort-symbol< (odds l)) nil))))
*non-instantiable-primitives*constant
(defconst *non-instantiable-primitives* '(not implies o< member-equal fix booleanp character-listp force case-split make-character-list eql endp atom bad-atom return-last mv-list cons-with-hint the-check member-symbol-name symbol-package-name intern-in-package-of-symbol pkg-imports symbol-listp no-duplicatesp-equal no-duplicatesp-eq-exec no-duplicatesp-eq-exec$guard-check))
instantiablepfunction
(defun instantiablep (fn wrld) (and (symbolp fn) (not (member-eq fn *non-instantiable-primitives*)) (function-symbolp fn wrld) (or (getpropc fn 'constrainedp nil wrld) (and (body fn nil wrld) t))))
constraint-lst-etc-pfunction
(defun constraint-lst-etc-p (x) (declare (xargs :guard t)) (and (consp x) (or (symbolp (car x)) (pseudo-term-listp (car x))) (true-listp (cdr x))))
pre-v8-7-getpropc-constraint-lst-nilmacro
(defmacro pre-v8-7-getpropc-constraint-lst-nil (fn wrld) `(car (getpropc ,FN 'constraint-lst-etc nil ,WRLD)))
make-originfunction
(defun make-origin (tag x) (declare (xargs :guard t)) (list tag x))
constraint-lst-etcmacro
(defmacro constraint-lst-etc (fn default wrld) `(let ((prop (getpropc ,FN 'constraint-lst-etc ,DEFAULT ,WRLD))) (if (consp prop) prop '(t))))
constraint-infofunction
(defun constraint-info (fn wrld) (declare (xargs :guard (and (symbolp fn) (plist-worldp wrld)))) (let ((prop (constraint-lst-etc fn '(t) wrld))) (cond ((eq (car prop) t) (let ((body (getpropc fn 'unnormalized-body nil wrld))) (cond (body (mv nil (fcons-term* 'equal (fcons-term fn (formals fn wrld)) body) (make-origin 'defun fn))) (t (mv nil (or (getpropc fn 'defchoose-axiom nil wrld) *t*) (make-origin 'defchoose fn)))))) ((and (symbolp (car prop)) (car prop)) (let ((pair (constraint-lst-etc (car prop) '(:error "See constraint-info: ~ expected to find a ~ 'constraint-lst-etc property ~ where we did not.") wrld))) (mv (car prop) (car pair) (cdr pair)))) (t (mv fn (car prop) (cdr prop))))))
pre-v8-7-constraint-infomacro
(defmacro pre-v8-7-constraint-info (fn wrld) `(mv-let (x y z) (constraint-info ,FN ,WRLD) (declare (ignore z)) (mv x y)))
other
(defun@par chk-equal-arities (fn1 n1 fn2 n2 ctx state) (cond ((not (equal n1 n2)) (er@par soft ctx "It is illegal to replace ~x0 by ~x1 because the former ~#2~[takes no ~ arguments~/takes one argument~/takes ~n3 arguments~] while the latter ~ ~#4~[takes none~/takes one~/takes ~n5~]. See the :functional-instance ~ discussion in :DOC :lemma-instance." fn1 fn2 (cond ((int= n1 0) 0) ((int= n1 1) 1) (t 2)) n1 (cond ((int= n2 0) 0) ((int= n2 1) 1) (t 2)) n2)) (t (value@par nil))))
extend-sorted-symbol-alistfunction
(defun extend-sorted-symbol-alist (pair alist) (cond ((endp alist) (list pair)) ((symbol< (car pair) (caar alist)) (cons pair alist)) (t (cons (car alist) (extend-sorted-symbol-alist pair (cdr alist))))))
other
(defun@par translate-functional-substitution (substn ctx wrld state) (cond ((null substn) (value@par nil)) ((not (and (true-listp (car substn)) (= (length (car substn)) 2))) (er@par soft ctx "The object ~x0 is not of the form (fi gi) as described in the ~ :functional-instance discussion of :DOC lemma-instance." (car substn))) (t (let ((fn1 (caar substn)) (fn2 (cadar substn)) (str "The object ~x0 is not of the form (fi gi) as described in ~ the :functional-instance discussion of :DOC lemma-instance. ~ ~ ~x1 is neither a function symbol nor a pseudo-lambda ~ expression.")) (cond ((not (and (symbolp fn1) (function-symbolp fn1 wrld))) (er@par soft ctx "Each domain element in a functional substitution must be a ~ function symbol, but ~x0 is not. See the :functional-instance ~ discussion of :DOC lemma-instance." fn1)) ((not (eq (instantiablep fn1 wrld) t)) (er@par soft ctx "The function symbol ~x0 cannot be instantiated~@1. See the ~ :functional-instance discussion about `instantiable' in :DOC ~ lemma-instance." fn1 (if (eq (instantiablep fn1 wrld) nil) "" (assert$ (eq (instantiablep fn1 wrld) *unknown-constraints*) (msg " because it has unknown-constraints; see :DOC ~ partial-encapsulate"))))) (t (er-let*@par ((x (cond ((symbolp fn2) (let ((fn2 (deref-macro-name fn2 (macro-aliases wrld)))) (cond ((function-symbolp fn2 wrld) (er-progn@par (chk-equal-arities@par fn1 (arity fn1 wrld) fn2 (arity fn2 wrld) ctx state) (value@par (cons fn1 fn2)))) (t (er@par soft ctx str (car substn) fn2))))) ((and (true-listp fn2) (= (length fn2) 3) (eq (car fn2) 'lambda)) (er-let*@par ((body (translate@par (caddr fn2) t t t ctx wrld state))) (er-progn@par (chk-arglist@par (cadr fn2) t ctx wrld state) (chk-equal-arities@par fn1 (arity fn1 wrld) fn2 (length (cadr fn2)) ctx state) (value@par (cons fn1 (make-lambda (cadr fn2) body)))))) (t (er@par soft ctx str (car substn) fn2)))) (y (translate-functional-substitution@par (cdr substn) ctx wrld state))) (cond ((assoc-eq fn1 y) (er@par soft ctx "It is illegal to bind ~x0 twice in a functional ~ substitution. See the :functional-instance discussion ~ of :DOC lemma-instance." fn1)) (t (value@par (extend-sorted-symbol-alist x y)))))))))))
sublis-fn-recmutual-recursion
(mutual-recursion (defun sublis-fn-rec (alist term bound-vars allow-freevars-p) (cond ((variablep term) (mv nil term)) ((fquotep term) (mv nil term)) ((flambda-applicationp term) (let ((old-lambda-formals (lambda-formals (ffn-symb term)))) (mv-let (erp new-lambda-body) (sublis-fn-rec alist (lambda-body (ffn-symb term)) (append old-lambda-formals bound-vars) allow-freevars-p) (cond (erp (mv erp new-lambda-body)) (t (mv-let (erp args) (sublis-fn-rec-lst alist (fargs term) bound-vars allow-freevars-p) (cond (erp (mv erp args)) (t (let* ((body-vars (all-vars new-lambda-body)) (extra-body-vars (set-difference-eq body-vars old-lambda-formals))) (mv nil (fcons-term (make-lambda (append old-lambda-formals extra-body-vars) new-lambda-body) (append args extra-body-vars)))))))))))) (t (let ((temp (assoc-eq (ffn-symb term) alist))) (cond (temp (cond ((symbolp (cdr temp)) (mv-let (erp args) (sublis-fn-rec-lst alist (fargs term) bound-vars allow-freevars-p) (cond (erp (mv erp args)) (t (mv nil (cons-term (cdr temp) args)))))) (t (let ((bad (if allow-freevars-p (intersection-eq (set-difference-eq (all-vars (lambda-body (cdr temp))) (lambda-formals (cdr temp))) bound-vars) (set-difference-eq (all-vars (lambda-body (cdr temp))) (lambda-formals (cdr temp)))))) (cond (bad (mv bad term)) (t (mv-let (erp args) (sublis-fn-rec-lst alist (fargs term) bound-vars allow-freevars-p) (cond (erp (mv erp args)) (t (mv nil (sublis-var (pairlis$ (lambda-formals (cdr temp)) args) (lambda-body (cdr temp))))))))))))) (t (mv-let (erp args) (sublis-fn-rec-lst alist (fargs term) bound-vars allow-freevars-p) (cond (erp (mv erp args)) (t (mv nil (cons-term (ffn-symb term) args))))))))))) (defun sublis-fn-rec-lst (alist terms bound-vars allow-freevars-p) (cond ((null terms) (mv nil nil)) (t (mv-let (erp term) (sublis-fn-rec alist (car terms) bound-vars allow-freevars-p) (cond (erp (mv erp term)) (t (mv-let (erp tail) (sublis-fn-rec-lst alist (cdr terms) bound-vars allow-freevars-p) (cond (erp (mv erp tail)) (t (mv nil (cons term tail))))))))))))
sublis-fnfunction
(defun sublis-fn (alist term bound-vars) (sublis-fn-rec alist term bound-vars t))
sublis-fn-simplefunction
(defun sublis-fn-simple (alist term) (mv-let (vars result) (sublis-fn-rec alist term nil t) (assert$ (null vars) result)))
sublis-fn-lst-simplefunction
(defun sublis-fn-lst-simple (alist termlist) (mv-let (vars result) (sublis-fn-rec-lst alist termlist nil t) (assert$ (null vars) result)))
instantiable-ffn-symbsmutual-recursion
(mutual-recursion (defun instantiable-ffn-symbs (term wrld ans ignore-fns) (cond ((variablep term) ans) ((fquotep term) ans) ((flambda-applicationp term) (let ((ans (instantiable-ffn-symbs (lambda-body (ffn-symb term)) wrld ans ignore-fns))) (instantiable-ffn-symbs-lst (fargs term) wrld ans ignore-fns))) (t (instantiable-ffn-symbs-lst (fargs term) wrld (cond ((or (not (instantiablep (ffn-symb term) wrld)) (member-eq (ffn-symb term) ignore-fns)) ans) (t (add-to-set-eq (ffn-symb term) ans))) ignore-fns)))) (defun instantiable-ffn-symbs-lst (lst wrld ans ignore-fns) (cond ((null lst) ans) (t (instantiable-ffn-symbs-lst (cdr lst) wrld (instantiable-ffn-symbs (car lst) wrld ans ignore-fns) ignore-fns)))))
unknown-constraints-pfunction
(defun unknown-constraints-p (lst) (declare (xargs :guard t)) (and (consp lst) (eq (car lst) *unknown-constraints*)))
unknown-constraints-supportersfunction
(defun unknown-constraints-supporters (lst) (declare (xargs :guard (unknown-constraints-p lst))) (cdr lst))
collect-instantiablep1function
(defun collect-instantiablep1 (fns wrld ignore-fns) (cond ((endp fns) nil) ((and (not (member-eq (car fns) ignore-fns)) (instantiablep (car fns) wrld)) (cons (car fns) (collect-instantiablep1 (cdr fns) wrld ignore-fns))) (t (collect-instantiablep1 (cdr fns) wrld ignore-fns))))
all-instantiablepfunction
(defun all-instantiablep (fns wrld) (cond ((endp fns) t) ((instantiablep (car fns) wrld) (all-instantiablep (cdr fns) wrld)) (t nil)))
collect-instantiablepfunction
(defun collect-instantiablep (fns wrld ignore-fns) (cond ((and (not (intersectp-eq fns ignore-fns)) (all-instantiablep fns wrld)) fns) (t (collect-instantiablep1 fns wrld ignore-fns))))
immediate-instantiable-ancestorsfunction
(defun immediate-instantiable-ancestors (fn wrld ignore-fns) (mv-let (name x origins) (constraint-info fn wrld) (declare (ignore origins)) (cond ((unknown-constraints-p x) (let ((supporters (unknown-constraints-supporters x))) (collect-instantiablep supporters wrld ignore-fns))) (name (instantiable-ffn-symbs-lst x wrld nil ignore-fns)) (t (instantiable-ffn-symbs x wrld nil ignore-fns)))))
instantiable-ancestorsfunction
(defun instantiable-ancestors (fns wrld ans) (cond ((null fns) ans) ((member-eq (car fns) ans) (instantiable-ancestors (cdr fns) wrld ans)) (t (let* ((ans1 (cons (car fns) ans)) (imm (immediate-instantiable-ancestors (car fns) wrld ans1)) (ans2 (instantiable-ancestors imm wrld ans1))) (instantiable-ancestors (cdr fns) wrld ans2)))))
hitpmutual-recursion
(mutual-recursion (defun hitp (term alist) (cond ((variablep term) nil) ((fquotep term) nil) ((flambda-applicationp term) (or (hitp (lambda-body (ffn-symb term)) alist) (hitp-lst (fargs term) alist))) ((assoc-eq (ffn-symb term) alist) t) (t (hitp-lst (fargs term) alist)))) (defun hitp-lst (terms alist) (cond ((null terms) nil) (t (or (hitp (car terms) alist) (hitp-lst (cdr terms) alist))))))
event-responsible-for-proved-constraintfunction
(defun event-responsible-for-proved-constraint (name alist proved-fnl-insts-alist) (cond ((endp proved-fnl-insts-alist) nil) ((and (eq name (access proved-functional-instances-alist-entry (car proved-fnl-insts-alist) :constraint-event-name)) (equal alist (access proved-functional-instances-alist-entry (car proved-fnl-insts-alist) :restricted-alist))) (or (access proved-functional-instances-alist-entry (car proved-fnl-insts-alist) :behalf-of-event-name) (er hard 'event-responsible-for-proved-constraint "Implementation error: We expected to find a non-nil ~ :behalf-of-event-name field in the following entry of the world ~ global 'proved-functional-instances-alist, but did not:~%~x0." (car proved-fnl-insts-alist)))) (t (event-responsible-for-proved-constraint name alist (cdr proved-fnl-insts-alist)))))
getprop-x-lstfunction
(defun getprop-x-lst (symbols prop wrld) (cond ((null symbols) nil) (t (cons (getpropc (car symbols) prop nil wrld) (getprop-x-lst (cdr symbols) prop wrld)))))
filter-hitps-with-originsfunction
(defun filter-hitps-with-origins (lst origins alist new-lst new-origins) (cond ((endp lst) (mv new-lst new-origins)) ((hitp (car lst) alist) (filter-hitps-with-origins (cdr lst) (cdr origins) alist (cons (car lst) new-lst) (cons (car origins) new-origins))) (t (filter-hitps-with-origins (cdr lst) (cdr origins) alist new-lst new-origins))))
relevant-constraints1function
(defun relevant-constraints1 (names alist proved-fnl-insts-alist constraints event-names new-entries origins seen wrld) (cond ((null names) (mv constraints event-names new-entries origins)) ((member-eq (car names) seen) (relevant-constraints1 (cdr names) alist proved-fnl-insts-alist constraints event-names new-entries origins seen wrld)) (t (mv-let (name x xorigins) (constraint-info (car names) wrld) (cond ((unknown-constraints-p x) (let ((supporters (unknown-constraints-supporters x))) (cond ((first-assoc-eq supporters alist) (mv x name nil nil)) (t (relevant-constraints1 (cdr names) alist proved-fnl-insts-alist constraints event-names new-entries origins seen wrld))))) ((and name (not (eq name (car names))) (member-eq name seen)) (relevant-constraints1 (cdr names) alist proved-fnl-insts-alist constraints event-names new-entries origins (cons (car names) seen) wrld)) (t (mv-let (new-x new-xorigins) (cond (name (filter-hitps-with-origins x xorigins alist nil nil)) ((hitp x alist) (mv x xorigins)) (t (mv nil nil))) (let* ((instantiable-fns (and new-x (cond (name (instantiable-ffn-symbs-lst new-x wrld nil nil)) (t (instantiable-ffn-symbs new-x wrld nil nil)))))) (let* ((constraint-alist (and new-x (restrict-alist instantiable-fns alist))) (ev (and new-x (event-responsible-for-proved-constraint (or name (car names)) constraint-alist proved-fnl-insts-alist))) (seen (cons (car names) (if (and name (not (eq name (car names)))) (cons name seen) seen)))) (cond ((null new-x) (relevant-constraints1 (cdr names) alist proved-fnl-insts-alist constraints event-names new-entries origins seen wrld)) (ev (relevant-constraints1 (cdr names) alist proved-fnl-insts-alist constraints (add-to-set ev event-names) new-entries origins seen wrld)) (t (relevant-constraints1 (cdr names) alist proved-fnl-insts-alist (if name (append new-x constraints) (cons new-x constraints)) event-names (cons (make proved-functional-instances-alist-entry :constraint-event-name (or name (car names)) :restricted-alist constraint-alist :behalf-of-event-name nil) new-entries) (if origins (if name (append (pairlis-x2 new-xorigins (list (alist-to-doublets constraint-alist))) (if (eq origins t) nil origins)) (cons (list new-xorigins (alist-to-doublets constraint-alist)) (if (eq origins t) nil origins))) nil) seen wrld))))))))))))
relevant-constraints1-axiomsfunction
(defun relevant-constraints1-axioms (names alist proved-fnl-insts-alist constraints event-names new-entries origins wrld) (cond ((null names) (mv constraints event-names new-entries (if (eq origins t) nil origins))) (t (let* ((constraint (getpropc (car names) 'theorem '(:error "See relevant-constraints1-axioms.") wrld)) (instantiable-fns (instantiable-ffn-symbs constraint wrld nil nil))) (cond ((hitp constraint alist) (let* ((constraint-alist (restrict-alist instantiable-fns alist)) (ev (event-responsible-for-proved-constraint (car names) constraint-alist proved-fnl-insts-alist))) (cond (ev (relevant-constraints1-axioms (cdr names) alist proved-fnl-insts-alist constraints (add-to-set ev event-names) new-entries origins wrld)) (t (relevant-constraints1-axioms (cdr names) alist proved-fnl-insts-alist (cons constraint constraints) event-names (cons (make proved-functional-instances-alist-entry :constraint-event-name (car names) :restricted-alist constraint-alist :behalf-of-event-name nil) new-entries) (if origins (cons `(defaxiom ,(CAR NAMES)) (if (eq origins t) nil origins)) nil) wrld))))) (t (relevant-constraints1-axioms (cdr names) alist proved-fnl-insts-alist constraints event-names new-entries origins wrld)))))))
relevant-constraintsfunction
(defun relevant-constraints (thm alist proved-fnl-insts-alist origins-flg wrld) (let ((nonconstructive-axiom-names (global-val 'nonconstructive-axiom-names wrld))) (mv-let (constraints event-names new-entries origins) (relevant-constraints1-axioms nonconstructive-axiom-names alist proved-fnl-insts-alist nil nil nil origins-flg wrld) (assert$ (not (unknown-constraints-p constraints)) (let* ((instantiable-fns (instantiable-ffn-symbs-lst (cons thm (getprop-x-lst nonconstructive-axiom-names 'theorem wrld)) wrld nil nil)) (ancestors (instantiable-ancestors instantiable-fns wrld nil))) (relevant-constraints1 ancestors alist proved-fnl-insts-alist constraints event-names new-entries (if (and (eq origins-flg t) (null origins)) t origins) nil wrld))))))
bound-varsmutual-recursion
(mutual-recursion (defun bound-vars (term ans) (cond ((variablep term) ans) ((fquotep term) ans) ((flambda-applicationp term) (bound-vars (lambda-body (ffn-symb term)) (bound-vars-lst (fargs term) (union-eq (lambda-formals (ffn-symb term)) ans)))) (t (bound-vars-lst (fargs term) ans)))) (defun bound-vars-lst (terms ans) (cond ((null terms) ans) (t (bound-vars-lst (cdr terms) (bound-vars (car terms) ans))))))
translate-lmi/instance-fix-alistfunction
(defun translate-lmi/instance-fix-alist (un-mentioned-vars formula-vars alist) (cond ((endp un-mentioned-vars) alist) (t (let ((alist (translate-lmi/instance-fix-alist (cdr un-mentioned-vars) formula-vars alist))) (cond ((eq alist :failed) :failed) (t (let* ((bad-var (car un-mentioned-vars)) (name (symbol-name bad-var)) (tail (member-symbol-name name formula-vars))) (cond (tail (cond ((or (assoc-eq (car tail) alist) (member-symbol-name name (cdr tail))) :failed) (t (let ((val (cdr (assoc-eq bad-var alist)))) (assert$ val (acons (car tail) val (remove1-assoc-eq bad-var alist))))))) (t :failed)))))))))
other
(defun@par translate-lmi/instance (formula constraints event-names new-entries origins extra-bindings-ok substn ctx wrld state) (er-let*@par ((alist (translate-substitution@par substn ctx wrld state))) (let* ((vars (all-vars formula)) (un-mentioned-vars (and (not extra-bindings-ok) (set-difference-eq (strip-cars alist) vars))) (alist (if un-mentioned-vars (translate-lmi/instance-fix-alist un-mentioned-vars vars alist) alist))) (cond ((eq alist :failed) (er@par soft ctx "The formula you wish to instantiate, ~p3, mentions ~#0~[no ~ variables~/only the variable ~&1~/the variables ~&1~]. Thus, there ~ is no reason to include ~&2 in the domain of your substitution. We ~ point this out only because it frequently indicates that a mistake ~ has been made. See the discussion of :instance in :DOC ~ lemma-instance, which explains how to use a keyword, ~ :extra-bindings-ok, to avoid this error (for example, in case your ~ substitution was automatically generated by a macro)." (zero-one-or-more vars) (merge-sort-symbol< vars) (merge-sort-symbol< un-mentioned-vars) (untranslate formula t wrld))) (t (value@par (list (sublis-var alist formula) constraints event-names new-entries origins)))))))
fn-subst-free-varsfunction
(defun fn-subst-free-vars (alist) (cond ((endp alist) nil) ((symbolp (cdar alist)) (fn-subst-free-vars (cdr alist))) (t (let* ((fn (cdar alist)) (formals (lambda-formals fn)) (body (lambda-body fn)) (free-vars (set-difference-eq (all-vars body) formals))) (union-eq free-vars (fn-subst-free-vars (cdr alist)))))))
fn-subst-renaming-alistfunction
(defun fn-subst-renaming-alist (vars avoid-vars) (cond ((endp vars) nil) (t (let* ((var (car vars)) (new-var (genvar (car vars) (concatenate 'string (symbol-name (car vars)) "-RENAMED") 0 avoid-vars))) (acons var new-var (fn-subst-renaming-alist (cdr vars) (cons new-var avoid-vars)))))))
remove-capture-in-constraint-lstfunction
(defun remove-capture-in-constraint-lst (alist new-constraints) (let* ((new-constraints-vars (all-vars1-lst new-constraints nil)) (fn-subst-free-vars (fn-subst-free-vars alist)) (bad-vars (intersection-eq new-constraints-vars fn-subst-free-vars))) (cond (bad-vars (let* ((bad-vars-alist (fn-subst-renaming-alist bad-vars fn-subst-free-vars)) (new-constraints-renamed (sublis-var-lst bad-vars-alist new-constraints))) (mv bad-vars-alist new-constraints-renamed))) (t (mv nil new-constraints)))))
other
(defun@par translate-lmi/functional-instance (formula constraints event-names new-entries origins substn proved-fnl-insts-alist ctx wrld state) (let ((constraint-tracking-flg (constraint-tracking wrld))) (er-let*@par ((alist (translate-functional-substitution@par substn ctx wrld state))) (mv-let (new-constraints new-event-names new-new-entries new-origins) (relevant-constraints formula alist proved-fnl-insts-alist constraint-tracking-flg wrld) (cond ((unknown-constraints-p new-constraints) (er@par soft ctx "Functional instantiation is disallowed in this context, because the ~ function ~x0 has unknown-constraints. See :DOC partial-encapsulate." new-event-names)) (t (mv-let (bad-vars-alist new-constraints) (remove-capture-in-constraint-lst alist new-constraints) (pprogn@par (cond (bad-vars-alist (warning$@par ctx "Capture" "In order to avoid variable capture, ~ functional instantiation is generating a ~ version of the constraints in which free ~ variables are renamed by the following ~ alist:~|~x0" bad-vars-alist)) (t (state-mac@par))) (let ((allow-freevars-p t)) (mv-let (erp0 formula0) (sublis-fn-rec alist formula nil allow-freevars-p) (mv-let (erp new-constraints0) (cond (erp0 (mv erp0 formula0)) (t (sublis-fn-rec-lst alist new-constraints nil allow-freevars-p))) (cond (erp (er@par soft ctx (if allow-freevars-p "Your functional substitution contains one or more ~ free occurrences of the variable~#0~[~/s~] ~&0 in ~ its range. ~ Alas, ~#1~[this variable occurrence ~ is~/these variables occurrences are~] bound in a ~ LET or MV-LET expression of ~#2~[the formula you ~ wish to functionally instantiate, ~p3.~|~/the ~ constraints that must be relieved. ~]You must ~ therefore change your functional substitution so ~ that it avoids such ``capture.'' It will suffice ~ for your functional substitution to stay clear of ~ all the variables bound by a LET or MV-LET ~ expression that are used in the target formula or ~ in the corresponding constraints. Thus it will ~ suffice for your substitution not to contain free ~ occurrences of ~v4 in its range, by using fresh ~ variables instead. Once you have fixed this ~ problem, you can :use an :instance of your ~ :functional-instance to bind the fresh variables ~ to ~&4." "Your functional substitution contains one or more ~ free occurrences of the variable~#0~[~/s~] ~&0 in ~ its range. Alas, the formula you wish to ~ functionally instantiate is not a classical ~ formula, ~p3. Free variables in lambda ~ expressions are only allowed when the formula to ~ be instantiated is classical, since these ~ variables may admit non-standard values, for which ~ the theorem may be false.") (merge-sort-symbol< erp) erp (if erp0 0 1) (untranslate formula t wrld) (bound-vars-lst (cons formula new-constraints) nil))) (t (value@par (list formula0 (append constraints new-constraints0) (union-equal new-event-names event-names) (union-equal new-new-entries new-entries) (if constraint-tracking-flg (append origins (if (eq new-origins t) nil new-origins)) nil))))))))))))))))
all-calls-alistfunction
(defun all-calls-alist (names alist ans) (cond ((null alist) ans) (t (all-calls-alist names (cdr alist) (all-calls names (cdar alist) nil ans)))))
ffnnamesp-eqmutual-recursion
(mutual-recursion (defun ffnnamesp-eq (fns term) (cond ((variablep term) nil) ((fquotep term) nil) ((flambda-applicationp term) (or (ffnnamesp-eq fns (lambda-body (ffn-symb term))) (ffnnamesp-eq-lst fns (fargs term)))) ((member-eq (ffn-symb term) fns) t) (t (ffnnamesp-eq-lst fns (fargs term))))) (defun ffnnamesp-eq-lst (fns l) (if (null l) nil (or (ffnnamesp-eq fns (car l)) (ffnnamesp-eq-lst fns (cdr l))))))
maybe-add-extra-info-litfunction
(defun maybe-add-extra-info-lit (debug-info term clause wrld) (cond (debug-info (cons (fcons-term* 'not (fcons-term* *extra-info-fn* (kwote debug-info) (kwote (untranslate term nil wrld)))) clause)) (t clause)))
measure-clause-for-branchfunction
(defun measure-clause-for-branch (name tc measure-alist rel debug-info wrld) (let* ((f0 name) (m0 (cdr (assoc-eq f0 measure-alist))) (tests (access tests-and-call tc :tests)) (call (access tests-and-call tc :call)) (f1 (ffn-symb call)) (m1-prime (subcor-var (formals f1 wrld) (fargs call) (cdr (assoc-eq f1 measure-alist)))) (concl (mcons-term* rel m1-prime m0)) (clause (add-literal concl (dumb-negate-lit-lst tests) t))) (maybe-add-extra-info-lit debug-info call clause wrld)))
split-initial-extra-info-litsfunction
(defun split-initial-extra-info-lits (cl hyps-rev) (cond ((endp cl) (mv hyps-rev cl)) ((extra-info-lit-p (car cl)) (split-initial-extra-info-lits (cdr cl) (cons (car cl) hyps-rev))) (t (mv hyps-rev cl))))
conjoin-clause-to-clause-set-extra-info1function
(defun conjoin-clause-to-clause-set-extra-info1 (tags-rev cl0 cl cl-set cl-set-all) (cond ((endp cl-set) (cons cl cl-set-all)) (t (mv-let (initial-extra-info-lits-rev cl1) (split-initial-extra-info-lits (car cl-set) nil) (cond ((equal cl0 cl1) (cond ((not tags-rev) cl-set-all) (t (cond ((subsetp-equal tags-rev initial-extra-info-lits-rev) cl-set-all) (t (append (take (- (length cl-set-all) (length cl-set)) cl-set-all) (cons (revappend initial-extra-info-lits-rev (mv-let (changedp new-tags-rev) (set-difference-equal-changedp tags-rev initial-extra-info-lits-rev) (cond (changedp (revappend new-tags-rev cl0)) (t cl)))) (cdr cl-set)))))))) (t (conjoin-clause-to-clause-set-extra-info1 tags-rev cl0 cl (cdr cl-set) cl-set-all)))))))
conjoin-clause-to-clause-set-extra-infofunction
(defun conjoin-clause-to-clause-set-extra-info (cl cl-set) (cond ((member-equal *t* cl) cl-set) (t (mv-let (tags-rev cl0) (split-initial-extra-info-lits cl nil) (conjoin-clause-to-clause-set-extra-info1 tags-rev cl0 cl cl-set cl-set)))))
measure-clauses-for-fn1function
(defun measure-clauses-for-fn1 (name t-machine measure-alist rel debug-info wrld) (cond ((null t-machine) nil) (t (conjoin-clause-to-clause-set-extra-info (measure-clause-for-branch name (car t-machine) measure-alist rel debug-info wrld) (measure-clauses-for-fn1 name (cdr t-machine) measure-alist rel debug-info wrld)))))
measure-clauses-for-fnfunction
(defun measure-clauses-for-fn (name t-machine measure-alist mp rel measure-debug wrld) (cond ((eq mp t) (measure-clauses-for-fn1 name t-machine measure-alist rel (and measure-debug `(:measure (:relation ,NAME))) wrld)) (t (conjoin-clause-to-clause-set-extra-info (let ((mp-call (mcons-term* mp (cdr (assoc-eq name measure-alist))))) (maybe-add-extra-info-lit (and measure-debug `(:measure (:domain ,NAME))) mp-call (add-literal mp-call nil t) wrld)) (measure-clauses-for-fn1 name t-machine measure-alist rel (and measure-debug `(:measure (:relation ,NAME))) wrld)))))
conjoin-clause-sets-extra-infofunction
(defun conjoin-clause-sets-extra-info (cl-set1 cl-set2) (cond ((null cl-set1) cl-set2) (t (conjoin-clause-to-clause-set-extra-info (car cl-set1) (conjoin-clause-sets-extra-info (cdr cl-set1) cl-set2)))))
conjoin-clause-sets+function
(defun conjoin-clause-sets+ (debug-info cl-set1 cl-set2) (cond (debug-info (conjoin-clause-sets-extra-info cl-set1 cl-set2)) (t (conjoin-clause-sets cl-set1 cl-set2))))
measure-clauses-for-cliquefunction
(defun measure-clauses-for-clique (names t-machines measure-alist mp rel measure-debug wrld) (cond ((null names) nil) (t (conjoin-clause-sets+ measure-debug (measure-clauses-for-fn (car names) (car t-machines) measure-alist mp rel measure-debug wrld) (measure-clauses-for-clique (cdr names) (cdr t-machines) measure-alist mp rel measure-debug wrld)))))
termination-theorem-clausesfunction
(defun termination-theorem-clauses (loop$-recursion-checkedp loop$-recursion names arglists bodies measure-alist mp rel ruler-extenders-lst wrld) (let ((t-machines (termination-machines loop$-recursion-checkedp loop$-recursion names arglists bodies ruler-extenders-lst))) (measure-clauses-for-clique names t-machines measure-alist mp rel nil wrld)))
measure-alist?function
(defun measure-alist? (names wrld) (cond ((endp names) nil) (t (let* ((fn (car names)) (rest (measure-alist? (cdr names) wrld)) (bad-names (and (eq (car rest) :failed) (cdr rest))) (just (getpropc fn 'justification nil wrld)) (m (assert$ just (access justification just :measure))) (bad (eq (ffn-symb m) :?))) (cond (bad-names (if bad (cons :failed (cons fn bad-names)) rest)) (bad (cons :failed (cons fn nil))) (t (acons (car names) m rest)))))))
ruler-extenders-lstfunction
(defun ruler-extenders-lst (names wrld) (cond ((endp names) nil) (t (cons (let ((just (getpropc (car names) 'justification nil wrld))) (assert$ just (access justification just :ruler-extenders))) (ruler-extenders-lst (cdr names) wrld)))))
get-unnormalized-bodiesfunction
(defun get-unnormalized-bodies (names wrld) (cond ((endp names) nil) (t (cons (getpropc (car names) 'unnormalized-body nil wrld) (get-unnormalized-bodies (cdr names) wrld)))))
termination-theoremfunction
(defun termination-theorem (fn wrld) (declare (xargs :guard (and (plist-worldp wrld) (symbolp fn) (function-symbolp fn wrld) (logicp fn wrld)))) (let* ((names (getpropc fn 'recursivep nil wrld)) (just (and names (getpropc fn 'justification nil wrld)))) (cond ((null names) (cons :failed (msg "The function ~x0 is not recursive" fn))) ((assert$ just (access justification just :subversive-p)) (cons :failed (msg "Note that ~x0 is ``subversive.'' See :DOC ~ subversive-recursions. Thus, the termination theorem ~ proved when this function was admitted is considered local ~ to an enclosing non-trivial encapsulate form" fn))) (t (let* ((mp (assert$ just (access justification just :mp))) (rel (access justification just :rel)) (measure-alist (measure-alist? names wrld))) (cond ((eq (car measure-alist) :failed) (cons :failed (let ((bad-names (cdr measure-alist))) (assert$ bad-names (cond ((consp (cdr bad-names)) (msg "The measures specified for ~&0 (mutually recursive ~ with ~x1) are "calls" of :?, rather than true ~ measures" bad-names fn)) (t (msg "The measure specified for ~&0~@1 is a "call" of ~ :?, rather than a true measure" bad-names (cond ((eq (car bad-names) fn) "") (t (msg " (which is mutually recursive with ~x0)" fn)))))))))) (t (let ((clauses (termination-theorem-clauses t (if (cdr names) nil (getpropc (car names) 'loop$-recursion nil wrld)) names (if (cdr names) nil (list (formals (car names) wrld))) (get-unnormalized-bodies names wrld) measure-alist mp rel (ruler-extenders-lst names wrld) wrld))) (termify-clause-set clauses)))))))))
eval-ground-subexpressions1-lst-lstfunction
(defun eval-ground-subexpressions1-lst-lst (lst-lst ens wrld safe-mode gc-off ttree hands-off-fns memo) (cond ((null lst-lst) (mv nil nil ttree memo)) (t (mv-let (flg1 x ttree memo) (eval-ground-subexpressions1-lst (car lst-lst) ens wrld safe-mode gc-off ttree hands-off-fns memo) (mv-let (flg2 y ttree memo) (eval-ground-subexpressions1-lst-lst (cdr lst-lst) ens wrld safe-mode gc-off ttree hands-off-fns memo) (mv (or flg1 flg2) (if (or flg1 flg2) (cons x y) lst-lst) ttree memo))))))
eval-ground-subexpressions-lst-lstfunction
(defun eval-ground-subexpressions-lst-lst (lst-lst ens wrld state ttree) (mv-let (flg x ttree memo) (eval-ground-subexpressions1-lst-lst lst-lst ens wrld (f-get-global 'safe-mode state) (gc-off state) ttree nil nil) (declare (ignore memo)) (mv flg x ttree)))
sublis-var-lst-lstfunction
(defun sublis-var-lst-lst (alist clauses) (cond ((null clauses) nil) (t (cons (sublis-var-lst alist (car clauses)) (sublis-var-lst-lst alist (cdr clauses))))))
add-segments-to-clausefunction
(defun add-segments-to-clause (clause segments) (cond ((null segments) nil) (t (conjoin-clause-to-clause-set (disjoin-clauses clause (car segments)) (add-segments-to-clause clause (cdr segments))))))
simplify-clause-for-term-equal-const-1function
(defun simplify-clause-for-term-equal-const-1 (var const cl) (cond ((endp cl) (mv nil nil)) (t (mv-let (changedp rest) (simplify-clause-for-term-equal-const-1 var const (cdr cl)) (mv-let (var2 const2) (term-equated-to-constant (car cl)) (cond ((and (equal var var2) (not (equal const const2))) (mv t rest)) (changedp (mv t (cons (car cl) rest))) (t (mv nil cl))))))))
simplify-clause-for-term-equal-constfunction
(defun simplify-clause-for-term-equal-const (var const cl) (mv-let (changedp new-cl) (simplify-clause-for-term-equal-const-1 var const cl) (declare (ignore changedp)) new-cl))
add-literal-smartfunction
(defun add-literal-smart (lit cl at-end-flg) (mv-let (term const) (cond ((ffn-symb-p lit 'not) (term-equated-to-constant (fargn lit 1))) (t (mv nil nil))) (add-literal lit (cond (term (simplify-clause-for-term-equal-const term const cl)) (t cl)) at-end-flg)))
all-vars!1mutual-recursion
(mutual-recursion (defun all-vars!1 (term wrld ans) (declare (xargs :guard (and (pseudo-termp term) (symbol-listp ans)) :mode :program)) (cond ((variablep term) (add-to-set-eq term ans)) ((fquotep term) (cond ((well-formed-lambda-objectp (unquote term) wrld) (let ((obj (unquote term))) (all-vars!1 (lambda-object-body obj) wrld (all-vars!1 (lambda-object-guard obj) wrld (union-eq (lambda-object-formals (ffn-symb term)) ans))))) (t ans))) ((flambdap (ffn-symb term)) (all-vars!1-lst (fargs term) wrld (all-vars!1 (lambda-body (ffn-symb term)) wrld (union-eq (lambda-formals (ffn-symb term)) ans)))) (t (all-vars!1-lst (fargs term) wrld ans)))) (defun all-vars!1-lst (lst wrld ans) (declare (xargs :guard (and (pseudo-term-listp lst) (symbol-listp ans)) :mode :program)) (cond ((endp lst) ans) (t (all-vars!1-lst (cdr lst) wrld (all-vars!1 (car lst) wrld ans))))))
all-vars!-of-fnfunction
(defun all-vars!-of-fn (fn wrld) (cond ((symbolp fn) (all-vars!1 (guard fn nil wrld) wrld (all-vars!1 (getpropc fn 'unnormalized-body '(:error "See ALL-VARS!-OF-FN.") wrld) wrld (formals fn wrld)))) (t (all-vars!1 (lambda-object-guard fn) wrld (all-vars!1 (lambda-object-body fn) wrld (lambda-object-formals fn))))))
special-loop$-scion-callpfunction
(defun special-loop$-scion-callp (term wrld) (case-match term (('do$ & & ('quote obj1) ('quote obj2) & &) (and (well-formed-lambda-objectp obj1 wrld) (well-formed-lambda-objectp obj2 wrld) (equal (length (lambda-object-formals obj1)) 1) (equal (length (lambda-object-formals obj2)) 1))) ((loop-scion ('quote obj) . &) (let ((style (loop$-scion-style loop-scion))) (and style (and (well-formed-lambda-objectp obj wrld) (equal (length (lambda-object-formals obj)) (if (eq style :plain) 1 2)))))) (t nil)))
collect-warranted-fnsmutual-recursion
(mutual-recursion (defun collect-warranted-fns (term ilk collect-p wrld) (declare (xargs :guard (and (plist-worldp wrld) (termp term wrld)))) (cond ((variablep term) nil) ((fquotep term) (let ((val (unquote term))) (cond ((eq ilk :fn) (cond ((case-match val (('lambda . &) t) (& nil)) (let ((body (car (last val)))) (and (pseudo-termp body) (collect-warranted-fns body nil t wrld)))) ((and (symbolp val) (get-warrantp val wrld)) (list val)) (t nil))) ((eq ilk :expr) (and (pseudo-termp val) (collect-warranted-fns val nil t wrld))) (t nil)))) ((flambda-applicationp term) (union-equal (collect-warranted-fns (lambda-body (ffn-symb term)) nil collect-p wrld) (collect-warranted-fns-lst (fargs term) nil collect-p wrld))) ((member-eq (ffn-symb term) '(apply$ ev$)) (collect-warranted-fns-lst (fargs term) (access apply$-badge (executable-badge (ffn-symb term) wrld) :ilks) collect-p wrld)) (t (mv-let (badge warrantp) (get-badge-and-warrantp (ffn-symb term) wrld) (cond (warrantp (let* ((ilks0 (access apply$-badge badge :ilks)) (ilks (if (eq ilks0 t) nil ilks0)) (fns (collect-warranted-fns-lst (fargs term) ilks collect-p wrld))) (cond (collect-p (add-to-set-equal (ffn-symb term) fns)) (t fns)))) (t (collect-warranted-fns-lst (fargs term) nil collect-p wrld))))))) (defun collect-warranted-fns-lst (lst ilks collect-p wrld) (declare (xargs :guard (and (plist-worldp wrld) (term-listp lst wrld)))) (cond ((endp lst) nil) (t (union-equal (collect-warranted-fns (car lst) (car ilks) collect-p wrld) (collect-warranted-fns-lst (cdr lst) (cdr ilks) collect-p wrld))))))
collect-negated-warrants1function
(defun collect-negated-warrants1 (lst clause) (cond ((endp lst) clause) ((equal clause *true-clause*) clause) (t (collect-negated-warrants1 (cdr lst) (add-literal (fcons-term* 'not (fcons-term* (warrant-name (car lst)))) clause t)))))
collect-negated-warrantsfunction
(defun collect-negated-warrants (term wrld clause) (collect-negated-warrants1 (collect-warranted-fns term nil nil wrld) clause))
add-literalsfunction
(defun add-literals (cl1 cl2) (cond ((endp cl1) cl2) (t (add-literal (car cl1) (add-literals (cdr cl1) cl2) nil))))
special-conjecturesfunction
(defun special-conjectures (clause term wrld newvar) (cond ((null newvar) nil) ((special-loop$-scion-callp term wrld) (let* ((style (loop$-scion-style (ffn-symb term))) (warrant-hyps (collect-negated-warrants term wrld nil)) (warranted-clause (add-literals warrant-hyps clause))) (cond ((eq style :do) (let* ((m-fn (unquote (fargn term 1))) (initial-alist (fargn term 2)) (do-fn (unquote (fargn term 3))) (do-fn-var (car (lambda-object-formals do-fn))) (do-fn-guard (lambda-object-guard do-fn)) (fin-fn (unquote (fargn term 4))) (fin-fn-var (car (lambda-object-formals fin-fn))) (fin-fn-guard (lambda-object-guard fin-fn)) (special-conjecture-d (if (equal do-fn-guard *t*) *true-clause* (add-literal-smart (subst-var initial-alist do-fn-var do-fn-guard) warranted-clause t))) (special-conjecture-e-f-g (add-literal-smart `((lambda (triple alist) ((lambda (exit-flg new-alist alist) (implies ,(SUBST-VAR 'ALIST DO-FN-VAR DO-FN-GUARD) (if (equal exit-flg 'nil) (if ,(SUBST-VAR 'NEW-ALIST DO-FN-VAR DO-FN-GUARD) (l< (lex-fix (apply$ ',M-FN (cons new-alist 'nil))) (lex-fix (apply$ ',M-FN (cons alist 'nil)))) 'nil) (if (equal exit-flg ':loop-finish) ,(SUBST-VAR 'NEW-ALIST FIN-FN-VAR FIN-FN-GUARD) 't)))) (car triple) (car (cdr (cdr triple))) alist)) (true-list-fix (apply$ ',DO-FN (cons alist 'nil))) alist) warrant-hyps t))) (append (if (equal special-conjecture-d *true-clause*) nil (list special-conjecture-d)) (if (equal special-conjecture-e-f-g *true-clause*) nil (list special-conjecture-e-f-g))))) (t (let* ((test-b (loop$-scion-restriction (ffn-symb term))) (fn (unquote (fargn term 1))) (globals (if (eq style :plain) nil (fargn term 2))) (lst (if (eq style :plain) (fargn term 2) (fargn term 3))) (var1 (car (lambda-object-formals fn))) (var2 (cadr (lambda-object-formals fn))) (fngp (lambda-object-guard fn)) (subst (if (eq style :plain) `((,VAR1 . ,NEWVAR)) `((,VAR1 . ,GLOBALS) (,VAR2 . ,NEWVAR)))) (special-conjecture-a (if (equal fngp *t*) *true-clause* (add-literal-smart (sublis-var subst fngp) (add-literal-smart `(not (member-equal ,NEWVAR ,LST)) warranted-clause t) t))) (special-conjecture-b (if test-b (add-literal-smart `(,TEST-B (apply$ ',FN ,(IF (EQ STYLE :PLAIN) `(CONS ,NEWVAR 'NIL) `(CONS ,GLOBALS (CONS ,NEWVAR 'NIL))))) (add-literal-smart `(not (member-equal ,NEWVAR ,LST)) warranted-clause t) t) *true-clause*))) (append (if (equal special-conjecture-a *true-clause*) nil (list special-conjecture-a)) (if (equal special-conjecture-b *true-clause*) nil (list special-conjecture-b)))))))) (t nil)))
make-lambda-application+function
(defun make-lambda-application+ (formals body actuals) (let ((term (make-lambda-application formals body actuals))) (cond ((and (lambda-applicationp term) (equal (lambda-formals (ffn-symb term)) (fargs term))) (lambda-body (ffn-symb term))) (t term))))
make-lambda-application+-lstfunction
(defun make-lambda-application+-lst (formals termlist args) (cond ((endp termlist) nil) (t (cons (make-lambda-application+ formals (car termlist) args) (make-lambda-application+-lst formals (cdr termlist) args)))))
split-envfunction
(defun split-env (env clause) (cond ((endp env) (mv nil clause)) ((lambda-applicationp (car env)) (mv-let (env1 clause1) (split-env (cdr env) clause) (mv (cons (car env1) env1) clause1))) (t (cond ((let ((accessor-call (fargn (car env) 1))) (or (dumb-occur-lst accessor-call (cdr env)) (dumb-occur-lst accessor-call clause))) (split-env (cdr env) (add-literal (fcons-term* 'not (car env)) clause nil))) (t (mv-let (env1 clause1) (split-env (cdr env) clause) (mv (cons (car env1) env1) clause1)))))))
add-env-to-clause-set-1function
(defun add-env-to-clause-set-1 (env cl-set) (cond ((endp cl-set) nil) (t (mv-let (tags-rev cl0) (split-initial-extra-info-lits (car cl-set) nil) (mv-let (env2 cl) (split-env env cl0) (declare (ignore env2)) (cons (revappend tags-rev cl) (add-env-to-clause-set-1 env (cdr cl-set))))))))
add-env-to-clause-setfunction
(defun add-env-to-clause-set (env cl-set) (cond ((null env) cl-set) (t (add-env-to-clause-set-1 env cl-set))))
guard-clausesmutual-recursion
(mutual-recursion (defun guard-clauses (term debug-info stobj-optp clause wrld newvar) (cond ((variablep term) (mv nil nil)) ((fquotep term) (mv nil nil)) ((flambda-applicationp term) (mv-let (cl-set1 env1) (guard-clauses-lst (fargs term) debug-info stobj-optp clause wrld newvar) (mv-let (cl-set2 env2) (guard-clauses (lambda-body (ffn-symb term)) debug-info stobj-optp nil wrld newvar) (let* ((formals (lambda-formals (ffn-symb term))) (args (remove-guard-holders-lst (fargs term) wrld)) (term1 (make-lambda-application+ formals (termify-clause-set cl-set2) args)) (cl (if (and (null (cdr cl-set2)) (ffn-symb-p term1 'if)) (reverse (disjoin-clauses (make-lambda-application+-lst formals (car cl-set2) args) clause)) (reverse (add-literal-smart term1 clause nil)))) (cl-set3 (if (equal cl *true-clause*) cl-set1 (conjoin-clause-sets+ debug-info cl-set1 (list cl)))) (env3 (make-lambda-application+-lst formals env2 args)) (env (union-equal env3 env1))) (mv (add-env-to-clause-set env cl-set3) env))))) ((eq (ffn-symb term) 'if) (let ((test (remove-guard-holders (fargn term 1) wrld))) (mv-let (cl-set1 env1) (guard-clauses (fargn term 1) debug-info stobj-optp clause wrld newvar) (mv-let (cl-set2 env2) (guard-clauses (fargn term 2) debug-info stobj-optp (add-literal-smart (dumb-negate-lit test) clause nil) wrld newvar) (mv-let (cl-set3 env3) (guard-clauses (fargn term 3) debug-info stobj-optp (add-literal-smart test clause nil) wrld newvar) (mv (conjoin-clause-sets+ debug-info cl-set1 (conjoin-clause-sets+ debug-info cl-set2 cl-set3)) (cond ((or env2 env3) (let* ((env23 (intersection-equal env2 env3)) (env2a (if env23 (set-difference-equal env2 env23) env2)) (env3a (if env23 (set-difference-equal env3 env23) env3))) (cond ((or env2a env3a) (add-to-set-equal (fcons-term* 'if (fargn term 1) (conjoin env2a) (conjoin env3a)) (if env23 (union$ env1 env23 :test 'equal) env1))) (t (union$ env1 env23 :test 'equal))))) (t env1)))))))) ((eq (ffn-symb term) 'wormhole-eval) (let* ((whs (car (lambda-formals (cadr (fargn term 2))))) (body (lambda-body (cadr (fargn term 2)))) (name-dropper-term (fargn term 3)) (new-var (if whs (genvar whs (symbol-name whs) nil (all-vars1-lst clause (all-vars name-dropper-term))) nil)) (new-body (if (eq whs new-var) body (subst-var new-var whs body)))) (cond ((not (or (variablep (fargn term 1)) (fquotep (fargn term 1)))) (mv (er hard 'guard-clauses "We thought that the name argument of every call of ~ wormhole-eval in the ACL2 source code was either a ~ variable symbol or a quoted constant. But ~ guard-clauses has encountered a call of wormhole-eval ~ with the term ~x0 in the wormhole name position. Out ~ of sheer laziness, guard-clauses is not prepared to ~ generate guard clauses for such a call of ~ wormhole-eval! Please inform the ACL2 developers of ~ this error message and we'll fix it!" (fargn term 1)) nil)) (new-var (mv-let (cl-set env) (guard-clauses new-body debug-info stobj-optp clause wrld newvar) (mv cl-set (cond ((dumb-occur-var-lst new-var env) nil) (t env))))) (t (guard-clauses new-body debug-info stobj-optp clause wrld newvar))))) ((throw-nonexec-error-p term :non-exec nil) (guard-clauses (fargn term 2) debug-info stobj-optp clause wrld newvar)) (t (let ((env-term (mv-let (tbl-get parent st st-creator) (parse-stobj-let-actual term) (declare (ignore st-creator)) (cond ((and tbl-get (not (member-eq tbl-get *stobjs-out-invalid*)) (equal (stobjs-out tbl-get wrld) (list *stobj-table-stobj*)) (equal (stobjs-in tbl-get wrld) (list nil parent *stobj-table-stobj*))) (fcons-term* (get-stobj-recognizer st wrld) term)) (t nil)))) (guard-concl-segments (clausify (guard (ffn-symb term) stobj-optp wrld) nil t (sr-limit wrld)))) (mv-let (cl-set1 env1) (guard-clauses-lst (cond ((and (eq (ffn-symb term) 'return-last) (quotep (fargn term 1))) (case (unquote (fargn term 1)) (mbe1-raw (list (fargn term 2))) (ec-call1-raw (fargs (fargn term 3))) (otherwise (fargs term)))) (t (fargs term))) debug-info stobj-optp clause wrld newvar) (let* ((cl-set2 (special-conjectures clause term wrld newvar)) (env2 (if env-term (add-to-set-equal env-term env1) env1)) (guard-concl-segments-1 (add-each-literal-lst (and guard-concl-segments (sublis-var-lst-lst (pairlis$ (formals (ffn-symb term) wrld) (remove-guard-holders-lst (fargs term) wrld)) guard-concl-segments)))) (cl-set (conjoin-clause-sets+ debug-info (conjoin-clause-sets+ debug-info cl-set1 (add-env-to-clause-set env2 (add-segments-to-clause (maybe-add-extra-info-lit debug-info term (reverse clause) wrld) guard-concl-segments-1))) (add-env-to-clause-set env2 cl-set2)))) (mv cl-set env2))))))) (defun guard-clauses-lst (lst debug-info stobj-optp clause wrld newvar) (cond ((null lst) (mv nil nil)) (t (mv-let (cl-set1 env1) (guard-clauses (car lst) debug-info stobj-optp clause wrld newvar) (mv-let (cl-set2 env2) (guard-clauses-lst (cdr lst) debug-info stobj-optp clause wrld newvar) (mv (conjoin-clause-sets+ debug-info cl-set1 cl-set2) (union-equal env1 env2))))))))
guard-clauses+function
(defun guard-clauses+ (term debug-info stobj-optp clause ens wrld safe-mode gc-off ttree newvar) (mv-let (clause-lst0 env0) (guard-clauses term debug-info stobj-optp clause wrld newvar) (declare (ignore env0)) (cond ((eq ens :do-not-simplify) (mv clause-lst0 ttree)) (t (mv-let (flg clause-lst ttree memo) (eval-ground-subexpressions1-lst-lst clause-lst0 ens wrld safe-mode gc-off ttree *loop$-special-function-symbols* nil) (declare (ignore flg memo)) (mv clause-lst ttree))))))
guard-clauses-for-bodyfunction
(defun guard-clauses-for-body (hyp-segments body debug-info stobj-optp ens wrld safe-mode gc-off ttree newvar) (cond ((null hyp-segments) (mv nil ttree)) (t (mv-let (cl-set1 ttree) (guard-clauses+ body debug-info stobj-optp (car hyp-segments) ens wrld safe-mode gc-off ttree newvar) (mv-let (cl-set2 ttree) (guard-clauses-for-body (cdr hyp-segments) body debug-info stobj-optp ens wrld safe-mode gc-off ttree newvar) (mv (conjoin-clause-sets+ debug-info cl-set1 cl-set2) ttree))))))
normalize-ts-backchain-limit-for-defsfunction
(defun normalize-ts-backchain-limit-for-defs (wrld) (let ((limit (backchain-limit wrld :ts))) (if (eql limit 0) 0 1)))
guard-clauses-for-fn1function
(defun guard-clauses-for-fn1 (name debug-p ens wrld safe-mode gc-off ttree) (let ((newvar (genvar (cond ((symbolp name) name) ((lambda-formals name) (car (lambda-formals name))) (t 'apply$)) "NEWV" nil (all-vars!-of-fn name wrld))) (guard (if (symbolp name) (guard name nil wrld) (lambda-object-guard name))) (stobj-optp (and (symbolp name) (not (eq (getpropc name 'non-executablep nil wrld) t))))) (mv-let (cl-set1 ttree) (guard-clauses+ guard (and debug-p `(:guard (:guard ,NAME))) stobj-optp nil ens wrld safe-mode gc-off ttree newvar) (let ((unnormalized-body (if (symbolp name) (getpropc name 'unnormalized-body '(:error "See GUARD-CLAUSES-FOR-FN.") wrld) (lambda-object-body name)))) (mv-let (normal-guard ttree) (cond ((eq ens :do-not-simplify) (mv guard nil)) (t (normalize guard t nil ens wrld ttree (normalize-ts-backchain-limit-for-defs wrld)))) (let ((hyp-segments (clausify (dumb-negate-lit normal-guard) nil t (sr-limit wrld)))) (mv-let (cl-set2 ttree) (guard-clauses-for-body hyp-segments unnormalized-body (and debug-p `(:guard (:body ,NAME))) stobj-optp ens wrld safe-mode gc-off ttree newvar) (mv-let (type-clauses ttree) (guard-clauses-for-body hyp-segments (fcons-term* 'insist (if (symbolp name) (getpropc name 'split-types-term *t* wrld) *t*)) (and debug-p `(:guard (:type ,NAME))) nil ens wrld safe-mode gc-off ttree newvar) (let ((cl-set2 (if type-clauses (conjoin-clause-sets+ debug-p type-clauses cl-set2) cl-set2))) (mv (conjoin-clause-sets+ debug-p cl-set1 cl-set2) ttree))))))))))
guard-clauses-for-fn1-lstfunction
(defun guard-clauses-for-fn1-lst (fns debug-p ens wrld safe-mode gc-off ttree) (cond ((endp fns) (mv nil ttree)) (t (mv-let (cl-set1 ttree) (guard-clauses-for-fn1 (car fns) debug-p ens wrld safe-mode gc-off ttree) (mv-let (cl-set2 ttree) (guard-clauses-for-fn1-lst (cdr fns) debug-p ens wrld safe-mode gc-off ttree) (mv (conjoin-clause-sets+ debug-p cl-set1 cl-set2) ttree))))))
collect-well-formed-lambda-objectsfunction
(defun collect-well-formed-lambda-objects (fn wrld) (cond ((global-val 'boot-strap-flg wrld) nil) (t (let* ((theorem (and (symbolp fn) (getpropc fn 'theorem nil wrld))) (guard (if (symbolp fn) (if theorem *t* (guard fn nil wrld)) (lambda-object-guard fn))) (unnormalized-body (if (symbolp fn) (or theorem (getpropc fn 'unnormalized-body '(:error "See COLLECT-WELL-FORMED-LAMBDA-OBJECTS") wrld)) (lambda-object-body fn))) (ans (collect-certain-lambda-objects-lst :well-formed (list guard unnormalized-body) wrld nil))) (if (symbolp fn) ans (cons fn ans))))))
collect-well-formed-lambda-objects-lstfunction
(defun collect-well-formed-lambda-objects-lst (fns wrld) (cond ((endp fns) nil) (t (union-equal (collect-well-formed-lambda-objects (car fns) wrld) (collect-well-formed-lambda-objects-lst (cdr fns) wrld)))))
guard-clauses-for-fnfunction
(defun guard-clauses-for-fn (fn debug-p ens wrld safe-mode gc-off ttree) (guard-clauses-for-fn1-lst (cons fn (set-difference-equal (collect-well-formed-lambda-objects fn wrld) (global-val 'common-lisp-compliant-lambdas wrld))) debug-p ens wrld safe-mode gc-off ttree))
guard-clauses-for-cliquefunction
(defun guard-clauses-for-clique (names debug-p ens wrld safe-mode gc-off ttree) (cond ((null names) (mv nil ttree)) (t (mv-let (cl-set1 ttree) (guard-clauses-for-fn (car names) debug-p ens wrld safe-mode gc-off ttree) (mv-let (cl-set2 ttree) (guard-clauses-for-clique (cdr names) debug-p ens wrld safe-mode gc-off ttree) (mv (conjoin-clause-sets+ debug-p cl-set1 cl-set2) ttree))))))
remove-built-in-clausesfunction
(defun remove-built-in-clauses (cl-set ens oncep-override wrld state ttree) (cond ((null cl-set) (mv nil ttree)) (t (mv-let (built-in-clausep ttree1) (built-in-clausep 'defun-or-guard-verification (car cl-set) ens oncep-override wrld state) (mv-let (new-set ttree) (remove-built-in-clauses (cdr cl-set) ens oncep-override wrld state (cons-tag-trees ttree1 ttree)) (cond (built-in-clausep (mv new-set ttree)) (t (mv (cons (car cl-set) new-set) ttree))))))))
length-exceedspfunction
(defun length-exceedsp (lst n) (cond ((null lst) nil) ((= n 0) t) (t (length-exceedsp (cdr lst) (1- n)))))
*half-length-initial-built-in-clauses*constant
(defconst *half-length-initial-built-in-clauses* (floor (length *initial-built-in-clauses*) 2))
clean-up-clause-setfunction
(defun clean-up-clause-set (cl-set ens wrld ttree state) (cond ((let ((sr-limit (sr-limit wrld))) (and sr-limit (> (length cl-set) sr-limit))) (pstk (remove-built-in-clauses cl-set ens (match-free-override wrld) wrld state (add-to-tag-tree 'sr-limit t ttree)))) ((length-exceedsp cl-set (if ens (global-val 'half-length-built-in-clauses wrld) *half-length-initial-built-in-clauses*)) (mv-let (cl-set ttree) (pstk (remove-built-in-clauses cl-set ens (match-free-override wrld) wrld state ttree)) (mv (pstk (subsumption-replacement-loop (merge-sort-length cl-set) nil nil)) ttree))) (t (pstk (remove-built-in-clauses (pstk (subsumption-replacement-loop (merge-sort-length cl-set) nil nil)) ens (match-free-override wrld) wrld state ttree)))))
guard-theorem-simplify-msgfunction
(defun guard-theorem-simplify-msg (caller x period-p) (declare (xargs :guard t)) (msg "~@0 must be ~x1 or ~x2, hence the supplied value ~x3 is ~@4" caller :limited nil x (msg (if period-p "illegal~@0." "illegal~@0") (cond ((eq x t) (msg " (consider using :LIMITED in place of ~x0)" t)) (t "")))))
guard-theoremfunction
(defun guard-theorem (fn simplify guard-debug wrld state) (declare (xargs :stobjs state :guard (and (plist-worldp wrld) (symbolp fn) (member-eq simplify '(:limited nil)) (function-symbolp fn wrld) (logicp fn wrld)))) (cond ((not (getpropc fn 'unnormalized-body nil wrld)) *t*) ((not (member-eq simplify '(:limited nil))) (er hard 'guard-theorem "~@0" (guard-theorem-simplify-msg (msg "The simplification argument of ~x0" 'guard-theorem) simplify t))) (t (let ((names (or (getpropc fn 'recursivep nil wrld) (list fn)))) (mv-let (cl-set ttree) (guard-clauses-for-clique names guard-debug :do-not-simplify wrld (f-get-global 'safe-mode state) (gc-off state) nil) (let ((cl-set (cond (simplify (mv-let (cl-set ttree) (clean-up-clause-set cl-set nil wrld ttree state) (declare (ignore ttree)) cl-set)) (t cl-set)))) (termify-clause-set cl-set)))))))
guard-or-termination-theorem-msgfunction
(defun guard-or-termination-theorem-msg (kwd args coda) (declare (xargs :guard (and (member-eq kwd '(:gthm :tthm)) (true-listp args)))) (let ((fn (car args))) (mv-let (wrld called-fn) (case kwd (:gthm (mv (nth 3 args) 'guard-theorem)) (:tthm (mv (nth 1 args) 'termination-theorem)) (otherwise (mv (er hard! 'guard-or-termination-theorem-msg "Implementation error!") nil))) (cond ((not (plist-worldp wrld)) (msg "The second argument of the call ~x0 is not a valid logical ~ world." (cons called-fn args))) ((and (eq kwd :gthm) (not (member-eq (nth 1 args) '(:limited nil)))) (guard-theorem-simplify-msg (msg "The simplification argument of ~v0" '(:guard-theorem :gthm)) (nth 1 args) t)) (t (msg "A call of ~x0 (or ~x1) can only be made on a :logic mode ~ function symbol, but ~x2 is ~@3.~@4" kwd called-fn fn (cond ((not (symbolp fn)) "not a symbol") ((not (function-symbolp fn wrld)) "not a function symbol in the current world") (t "a :program mode function symbol")) coda))))))
other
(set-guard-msg guard-theorem (guard-or-termination-theorem-msg :gthm args coda))
other
(set-guard-msg termination-theorem (guard-or-termination-theorem-msg :tthm args coda))
termination-theorem-fn-subst2function
(defun termination-theorem-fn-subst2 (old-nest wrld acc) (cond ((endp old-nest) (and (not (eq (cadr (car wrld)) 'formals)) acc)) ((eq (cadr (car wrld)) 'formals) (and (eql (length (cddr (car wrld))) (length (getpropc (car old-nest) 'formals nil wrld))) (instantiablep (car old-nest) wrld) (termination-theorem-fn-subst2 (cdr old-nest) (cdr wrld) (acons (car old-nest) (car (car wrld)) acc)))) (t nil)))
termination-theorem-fn-subst1function
(defun termination-theorem-fn-subst1 (old-nest wrld) (cond ((eq (cadr (car wrld)) 'formals) (termination-theorem-fn-subst2 (reverse old-nest) wrld nil)) ((eq (car (car wrld)) 'event-landmark) nil) (t (termination-theorem-fn-subst1 old-nest (cdr wrld)))))
termination-theorem-fn-substfunction
(defun termination-theorem-fn-subst (fn wrld) (let ((old-nest (getpropc fn 'recursivep nil wrld))) (and old-nest (termination-theorem-fn-subst1 old-nest wrld))))
other
(defun@par translate-lmi (lmi normalizep ctx wrld state) (let ((str "The object ~x0 is an ill-formed lemma instance because ~@1. ~ See :DOC lemma-instance.") (atomic-lmi-cars '(:theorem :termination-theorem :termination-theorem! :guard-theorem))) (cond ((atom lmi) (cond ((symbolp lmi) (let ((term (formula lmi normalizep wrld))) (cond (term (value@par (list term nil nil nil nil))) (t (er@par soft ctx str lmi (msg "there is no formula associated with the name ~ ~x0" lmi)))))) (t (er@par soft ctx str lmi "it is an atom that is not a symbol")))) ((and (member-eq (car lmi) atomic-lmi-cars) (not (and (true-listp lmi) (or (= (length lmi) 2) (and (member-eq (car lmi) '(:guard-theorem :termination-theorem :termination-theorem!)) (= (length lmi) 3)))))) (er@par soft ctx str lmi (msg "this ~x0 lemma instance is not a true list of length 2~@1" (car lmi) (if (member-eq (car lmi) '(:guard-theorem :termination-theorem :termination-theorem!)) " or 3" "")))) ((eq (car lmi) :theorem) (er-let*@par ((term (translate@par (cadr lmi) t t t ctx wrld state)) (term (value@par (remove-guard-holders term wrld)))) (value@par (list term (list term) nil nil (list (make-origin :theorem (cadr lmi))))))) ((or (eq (car lmi) :instance) (eq (car lmi) :functional-instance)) (cond ((and (true-listp lmi) (>= (length lmi) 2)) (er-let*@par ((lst (translate-lmi@par (cadr lmi) normalizep ctx wrld state))) (let ((formula (car lst)) (constraints (cadr lst)) (event-names (caddr lst)) (new-entries (cadddr lst)) (origins (car (cddddr lst))) (substn (cddr lmi))) (cond ((eq (car lmi) :instance) (mv-let (extra-bindings-ok substn) (cond ((eq (car substn) :extra-bindings-ok) (mv t (cdr substn))) (t (mv nil substn))) (translate-lmi/instance@par formula constraints event-names new-entries origins extra-bindings-ok substn ctx wrld state))) (t (translate-lmi/functional-instance@par formula constraints event-names new-entries origins substn (global-val 'proved-functional-instances-alist wrld) ctx wrld state)))))) (t (er@par soft ctx str lmi (msg "this ~x0 lemma instance is not a true list of length at ~ least 2" (car lmi)))))) ((eq (car lmi) :guard-theorem) (let ((fn (cadr lmi))) (cond ((not (and (symbolp fn) (function-symbolp fn wrld) (eq (symbol-class fn wrld) :common-lisp-compliant))) (er@par soft ctx str lmi (msg "~x0 is not a guard-verified function symbol in the ~ current ACL2 logical world" fn))) ((and (= (length lmi) 3) (not (member-eq (caddr lmi) '(:limited nil)))) (er@par soft ctx str lmi (guard-theorem-simplify-msg (msg "the simplification argument of ~x0" :guard-theorem) (caddr lmi) nil))) (t (let ((term (guard-theorem fn (if (= (length lmi) 2) :limited (caddr lmi)) nil wrld state))) (value@par (list term nil nil nil nil))))))) ((member-eq (car lmi) '(:termination-theorem :termination-theorem!)) (let ((fn (cadr lmi))) (cond ((not (and (symbolp fn) (function-symbolp fn wrld) (logicp fn (w state)))) (er@par soft ctx str lmi (msg "~x0 is not a :logic-mode function symbol in the ~ current ACL2 logical world" fn))) (t (let ((term (termination-theorem fn wrld))) (cond ((and (consp term) (eq (car term) :failed)) (cond ((eq (car lmi) :termination-theorem) (er@par soft ctx str lmi (msg "there is no termination theorem for ~x0. ~ ~@1" fn (cdr term)))) (t (value@par (list *t* nil nil nil nil))))) ((and (cddr lmi) (not (symbol-doublet-listp (caddr lmi)))) (er@par soft ctx str lmi "the alleged functional substitution is not a list of ~ pairs of the form (symbol x)")) ((cddr lmi) (er-let*@par ((alist (translate-functional-substitution@par (caddr lmi) ctx wrld state))) (cond ((subsetp-eq (strip-cars alist) (getpropc fn 'recursivep nil wrld)) (value@par (list (sublis-fn-simple alist term) nil nil nil nil))) (t (er@par soft ctx str lmi "its functional substitution is illegal: the ~ function symbol~#1~[ ~&1 is~/s ~&1 are~] not ~ introduced with the function symbol ~x2" lmi (set-difference-eq (strip-cars alist) (getpropc fn 'recursivep nil wrld)) fn))))) (t (let* ((alist (termination-theorem-fn-subst fn wrld)) (term (cond (alist (sublis-fn-simple alist term)) (t term)))) (value@par (list term nil nil nil nil)))))))))) ((runep lmi wrld) (let ((term (and (not (eq (car lmi) :induction)) (corollary lmi wrld)))) (cond (term (value@par (list term nil nil nil nil))) (t (er@par soft ctx str lmi "there is no known formula associated with this rune"))))) (t (er@par soft ctx str lmi "it is not a symbol, a rune in the current logical world, or a list ~ whose first element is ~v2" (list* :instance :functional-instance atomic-lmi-cars))))))
other
(defun@par translate-use-hint1 (arg ctx wrld state) (cond ((atom arg) (cond ((null arg) (value@par '(nil nil nil nil nil))) (t (er@par soft ctx "The value of the :use hint must be a true list but your ~ list ends in ~x0. See the :use discussion in :DOC hints." arg)))) (t (er-let*@par ((lst1 (translate-lmi@par (car arg) t ctx wrld state)) (lst2 (translate-use-hint1@par (cdr arg) ctx wrld state))) (value@par (list (cons (car lst1) (car lst2)) (append (cadr lst1) (cadr lst2)) (union-eq (caddr lst1) (caddr lst2)) (union-equal (cadddr lst1) (cadddr lst2)) (append (car (cddddr lst1)) (car (cddddr lst2)))))))))
add-extra-info-hyp-lstfunction
(defun add-extra-info-hyp-lst (terms origins) (cond ((endp terms) nil) (t (cons (if (car origins) (fcons-term* 'implies `(extra-info ':constraint ',(CAR ORIGINS)) (car terms)) (car terms)) (add-extra-info-hyp-lst (cdr terms) (cdr origins))))))
maybe-add-extra-info-hyp-lstfunction
(defun maybe-add-extra-info-hyp-lst (terms origins wrld) (if (and origins (constraint-tracking wrld)) (assert$ (equal (length terms) (length origins)) (add-extra-info-hyp-lst terms origins)) terms))
other
(defun@par translate-use-hint (arg ctx wrld state) (cond ((null arg) (er@par soft ctx "Implementation error: Empty :USE hints should not be handled by ~ translate-use-hint (for example, they are handled by ~ translate-hint-settings.")) (t (let ((lmi-lst (cond ((atom arg) (list arg)) ((or (member-eq (car arg) '(:instance :functional-instance :theorem :termination-theorem :termination-theorem! :guard-theorem)) (runep arg wrld)) (list arg)) (t arg)))) (er-let*@par ((lst (translate-use-hint1@par lmi-lst ctx wrld state))) (let ((constraints (cadr lst)) (origins (car (cddddr lst)))) (value@par (list lmi-lst (car lst) (add-literal (conjoin (maybe-add-extra-info-hyp-lst constraints origins wrld)) nil nil) (length (cadr lst)) (caddr lst) (cadddr lst)))))))))
convert-name-tree-to-new-name1function
(defun convert-name-tree-to-new-name1 (name-tree char-lst sym) (cond ((atom name-tree) (cond ((symbolp name-tree) (mv (append (coerce (symbol-name name-tree) 'list) (cond ((null char-lst) nil) (t (cons #\ char-lst)))) name-tree)) ((stringp name-tree) (mv (append (coerce name-tree 'list) (cond ((null char-lst) nil) (t (cons #\ char-lst)))) sym)) (t (mv (er hard 'convert-name-tree-to-new-name1 "Name-tree was supposed to be a cons tree of ~ symbols and strings, but this one contained ~ ~x0. One explanation for this is that we ~ liberalized what a goal-spec could be and ~ forgot this function." name-tree) nil)))) (t (mv-let (char-lst sym) (convert-name-tree-to-new-name1 (cdr name-tree) char-lst sym) (convert-name-tree-to-new-name1 (car name-tree) char-lst sym)))))
convert-name-tree-to-new-namefunction
(defun convert-name-tree-to-new-name (name-tree wrld) (mv-let (char-lst sym) (convert-name-tree-to-new-name1 name-tree nil 'convert-name-tree-to-new-name) (gen-new-name (intern-in-package-of-symbol (coerce char-lst 'string) sym) wrld)))
other
(defun@par translate-by-hint (name-tree arg ctx wrld state) (cond ((or (and arg (symbolp arg) (formula arg t wrld)) (consp arg)) (er-let*@par ((lst (translate-lmi@par arg nil ctx wrld state))) (value@par (list (list arg) (car lst) (add-literal (conjoin (cadr lst)) nil nil) (length (cadr lst)) (caddr lst) (cadddr lst))))) ((null arg) (value@par (convert-name-tree-to-new-name name-tree wrld))) ((and (symbolp arg) (not (keywordp arg)) (not (equal *main-lisp-package-name* (symbol-package-name arg))) (new-namep arg wrld)) (value@par arg)) (t (er@par soft ctx "The :BY hint must be given a lemma-instance, nil, or a new name. ~ ~x0 is none of these. See :DOC hints." arg))))
other
(defun@par translate-cases-hint (arg ctx wrld state) (cond ((null arg) (er@par soft ctx "We do not permit empty :CASES hints.")) ((not (true-listp arg)) (er@par soft ctx "The value associated with a :CASES hint must be a true-list of terms, ~ but ~x0 is not." arg)) (t (translate-term-lst@par arg t t t ctx wrld state))))
other
(defun@par translate-case-split-limitations-hint (arg ctx wrld state) (declare (ignore wrld)) (cond ((null arg) (value@par '(nil nil))) ((and (true-listp arg) (equal (len arg) 2) (or (natp (car arg)) (null (car arg))) (or (natp (cadr arg)) (null (cadr arg)))) (value@par arg)) (t (er@par soft ctx "The value associated with a :CASE-SPLIT-LIMITATIONS hint must ~ be either nil (denoting a list of two nils), or a true list of ~ length two, each element which is either nil or a natural ~ number; but ~x0 is not." arg))))
other
(defun@par translate-no-op-hint (arg ctx wrld state) (declare (ignore arg ctx wrld)) (value@par t))
other
(defun@par translate-error-hint (arg ctx wrld state) (declare (ignore wrld)) (cond ((tilde-@p arg) (er@par soft ctx "~@0" arg)) (t (er@par soft ctx "The :ERROR hint keyword was included among your hints, with ~ value ~x0." arg))))
other
(defun@par translate-induct-hint (arg ctx wrld state) (cond ((eq arg t) (value@par *t*)) ((or (atom arg) (and (consp arg) (eq (car arg) 'quote))) (er@par soft ctx "It is illegal to supply an atom, other than ~x0, or a quoted constant ~ as the value of an :induct hint. The hint :INDUCT ~x1 is thus illegal." t arg)) (t (translate@par arg t t t ctx wrld state))))
*built-in-executable-counterparts*constant
(defconst *built-in-executable-counterparts* '(acl2-numberp binary-* binary-+ unary-- unary-/ < car cdr char-code characterp code-char complex complex-rationalp coerce cons consp denominator equal if imagpart integerp intern-in-package-of-symbol numerator pkg-witness pkg-imports rationalp realpart stringp symbol-name symbol-package-name symbolp not))
*s-prop-theory*constant
(defconst *s-prop-theory* (cons 'iff *expandable-boot-strap-non-rec-fns*))
new-disablesfunction
(defun new-disables (theory-tail runic-theory exception ens wrld) (cond ((endp theory-tail) nil) ((and (enabled-runep (car theory-tail) ens wrld) (not (member-equal (car theory-tail) runic-theory))) (let ((sym (base-symbol (car theory-tail)))) (if (eq sym exception) (new-disables (cdr theory-tail) runic-theory exception ens wrld) (cons sym (new-disables (cdr theory-tail) runic-theory exception ens wrld))))) (t (new-disables (cdr theory-tail) runic-theory exception ens wrld))))
some-new-disables-1function
(defun some-new-disables-1 (theory-tail runic-theory ens wrld) (cond ((endp theory-tail) (mv t nil)) (t (mv-let (allp rest) (some-new-disables-1 (cdr theory-tail) runic-theory ens wrld) (let ((addp (and (enabled-runep (car theory-tail) ens wrld) (not (member-equal (car theory-tail) runic-theory))))) (cond ((and allp addp) (mv t theory-tail)) (addp (mv nil (cons (car theory-tail) rest))) (t (mv nil rest))))))))
some-new-disablesfunction
(defun some-new-disables (theory-tail runic-theory ens wrld) (mv-let (allp runes) (some-new-disables-1 theory-tail runic-theory ens wrld) (cond (allp nil) (t runes))))
some-new-enables-1function
(defun some-new-enables-1 (theory-tail runic-theory ens wrld) (cond ((endp theory-tail) (mv t nil)) (t (mv-let (allp rest) (some-new-enables-1 (cdr theory-tail) runic-theory ens wrld) (let ((addp (and (not (enabled-runep (car theory-tail) ens wrld)) (member-equal (car theory-tail) runic-theory)))) (cond ((and allp addp) (mv t theory-tail)) (addp (mv nil (cons (car theory-tail) rest))) (t (mv nil rest))))))))
some-new-enablesfunction
(defun some-new-enables (theory-tail runic-theory ens wrld) (mv-let (allp runes) (some-new-enables-1 theory-tail runic-theory ens wrld) (cond (allp nil) (t runes))))
translate-in-theory-hintfunction
(defun translate-in-theory-hint (expr chk-boot-strap-fns-flg ctx wrld state) (er-let* ((runic-value (eval-theory-expr expr ctx wrld state))) (let* ((warning-disabled-p (warning-disabled-p "Theory")) (ens (ens state))) (pprogn (cond ((or warning-disabled-p (f-get-global 'boot-strap-flg state) (not (and chk-boot-strap-fns-flg (f-get-global 'verbose-theory-warning state)))) state) (t (pprogn (let* ((definition-minimal-theory (getpropc 'definition-minimal-theory 'theory nil wrld)) (exception (and (not (simplifiable-mv-nth-p)) 'mv-nth)) (new-disables (new-disables definition-minimal-theory runic-value exception ens wrld))) (cond (new-disables (warning$ ctx ("Theory") `("The :DEFINITION rule~#0~[ for the built-in ~ function ~&0 is~/s for the built-in functions ~&0 ~ are~] disabled by the theory expression ~x1, but ~ some expansions of ~#0~[its~/their~] calls may ~ still occur. See :DOC theories-and-primitives." (:doc theories-and-primitives) (:new-disables ,NEW-DISABLES) (:rule-class :definition) (:theory-expression ,EXPR)) new-disables expr)) (t state))) (let* ((executable-counterpart-minimal-theory (getpropc 'executable-counterpart-minimal-theory 'theory nil wrld)) (new-disables (new-disables executable-counterpart-minimal-theory runic-value nil ens wrld))) (cond (new-disables (warning$ ctx ("Theory") `("The :EXECUTABLE-COUNTERPART rule~#0~[ for the ~ built-in function ~&0 is~/s for the built-in ~ functions ~&0 are~] disabled by the theory ~ expression ~x1, but some evaluations of ~ ~#0~[its~/their~] calls may still occur. See :DOC ~ theories-and-primitives." (:doc theories-and-primitives) (:new-disables ,NEW-DISABLES) (:rule-class :executable-counterpart) (:theory-expression ,EXPR)) new-disables expr)) (t state))) (let* ((acl2-primitives-theory (getpropc 'acl2-primitives 'theory nil wrld)) (new-primitive-disables (some-new-disables acl2-primitives-theory runic-value ens wrld)) (new-primitive-enables (some-new-enables acl2-primitives-theory runic-value ens wrld))) (cond ((or new-primitive-disables new-primitive-enables) (warning$ ctx ("Theory") `("There is no effect from disabling or enabling ~ :DEFINITION rules for primitive functions (see ~ :DOC primitive). For the expression ~x0, the ~ attempt to ~@1 will therefore have no effect for ~ ~#2~[its definition~/their definitions~]. See ~ :DOC theories-and-primitives." (:doc theories-and-primitives) (:new-primitive-disables ,NEW-PRIMITIVE-DISABLES) (:new-primitive-enables ,NEW-PRIMITIVE-ENABLES) (:theory-expression ,EXPR)) expr (cond ((and new-primitive-disables new-primitive-enables) (msg "disable ~&0 and enable ~&1" (strip-base-symbols new-primitive-disables) (strip-base-symbols new-primitive-enables))) (new-primitive-disables (msg "disable ~&0" (strip-base-symbols new-primitive-disables))) (t (msg "enable ~&0" (strip-base-symbols new-primitive-enables)))) (cond ((or (and new-primitive-disables new-primitive-enables) (cdr new-primitive-disables) (cdr new-primitive-enables)) 1) (t 0)))) (t state)))))) (value runic-value)))))
non-function-symbolsfunction
(defun non-function-symbols (lst wrld) (cond ((null lst) nil) ((function-symbolp (car lst) wrld) (non-function-symbols (cdr lst) wrld)) (t (cons (car lst) (non-function-symbols (cdr lst) wrld)))))
collect-non-logic-modefunction
(defun collect-non-logic-mode (alist wrld) (cond ((null alist) nil) ((and (function-symbolp (caar alist) wrld) (logicp (caar alist) wrld)) (collect-non-logic-mode (cdr alist) wrld)) (t (cons (caar alist) (collect-non-logic-mode (cdr alist) wrld)))))
other
(defun@par translate-bdd-hint1 (top-arg rest ctx wrld state) (cond ((null rest) (value@par nil)) (t (let ((kwd (car rest))) (er-let*@par ((cdar-alist (case kwd (:vars (cond ((eq (cadr rest) t) (value@par t)) ((not (true-listp (cadr rest))) (er@par soft ctx "The value associated with :VARS in the :BDD hint must ~ either be T or a true list, but ~x0 is neither." (cadr rest))) ((collect-non-legal-variableps (cadr rest)) (er@par soft ctx "The value associated with :VARS in the :BDD hint must ~ either be T or a true list of variables, but in the :BDD ~ hint ~x0, :VARS is associated with the following list of ~ non-variables: ~x1." top-arg (collect-non-legal-variableps (cadr rest)))) (t (value@par (cadr rest))))) (:prove (cond ((member-eq (cadr rest) '(t nil)) (value@par (cadr rest))) (t (er@par soft ctx "The value associated with ~x0 in the :BDD hint ~x1 ~ is ~x2, but it needs to be t or nil." kwd top-arg (cadr rest))))) (:literal (cond ((member-eq (cadr rest) '(:conc :all)) (value@par (cadr rest))) ((and (integerp (cadr rest)) (< 0 (cadr rest))) (value@par (1- (cadr rest)))) (t (er@par soft ctx "The value associated with :LITERAL in a :BDD hint ~ must be either :CONC, :ALL, or a positive integer ~ (indicating the index, starting with 1, of a ~ hypothesis). The value ~x0 from the :BDD hint ~x1 ~ is therefore illegal." (cadr rest) top-arg)))) (:bdd-constructors (cond ((and (consp (cadr rest)) (eq (car (cadr rest)) 'quote) (consp (cdr (cadr rest))) (null (cddr (cadr rest)))) (er@par soft ctx "The value associated with :BDD-CONSTRUCTORS must be a ~ list of function symbols. It should not be quoted, ~ but the value supplied is of the form (QUOTE x).")) ((not (symbol-listp (cadr rest))) (er@par soft ctx "The value associated with :BDD-CONSTRUCTORS must be a ~ list of symbols, but ~x0 ~ is not." (cadr rest))) ((all-function-symbolps (cadr rest) wrld) (value@par (cadr rest))) (t (er@par soft ctx "The value associated with :BDD-CONSTRUCTORS must be ~ a list of :logic mode function symbols, but ~&0 ~ ~#0~[is~/are~] not." (collect-non-logic-mode (pairlis$ (cadr rest) nil) wrld))))) (otherwise (er@par soft ctx "The keyword ~x0 is not a legal keyword for a :BDD hint. The ~ hint ~x1 is therefore illegal. See :DOC hints." (car rest) top-arg))))) (er-let*@par ((cdr-alist (translate-bdd-hint1@par top-arg (cddr rest) ctx wrld state))) (value@par (cons (cons kwd cdar-alist) cdr-alist))))))))
other
(defun@par translate-bdd-hint (arg ctx wrld state) (cond ((not (keyword-value-listp arg)) (er@par soft ctx "The value associated with a :BDD hint must be a list of the form (:kw1 ~ val1 :kw2 val2 ...), where each :kwi is a keyword. However, ~x0 does ~ not have this form." arg)) ((not (assoc-keyword :vars arg)) (er@par soft ctx "The value associated with a :BDD hint must include an assignment for ~ :vars, but ~x0 does not." arg)) (t (translate-bdd-hint1@par arg arg ctx wrld state))))
other
(defun@par translate-nonlinearp-hint (arg ctx wrld state) (declare (ignore wrld)) (if (or (equal arg t) (equal arg nil)) (value@par arg) (er@par soft ctx "The only legal values for a :nonlinearp hint are T and NIL, but ~x0 is ~ neither of these." arg)))
other
(defun@par translate-backchain-limit-rw-hint (arg ctx wrld state) (declare (ignore wrld)) (if (or (natp arg) (equal arg nil)) (value@par arg) (er@par soft ctx "The only legal values for a :backchain-limit-rw hint are NIL and ~ natural numbers, but ~x0 is neither of these." arg)))
other
(defun@par translate-no-thanks-hint (arg ctx wrld state) (declare (ignore ctx wrld)) (value@par arg))
other
(defun@par translate-reorder-hint (arg ctx wrld state) (declare (ignore wrld)) (if (and (pos-listp arg) (no-duplicatesp arg)) (value@par arg) (er@par soft ctx "The value for a :reorder hint must be a true list of positive integers ~ without duplicates, but ~x0 is not." arg)))
arity-mismatch-msgfunction
(defun arity-mismatch-msg (sym expected-arity wrld) (let* ((fn (or (deref-macro-name sym (macro-aliases wrld)) sym)) (arity (arity fn wrld))) (cond ((null arity) (if (getpropc sym 'macro-body nil wrld) nil (msg "~x0 is neither a function symbol nor a macro name" sym))) ((and (consp expected-arity) (< arity (car expected-arity))) (msg "~x0 has arity ~x1 (expected arity of at least ~x2 for this hint ~ syntax)" fn arity (car expected-arity))) ((and (integerp expected-arity) (not (eql expected-arity arity))) (msg "~x0 has arity ~x1 (expected arity ~x2 for this hint syntax)" fn arity expected-arity)) (t nil))))
macro-minimal-arity1function
(defun macro-minimal-arity1 (lst) (declare (xargs :guard (true-listp lst))) (cond ((endp lst) 0) ((lambda-keywordp (car lst)) 0) (t (1+ (macro-minimal-arity1 (cdr lst))))))
macro-minimal-arityfunction
(defun macro-minimal-arity (sym default wrld) (let ((args (getpropc sym 'macro-args default wrld))) (macro-minimal-arity1 (if (eq (car args) '&whole) (cddr args) args))))
translate-clause-processor-hint/symbol-to-callfunction
(defun translate-clause-processor-hint/symbol-to-call (sym wrld) (declare (xargs :guard (and (symbolp sym) (plist-worldp wrld)))) (cond ((getpropc sym 'macro-body nil wrld) (case (macro-minimal-arity sym nil wrld) (0 "it is the name of a macro that has no required arguments") (1 (list sym 'clause)) (2 (list sym 'clause nil)) (t "it is the name of a macro that has more than two required arguments"))) (t (let ((stobjs-in (stobjs-in sym wrld)) (stobjs-out (if (member-eq sym *stobjs-out-invalid*) :none (stobjs-out sym wrld)))) (cond ((null stobjs-in) (cond ((function-symbolp sym wrld) "it is a function of no arguments") (t "it is not a function symbol or macro name"))) ((or (car stobjs-in) (cadr stobjs-in)) (msg "it is a function whose ~n0 input is a stobj" (list (if (car stobjs-in) 1 2)))) ((member-eq nil (cddr stobjs-in)) "it is function symbol with a non-stobj input other than the first two") ((eq stobjs-out :none) "it is a function symbol whose output signature is unknown") ((or (car stobjs-out) (cadr stobjs-out)) (msg "it is a function whose ~n0 output is a stobj" (list (if (car stobjs-out) 1 2)))) ((member-eq nil (cddr stobjs-out)) "it is a function symbol with a non-stobj output other than the first ~ or second output") (t (list* sym 'clause (cdr stobjs-in))))))))
other
(defun@par translate-clause-processor-hint (form ctx wrld state) (let ((err-msg (msg "The form ~x0 is not a legal value for a ~ :clause-processor hint because ~@1. See :DOC ~ clause-processor." form))) (er-let*@par ((form (cond ((symbolp form) (let ((x (translate-clause-processor-hint/symbol-to-call form wrld))) (cond ((msgp x) (er@par soft ctx "~@0" err-msg x)) (t (value@par x))))) ((atom form) (er@par soft ctx "~@0" err-msg "it is an atom that is not a symbol")) ((not (true-listp form)) (er@par soft ctx "~@0" err-msg "it is a cons that is not a true-listp")) (t (case-match form ((':function cl-proc) (cond ((symbolp cl-proc) (let ((msg (arity-mismatch-msg cl-proc 1 wrld))) (cond (msg (er@par soft ctx "~@0" err-msg msg)) (t (value@par (list cl-proc 'clause)))))) (t (er@par soft ctx "~@0" err-msg "the :FUNCTION is not a symbol")))) ((':function cl-proc ':hint hint) (cond ((symbolp cl-proc) (let ((msg (arity-mismatch-msg cl-proc '(2) wrld))) (cond (msg (er@par soft ctx "~@0" err-msg msg)) (t (value@par (list* cl-proc 'clause hint (cddr (stobjs-in cl-proc wrld)))))))) (t (er@par soft ctx "~@0" err-msg "the :FUNCTION is an atom that is not a symbol")))) (& (value@par form))))))) (mv-let@par (erp term bindings state) (translate1@par form :stobjs-out '((:stobjs-out . :stobjs-out)) t ctx wrld state) (cond (erp (er@par soft ctx "~@0" err-msg "it was not successfully translated (see error message above)")) ((or (variablep term) (fquotep term) (flambda-applicationp term)) (er@par soft ctx "~@0" err-msg "it is not (even after doing macroexpansion) a call of a function ~ symbol")) (t (let ((verified-p (getpropc (ffn-symb term) 'clause-processor nil wrld))) (cond ((not (or verified-p (assoc-eq (ffn-symb term) (table-alist 'trusted-cl-proc-table wrld)))) (er@par soft ctx "~@0" err-msg "it is not a call of a clause-processor function")) ((not (eq (fargn term 1) 'clause)) (er@par soft ctx "~@0" err-msg "its first argument is not the variable, CLAUSE")) ((set-difference-eq (unknown-stobj-names (all-vars term) t wrld) '(clause)) (er@par soft ctx "~@0" err-msg (msg "it contains the free variable~#0~[~/s~] ~&0, but the only ~ legal variable (not including stobjs) is ~x1" (reverse (set-difference-eq (unknown-stobj-names (all-vars term) t wrld) '(clause))) 'clause))) (t (value@par (make clause-processor-hint :term term :stobjs-out (translate-deref :stobjs-out bindings) :verified-p verified-p)))))))))))
other
(defun@par translate-custom-keyword-hint (arg uterm2 ctx wrld state) (er-progn@par (xtrans-eval@par uterm2 (list (cons 'val arg) (cons 'world wrld) (cons 'ctx ctx)) t t ctx state t) (value@par arg)))
custom-keyword-hintfunction
(defun custom-keyword-hint (key wrld) (let ((temp (assoc-eq key (table-alist 'custom-keywords-table wrld)))) (cond (temp (mv t (car (cdr temp)) (cadr (cdr temp)))) (t (mv nil nil nil)))))
remove-all-no-opsfunction
(defun remove-all-no-ops (key-val-lst) (cond ((endp key-val-lst) nil) ((eq (car key-val-lst) :no-op) (remove-all-no-ops (cddr key-val-lst))) (t (cons (car key-val-lst) (cons (cadr key-val-lst) (remove-all-no-ops (cddr key-val-lst)))))))
remove-redundant-no-opsfunction
(defun remove-redundant-no-ops (key-val-lst) (cond ((assoc-keyword :no-op key-val-lst) (let ((temp (remove-all-no-ops key-val-lst))) (cond (temp temp) (t '(:no-op t))))) (t key-val-lst)))
find-first-custom-keyword-hintfunction
(defun find-first-custom-keyword-hint (user-hints wrld) (cond ((endp user-hints) (mv nil nil nil nil)) (t (mv-let (flg uterm1 uterm2) (custom-keyword-hint (car user-hints) wrld) (cond (flg (mv (car user-hints) (cadr user-hints) uterm1 uterm2)) (t (find-first-custom-keyword-hint (cddr user-hints) wrld)))))))
*custom-keyword-max-iterations*constant
(defconst *custom-keyword-max-iterations* 100)
other
(defun@par custom-keyword-hint-interpreter1 (keyword-alist max specified-id id clause wrld stable-under-simplificationp hist pspv ctx state keyword-alist0 eagerp) (cond ((equal specified-id id) (mv-let (keyi vali uterm1 uterm2) (find-first-custom-keyword-hint keyword-alist wrld) (cond ((null keyi) (value@par keyword-alist)) ((zp max) (er@par soft ctx "We expanded the custom keyword hints in ~x0 a total of ~x1 times ~ and were still left with a hint containing custom keywords, namely ~ ~x2." keyword-alist0 *custom-keyword-max-iterations* keyword-alist)) (t (let ((checker-bindings (list (cons 'val vali) (cons 'world wrld) (cons 'ctx ctx)))) (er-progn@par (xtrans-eval@par uterm2 checker-bindings t t ctx state t) (mv-let@par (erp val state) (xtrans-eval@par uterm1 (cond (eagerp (list* (cons 'keyword-alist keyword-alist) (cons 'id id) checker-bindings)) (t (list* (cons 'keyword-alist keyword-alist) (cons 'id id) (cons 'clause clause) (cons 'stable-under-simplificationp stable-under-simplificationp) (cons 'hist hist) (cons 'pspv pspv) checker-bindings))) t (if eagerp nil t) ctx state t) (cond (erp (mv@par erp val state)) ((not (keyword-value-listp val)) (er@par soft ctx "The custom keyword hint ~x0 in the context below generated a ~ result that is not of the form (:key1 val1 ... :keyn valn), ~ where the :keyi are keywords. The context is ~y1, and the ~ result generated was ~y2." keyi keyword-alist val)) (t (pprogn@par (cond ((f-get-global 'show-custom-keyword-hint-expansion state) (io?@par prove nil state (keyi id keyword-alist val) (fms "~%(Advisory from ~ show-custom-keyword-hint-expansion: The ~ custom keyword hint ~x0, appearing in ~@1, ~ transformed~%~%~Y23,~%into~%~%~Y43.)~%" (list (cons #\0 keyi) (cons #\1 (tilde-@-clause-id-phrase id)) (cons #\2 (cons (string-for-tilde-@-clause-id-phrase id) keyword-alist)) (cons #\3 (term-evisc-tuple nil state)) (cons #\4 (cons (string-for-tilde-@-clause-id-phrase id) val))) (proofs-co state) state nil))) (t (state-mac@par))) (custom-keyword-hint-interpreter1@par val (- max 1) specified-id id clause wrld stable-under-simplificationp hist pspv ctx state keyword-alist0 eagerp))))))))))) (t (value@par nil))))
other
(defun@par custom-keyword-hint-interpreter (keyword-alist specified-id id clause wrld stable-under-simplificationp hist pspv ctx state eagerp) (custom-keyword-hint-interpreter1@par keyword-alist *custom-keyword-max-iterations* specified-id id clause wrld stable-under-simplificationp hist pspv ctx state keyword-alist eagerp))
custom-keyword-hint-in-computed-hint-formfunction
(defun custom-keyword-hint-in-computed-hint-form (computed-hint-tuple) (let ((term (nth 3 computed-hint-tuple))) (cond ((and (nvariablep term) (not (fquotep term)) (serial-first-form-parallel-second-form@par (eq (ffn-symb term) 'custom-keyword-hint-interpreter) (or (eq (ffn-symb term) 'custom-keyword-hint-interpreter) (eq (ffn-symb term) 'custom-keyword-hint-interpreter@par))) (quotep (fargn term 1)) (quotep (fargn term 2))) (cadr (fargn term 1))) (t nil))))
other
(defun@par put-cl-id-of-custom-keyword-hint-in-computed-hint-form (computed-hint-tuple cl-id) (let ((term (nth 3 computed-hint-tuple))) (list 'eval-and-translate-hint-expression (nth 1 computed-hint-tuple) (nth 2 computed-hint-tuple) (fcons-term* (serial-first-form-parallel-second-form@par 'custom-keyword-hint-interpreter 'custom-keyword-hint-interpreter@par) (fargn term 1) (kwote cl-id) (fargn term 3) (fargn term 4) (fargn term 5) (fargn term 6) (fargn term 7) (fargn term 8) (fargn term 9) (fargn term 10) (fargn term 11)))))
make-disjunctive-clause-idfunction
(defun make-disjunctive-clause-id (cl-id i pkg-name) (change clause-id cl-id :case-lst (append (access clause-id cl-id :case-lst) (list (intern$ (coerce (packn1 (list 'd i)) 'string) pkg-name))) :primes 0))
make-disjunctive-goal-specfunction
(defun make-disjunctive-goal-spec (str i pkg-name) (let ((cl-id (parse-clause-id str))) (string-for-tilde-@-clause-id-phrase (make-disjunctive-clause-id cl-id i pkg-name))))
minimally-well-formed-or-hintpfunction
(defun minimally-well-formed-or-hintp (val) (cond ((atom val) (equal val nil)) (t (and (consp (car val)) (true-listp (car val)) (evenp (length (car val))) (minimally-well-formed-or-hintp (cdr val))))))
split-keyword-alistfunction
(defun split-keyword-alist (key keyword-alist) (cond ((endp keyword-alist) (mv nil nil)) ((eq key (car keyword-alist)) (mv nil keyword-alist)) (t (mv-let (pre post) (split-keyword-alist key (cddr keyword-alist)) (mv (cons (car keyword-alist) (cons (cadr keyword-alist) pre)) post)))))
distribute-other-hints-into-or1function
(defun distribute-other-hints-into-or1 (pre x post) (cond ((endp x) nil) (t (cons (append pre (car x) post) (distribute-other-hints-into-or1 pre (cdr x) post)))))
distribute-other-hints-into-orfunction
(defun distribute-other-hints-into-or (keyword-alist) (mv-let (pre post) (split-keyword-alist :or keyword-alist) (list :or (distribute-other-hints-into-or1 pre (cadr post) (cddr post)))))
*hint-expression-basic-vars*constant
(defconst *hint-expression-basic-vars* '(id clause world stable-under-simplificationp hist pspv ctx state))
*hint-expression-override-vars*constant
(defconst *hint-expression-override-vars* (cons 'keyword-alist *hint-expression-basic-vars*))
*hint-expression-backtrack-vars*constant
(defconst *hint-expression-backtrack-vars* (append '(clause-list processor) (remove1-eq 'stable-under-simplificationp *hint-expression-basic-vars*)))
*hint-expression-all-vars*constant
(defconst *hint-expression-all-vars* (union-equal *hint-expression-override-vars* (union-equal *hint-expression-backtrack-vars* *hint-expression-basic-vars*)))
other
(defun@par translate-hint-expression (name-tree term hint-type ctx wrld state) (cond ((symbolp term) (cond ((and (function-symbolp term wrld) (or (equal (arity term wrld) 3) (equal (arity term wrld) 4) (equal (arity term wrld) 7)) (all-nils (stobjs-in term wrld)) (not (eq term 'return-last)) (equal (stobjs-out term wrld) '(nil))) (value@par (cond ((equal (arity term wrld) 3) (list 'eval-and-translate-hint-expression name-tree nil (formal-value-triple@par *nil* (fcons-term term '(id clause world))))) ((equal (arity term wrld) 4) (list 'eval-and-translate-hint-expression name-tree t (formal-value-triple@par *nil* (fcons-term term '(id clause world stable-under-simplificationp))))) (t (list 'eval-and-translate-hint-expression name-tree t (formal-value-triple@par *nil* (fcons-term term '(id clause world stable-under-simplificationp hist pspv ctx)))))))) (t (er@par soft ctx "When you give a hint that is a symbol, it must be a function ~ symbol of three, four or seven ordinary arguments (so, not ~ involving STATE or other single-threaded objects) that ~ returns a single ordinary value. The allowable arguments are ~ ID, CLAUSE, WORLD, STABLE-UNDER-SIMPLIFICATIONP, HIST, PSPV, ~ and CTX. See :DOC computed-hints. ~x0 is not such a symbol." term)))) (t (er-let*@par ((tterm (translate-simple-or-error-triple@par term ctx wrld state))) (let ((vars (all-vars tterm))) (cond ((subsetp-eq vars (case hint-type (backtrack *hint-expression-backtrack-vars*) (override *hint-expression-override-vars*) (otherwise *hint-expression-basic-vars*))) (value@par (list 'eval-and-translate-hint-expression name-tree (if (member-eq 'stable-under-simplificationp vars) t nil) tterm))) ((and (not hint-type) (subsetp-eq vars *hint-expression-all-vars*)) (let ((backtrack-bad-vars (intersection-eq '(clause-list processor) vars)) (override-bad-vars (intersection-eq '(keyword-alist) vars))) (mv-let (bad-vars types-string) (cond (backtrack-bad-vars (cond (override-bad-vars (mv (append backtrack-bad-vars override-bad-vars) ":BACKTRACK hints or override-hints")) (t (mv backtrack-bad-vars ":BACKTRACK hints")))) (t (assert$ override-bad-vars (mv override-bad-vars "override-hints")))) (er@par soft ctx "The hint expression ~x0 mentions ~&1. But variable~#2~[ ~&2 ~ is~/s ~&2 are~] legal only for ~@3. See :DOC computed-hints." term vars bad-vars types-string)))) (t (mv-let (type-string legal-vars extra-doc-hint) (case hint-type (backtrack (mv ":BACKTRACK hint" *hint-expression-backtrack-vars* " and see :DOC hints for a discussion of :BACKTRACK ~ hints")) (override (mv "override-hint" *hint-expression-override-vars* " and see :DOC override-hints")) (otherwise (mv "Computed" *hint-expression-basic-vars* ""))) (er@par soft ctx "~@0 expressions may not mention any variable symbols other than ~ ~&1. See :DOC computed-hints~@2. But the hint expression ~x3 ~ mentions ~&4." type-string legal-vars extra-doc-hint term vars)))))))))
other
(defun@par translate-backtrack-hint (name-tree arg ctx wrld state) (translate-hint-expression@par name-tree arg 'backtrack ctx wrld state))
other
(defun@par translate-rw-cache-state-hint (arg ctx wrld state) (declare (ignore wrld)) (cond ((member-eq arg *legal-rw-cache-states*) (value@par arg)) (t (er@par soft ctx "Illegal :rw-cache-state argument, ~x0 (should be ~v1)" arg *legal-rw-cache-states*))))
other
(mutual-recursion@par (defun@par translate-or-hint (name-tree str arg ctx wrld state) (cond ((atom arg) (if (null arg) (value@par nil) (er@par soft ctx "An :OR hint must be a true-list."))) (t (er-let*@par ((val (translate-hint@par name-tree (cons (make-disjunctive-goal-spec str (length arg) (current-package state)) (car arg)) nil ctx wrld state)) (tl (translate-or-hint@par name-tree str (cdr arg) ctx wrld state))) (cond ((eq (car val) 'eval-and-translate-hint-expression) (value@par (cons (cons (car arg) val) tl))) (t (let ((val (cdr val))) (value@par (cons (cons (car arg) val) tl))))))))) (defun@par translate-hint-settings (name-tree str key-val-lst ctx wrld state) (cond ((null key-val-lst) (value@par nil)) ((and (eq (car key-val-lst) :use) (eq (cadr key-val-lst) nil)) (translate-hint-settings@par name-tree str (cddr key-val-lst) ctx wrld state)) (t (er-let*@par ((val (translate-x-hint-value@par name-tree str (car key-val-lst) (cadr key-val-lst) ctx wrld state)) (tl (translate-hint-settings@par name-tree str (cddr key-val-lst) ctx wrld state))) (value@par (cons (cons (car key-val-lst) val) tl)))))) (defun@par translate-x-hint-value (name-tree str x arg ctx wrld state) (mv-let (flg uterm1 uterm2) (custom-keyword-hint x wrld) (declare (ignore uterm1)) (cond (flg (translate-custom-keyword-hint@par arg uterm2 ctx wrld state)) (t (case x (:expand (translate-expand-hint@par arg ctx wrld state)) (:restrict (translate-restrict-hint@par arg ctx wrld state)) (:hands-off (translate-hands-off-hint@par arg ctx wrld state)) (:do-not-induct (translate-do-not-induct-hint@par arg ctx wrld state)) (:do-not (translate-do-not-hint@par arg ctx state)) (:use (translate-use-hint@par arg ctx wrld state)) (:or (translate-or-hint@par name-tree str arg ctx wrld state)) (:cases (translate-cases-hint@par arg ctx wrld state)) (:case-split-limitations (translate-case-split-limitations-hint@par arg ctx wrld state)) (:by (translate-by-hint@par name-tree arg ctx wrld state)) (:induct (translate-induct-hint@par arg ctx wrld state)) (:in-theory (translate-in-theory-hint@par arg t ctx wrld state)) (:bdd (translate-bdd-hint@par arg ctx wrld state)) (:clause-processor (translate-clause-processor-hint@par arg ctx wrld state)) (:nonlinearp (translate-nonlinearp-hint@par arg ctx wrld state)) (:no-op (translate-no-op-hint@par arg ctx wrld state)) (:no-thanks (translate-no-thanks-hint@par arg ctx wrld state)) (:reorder (translate-reorder-hint@par arg ctx wrld state)) (:backtrack (translate-backtrack-hint@par name-tree arg ctx wrld state)) (:backchain-limit-rw (translate-backchain-limit-rw-hint@par arg ctx wrld state)) (:error (translate-error-hint@par arg ctx wrld state)) (:rw-cache-state (translate-rw-cache-state-hint@par arg ctx wrld state)) (otherwise (mv@par (er hard 'translate-x-hint-value "The object ~x0 not recognized as a legal hint keyword. See :DOC ~ hints." x) nil state))))))) (defun replace-goal-spec-in-name-tree1 (name-tree goal-spec) (cond ((atom name-tree) (cond ((and (stringp name-tree) (parse-clause-id name-tree)) (mv t goal-spec)) (t (mv nil name-tree)))) (t (mv-let (flg1 name-tree1) (replace-goal-spec-in-name-tree1 (car name-tree) goal-spec) (cond (flg1 (mv t (cons name-tree1 (cdr name-tree)))) (t (mv-let (flg2 name-tree2) (replace-goal-spec-in-name-tree1 (cdr name-tree) goal-spec) (mv flg2 (cons (car name-tree) name-tree2))))))))) (defun replace-goal-spec-in-name-tree (name-tree goal-spec) (mv-let (flg new-name-tree) (replace-goal-spec-in-name-tree1 name-tree goal-spec) (cond (flg new-name-tree) (t (cons name-tree goal-spec))))) (defun@par translate-hint (name-tree pair hint-type ctx wrld state) (cond ((not (and (consp pair) (stringp (car pair)) (keyword-value-listp (cdr pair)))) (er@par soft ctx "Each hint is supposed to be a list of the form (str :key1 val1 ~ ... :keyn valn), but a proposed hint, ~x0, is not. See :DOC ~ hints." pair)) (t (let ((cl-id (parse-clause-id (car pair)))) (cond ((null cl-id) (er@par soft ctx "The object ~x0 is not a goal-spec. See :DOC hints and :DOC ~ goal-spec." (car pair))) ((assoc-keyword :error (cdr pair)) (translate-error-hint@par (cadr (assoc-keyword :error (cdr pair))) ctx wrld state)) (t (mv-let (keyi vali uterm1 uterm2) (find-first-custom-keyword-hint (cdr pair) wrld) (declare (ignore vali uterm1 uterm2)) (cond (keyi (mv-let@par (erp val state) (custom-keyword-hint-interpreter@par (cdr pair) cl-id cl-id nil wrld nil nil nil ctx state t) (cond (erp (cond ((eq val 'wait) (er-let*@par ((hint-settings (translate-hint-settings@par (replace-goal-spec-in-name-tree name-tree (car pair)) (car pair) (cdr pair) ctx wrld state))) (translate-hint-expression@par name-tree (serial-first-form-parallel-second-form@par `(custom-keyword-hint-interpreter ',(CDR PAIR) ',CL-ID id clause world stable-under-simplificationp hist pspv ctx state 'nil) `(custom-keyword-hint-interpreter@par ',(CDR PAIR) ',CL-ID id clause world stable-under-simplificationp hist pspv ctx state 'nil)) hint-type ctx wrld state))) (t (mv@par t nil state)))) (t (translate-hint@par name-tree (cons (car pair) val) hint-type ctx wrld state))))) (t (let* ((key-val-lst (remove-redundant-no-ops (cdr pair))) (keys (evens key-val-lst)) (expanded-hint-keywords (append (strip-cars (table-alist 'custom-keywords-table wrld)) *hint-keywords*))) (cond ((null keys) (er@par soft ctx "There is no point in attaching the empty list of ~ hints to ~x0. We suspect that you have made a ~ mistake in presenting your hints. See :DOC hints. ~ ~ If you really want a hint that changes nothing, ~ use ~x1." (car pair) (cons (car pair) '(:no-op t)))) ((not (subsetp-eq keys expanded-hint-keywords)) (er@par soft ctx "The legal hint keywords are ~&0. ~&1 ~ ~#1~[is~/are~] unrecognized. See :DOC hints." expanded-hint-keywords (set-difference-eq keys expanded-hint-keywords))) ((member-eq :computed-hint-replacement keys) (er@par soft ctx "The hint keyword ~x0 has been used incorrectly. ~ Its only appropriate use is as a leading hint ~ keyword in computed hints. See :DOC computed-hints." :computed-hint-replacement)) ((not (no-duplicatesp-equal keys)) (er@par soft ctx "You have duplicate occurrences of the hint keyword ~ ~&0 in your hint. While duplicate occurrences of ~ keywords are permitted by CLTL, the semantics ~ ignores all but the left-most. We therefore ~ suspect that you have made a mistake in presenting ~ your hints." (duplicates keys))) ((and (assoc-keyword :or (cdr pair)) (not (minimally-well-formed-or-hintp (cadr (assoc-keyword :or (cdr pair)))))) (er@par soft ctx "The value supplied to an :OR hint must be a ~ non-empty true-list of non-empty true-lists of even ~ length, i.e., of the form ((...) ...). But you ~ supplied the value ~x0." (cdr pair))) ((and (member-eq :induct keys) (member-eq :use keys)) (er@par soft ctx "We do not support the use of an :INDUCT hint with a ~ :USE hint. When a subgoal with an :INDUCT hint ~ arises, we push it for proof by induction. Upon ~ popping it, we interpret the :INDUCT hint to ~ determine the induction and we also install any ~ other non-:USE hints supplied. On the other hand, ~ when a subgoal with a :USE hint arises, we augment ~ the formula with the additional hypotheses supplied ~ by the hint. If both an :INDUCT and a :USE hint ~ were attached to the same subgoal we could either ~ add the hypotheses before induction, which is ~ generally detrimental to a successful induction, or ~ add them to each of the formulas produced by the ~ induction, which generally adds the hypotheses in ~ many more places than they are needed. We ~ therefore do neither and cause this neat, ~ informative error. You are encouraged to attach ~ the :INDUCT hint to the goal or subgoal to which ~ you want us to apply induction and then attach :USE ~ hints to the individual subgoals produced, as ~ necessary. For what it is worth, :INDUCT hints get ~ along just fine with hints besides :USE. For ~ example, an :INDUCT hint and an :IN-THEORY hint ~ would cause an induction and set the post-induction ~ locally enabled theory to be as specified by the ~ :IN-THEORY.")) ((and (member-eq :reorder keys) (intersectp-eq '(:or :induct) keys)) (cond ((member-eq :or keys) (er@par soft ctx "We do not support the use of a :REORDER hint with ~ an :OR hint. The order of disjunctive subgoals ~ corresponds to the list of hints given by the :OR ~ hint, so you may want to reorder that list ~ instead.")) (t (er@par soft ctx "We do not support the use of a :REORDER hint with ~ an :INDUCT hint. If you want this capability, ~ please send a request to the ACL2 implementors.")))) (t (let ((bad-keys (intersection-eq `(:induct ,@*TOP-HINT-KEYWORDS*) keys))) (cond ((and (< 1 (length bad-keys)) (not (and (member-eq :use bad-keys) (member-eq :cases bad-keys) (equal 2 (length bad-keys))))) (er@par soft ctx "We do not support the use of a~#0~[n~/~] ~x1 ~ hint with a~#2~[n~/~] ~x3 hint, since they ~ suggest two different ways of replacing the ~ current goal by new goals. ~@4Which is it to ~ be? To summarize: A~#0~[n~/~] ~x1 hint ~ together with a~#2~[n~/~] ~x3 hint is not ~ allowed because the intention of such a ~ combination does not seem sufficiently clear." (if (member-eq (car bad-keys) '(:or :induct)) 0 1) (car bad-keys) (if (member-eq (cadr bad-keys) '(:or :induct)) 0 1) (cadr bad-keys) (cond ((and (eq (car bad-keys) :by) (eq (cadr bad-keys) :induct)) "The :BY hint suggests that the goal follows ~ from an existing theorem, or is to be ~ pushed. However, the :INDUCT hint provides ~ for replacement of the current goal by ~ appropriate new goals before proceeding. ") (t "")))) (t (er-let*@par ((hint-settings (translate-hint-settings@par (replace-goal-spec-in-name-tree name-tree (car pair)) (car pair) (cond ((assoc-keyword :or (cdr pair)) (distribute-other-hints-into-or (cdr pair))) (t (cdr pair))) ctx wrld state))) (cond ((and (consp hint-settings) (eq (caar hint-settings) :or) (consp (cdr (car hint-settings))) (null (cddr (car hint-settings)))) (assert$ (null (cdr hint-settings)) (value@par (let* ((pair (cadr (car hint-settings))) (hint-settings2 (cdr pair))) (cons cl-id hint-settings2))))) (t (value@par (cons cl-id hint-settings)))))))))))))))))))))
other
(defun@par translate-hint-expressions (name-tree terms hint-type ctx wrld state) (cond ((endp terms) (cond ((equal terms nil) (value@par nil)) (t (er@par soft ctx "The value of the :COMPUTED-HINT-REPLACEMENT key must be NIL, ~ T, or a true list of terms. Your list ends in ~x0." terms)))) (t (er-let*@par ((thint (translate-hint-expression@par name-tree (car terms) hint-type ctx wrld state)) (thints (translate-hint-expressions@par name-tree (cdr terms) hint-type ctx wrld state))) (value@par (cons thint thints))))))
other
(defun@par check-translated-override-hint (hint uhint ctx state) (cond ((not (and (consp hint) (eq (car hint) 'eval-and-translate-hint-expression))) (er@par soft ctx "The proposed override-hint, ~x0, was not a computed hint. See ~ :DOC override-hints." uhint)) (t (value@par nil))))
other
(defun@par translate-hints1 (name-tree lst hint-type override-hints seen ctx wrld state) (cond ((atom lst) (cond ((null lst) (value@par nil)) (t (er@par soft ctx "The :HINTS keyword is supposed to have a true-list as its ~ value, but ~x0 is not one. See :DOC hints." lst)))) (t (let ((goal-name (and (consp (car lst)) (stringp (caar lst)) (caar lst)))) (cond ((and goal-name (null (cdar lst))) (translate-hints1@par name-tree (cdr lst) hint-type override-hints seen ctx wrld state)) (t (er-let*@par ((hint (cond (goal-name (pprogn@par (if (member-string-equal goal-name seen) (warning$@par ctx "Hints" "The goal-spec ~x0 is explicitly associated ~ with more than one hint. All but the first of ~ these hints may be ignored. If you intended ~ to give all of these hints, consider combining ~ them into a single hint of the form (~x0 :kwd1 ~ val1 :kwd2 val2 ...). See :DOC hints and :DOC ~ hints-and-the-waterfall; community book ~ books/hints/merge-hint.lisp might also be ~ helpful." goal-name) (state-mac@par)) (translate-hint@par name-tree (car lst) hint-type ctx wrld state))) (t (translate-hint-expression@par name-tree (car lst) hint-type ctx wrld state)))) (rst (translate-hints1@par name-tree (cdr lst) hint-type override-hints (cond (goal-name (cons goal-name seen)) (t seen)) ctx wrld state))) (er-progn@par (cond ((eq hint-type 'override) (check-translated-override-hint@par hint (car lst) ctx state)) (t (value@par nil))) (value@par (cons (cond ((atom hint) hint) (goal-name (cond (override-hints (list* (car hint) (cons :keyword-alist (cdar lst)) (cons :name-tree name-tree) (cdr hint))) (t hint))) ((eq (car hint) 'eval-and-translate-hint-expression) hint) (t (er hard ctx "Internal error: Unexpected ~ translation ~x0 for hint ~x1. ~ Please contact the ACL2 implementors." hint (car lst)))) rst))))))))))
override-hintsfunction
(defun override-hints (wrld) (declare (xargs :guard (and (plist-worldp wrld) (alistp (table-alist 'default-hints-table wrld))))) (cdr (assoc-eq :override (table-alist 'default-hints-table wrld))))
other
(defun@par translate-hints (name-tree lst ctx wrld state) (translate-hints1@par name-tree lst nil (override-hints wrld) nil ctx wrld state))
other
(defun@par translate-hints+1 (name-tree lst default-hints ctx wrld state) (cond ((not (true-listp lst)) (er@par soft ctx "The :HINTS keyword is supposed to have a true-list as its value, but ~ ~x0 is not one. See :DOC hints." lst)) (t (translate-hints@par name-tree (append lst default-hints) ctx wrld state))))
translate-hints+function
(defun translate-hints+ (name-tree lst default-hints ctx wrld state) (translate-hints+1 name-tree lst default-hints ctx wrld state))
translate-override-hintsfunction
(defun translate-override-hints (name-tree lst ctx wrld state) (translate-hints1 name-tree lst 'override nil nil ctx wrld state))
other
(defun@par apply-override-hint1 (override-hint cl-id clause hist pspv ctx wrld stable-under-simplificationp clause-list processor keyword-alist state) (let* ((tuple override-hint) (flg (cadr (cdr tuple))) (term (caddr (cdr tuple)))) (er-let*@par ((new-keyword-alist (xtrans-eval@par term (list* (cons 'id cl-id) (cons 'clause clause) (cons 'hist hist) (cons 'pspv pspv) (cons 'ctx ctx) (cons 'world wrld) (cons 'clause-list clause-list) (cons 'processor processor) (cons 'keyword-alist keyword-alist) (if flg (cons (cons 'stable-under-simplificationp stable-under-simplificationp) nil) nil)) nil t ctx state t))) (cond ((not (keyword-value-listp new-keyword-alist)) (er@par soft ctx "An override-hint, ~x0, has produced an illegal value from ~ keyword-alist ~x1. That value, ~x2, is illegal because it is not a ~ keyword-value-listp, i.e., an alternating list of keywords and ~ values." (untranslate term nil wrld) keyword-alist new-keyword-alist)) (t (mv-let@par (erp new-keyword-alist state) (custom-keyword-hint-interpreter@par new-keyword-alist cl-id cl-id clause wrld stable-under-simplificationp hist pspv ctx state nil) (cond (erp (er@par soft ctx "An override-hint applied to ~@0 has generated an illegal custom ~ keyword hint, as reported above." (tilde-@-clause-id-phrase cl-id))) ((eq (car new-keyword-alist) :computed-hint-replacement) (er@par soft ctx "An override-hint, ~x0, has produced an illegal value from ~ keyword-alist ~x1. That value, ~x2, is illegal because it ~ begins with the keyword :COMPUTED-HINT-REPLACEMENT; see :DOC ~ override-hints." (untranslate term nil wrld) keyword-alist new-keyword-alist)) ((assoc-keyword :error new-keyword-alist) (translate-error-hint@par (cadr (assoc-keyword :error new-keyword-alist)) (msg "an override hint applied to ~@0" (tilde-@-clause-id-phrase cl-id)) wrld state)) (t (value@par new-keyword-alist)))))))))
other
(defun@par apply-override-hint (override-hint cl-id clause hist pspv ctx wrld stable-under-simplificationp clause-list processor keyword-alist state) (apply-override-hint1 override-hint cl-id clause hist pspv ctx wrld stable-under-simplificationp clause-list processor keyword-alist state))
other
(defun@par apply-override-hints (override-hints cl-id clause hist pspv ctx wrld stable-under-simplificationp clause-list processor keyword-alist state) (cond ((endp override-hints) (value@par keyword-alist)) (t (er-let*@par ((new-keyword-alist (apply-override-hint@par (car override-hints) cl-id clause hist pspv ctx wrld stable-under-simplificationp clause-list processor keyword-alist state))) (apply-override-hints@par (cdr override-hints) cl-id clause hist pspv ctx wrld stable-under-simplificationp clause-list processor new-keyword-alist state)))))
other
(defun@par eval-and-translate-hint-expression (tuple cl-id clause wrld stable-under-simplificationp hist pspv clause-list processor keyword-alist hint-type override-hints ctx state) (let* ((name-tree (car tuple)) (flg (cadr tuple)) (term (caddr tuple)) (custom-keyword-alist (if (and (nvariablep term) (not (fquotep term)) (serial-first-form-parallel-second-form@par (eq (ffn-symb term) 'custom-keyword-hint-interpreter) (or (eq (ffn-symb term) 'custom-keyword-hint-interpreter) (eq (ffn-symb term) 'custom-keyword-hint-interpreter@par))) (quotep (fargn term 1)) (quotep (fargn term 2))) (cadr (fargn term 1)) nil))) (er-let*@par ((val0 (xtrans-eval@par term (list* (cons 'id cl-id) (cons 'clause clause) (cons 'clause-list clause-list) (cons 'processor processor) (cons 'keyword-alist keyword-alist) (cons 'world wrld) (cons 'hist hist) (cons 'pspv pspv) (cons 'ctx ctx) (if flg (cons (cons 'stable-under-simplificationp stable-under-simplificationp) nil) nil)) nil t ctx state t))) (cond ((null val0) (value@par nil)) (t (er-let*@par ((str (value@par (string-for-tilde-@-clause-id-phrase cl-id))) (chr-p (cond ((keyword-value-listp val0) (value@par (eq (car val0) :computed-hint-replacement))) (t (er@par soft ctx "A ~#0~[custom keyword~/computed~] hint for ~x1 has ~ produced a result that is not an alternating list of ~ keywords and values, (str :key1 val1 ... :keyn valn). ~ That result, ~x2, is thus illegal." (if custom-keyword-alist 0 1) str val0)))) (chr (cond ((null chr-p) (value@par :irrelevant)) (custom-keyword-alist (er@par soft (msg "a custom keyword hint for ~x0" str) "The hint ~x0 produced a :COMPUTED-HINT-REPLACEMENT value as ~ part of its result. It is not permitted for custom keyword ~ hints to produce such a value (only computed hints are allowed ~ to do that). The result produced was ~x1." (cons str (cadr (fargn term 1))) val0)) ((not (consp (cdr val0))) (er@par soft (msg "a computed hint for ~x0: The computed hint ~% ~q1 produced ~ the non-nil result~%~y2. But this is an illegal value" str (untranslate term nil wrld) val0) "The :COMPUTED-HINT-REPLACEMENT keyword must be followed by a ~ list whose first element is NIL, T, or a list of terms. The ~ remaining elements are to be keyword/value pairs.")) ((or (eq (cadr val0) nil) (eq (cadr val0) t)) (value@par (cadr val0))) (t (translate-hint-expressions@par (cons "Computed hint auto-generated for " name-tree) (cadr val0) hint-type 'auto-generated-hint wrld state)))) (val1 (value@par (if chr-p (cddr val0) val0)))) (cond ((null val1) (value@par nil)) (t (er-let*@par ((val (cond ((and (keyword-value-listp val1) (assoc-keyword :error val1)) (translate-error-hint@par (cadr (assoc-keyword :error val1)) (msg "a ~#0~[custom keyword~/computed~] hint for ~x1" (if custom-keyword-alist 0 1) str) wrld state)) (t (apply-override-hints@par override-hints cl-id clause hist pspv ctx wrld stable-under-simplificationp clause-list processor val1 state))))) (cond ((null val) (value@par nil)) (t (er-let*@par ((temp (translate-hint@par name-tree (cons str val) hint-type (msg "a ~#0~[custom keyword~/computed~] hint for ~x1: The ~ ~#0~[custom keyword~/computed~] hint ~%~#0~[~x2 ~ ~/~q2~]produced the non-nil result~%~y3.~@4Regarding this ~ value" (if custom-keyword-alist 0 1) str (if custom-keyword-alist custom-keyword-alist (untranslate term nil wrld)) val0 (cond ((equal val val1) "") (t (msg "In turn, override-hints transformed these ~ hint-settings~#0~[ (without the leading ~ :COMPUTED-HINT-REPLACEMENT value)~/~] into ~ ~x1. " (if (equal val0 val1) 1 0) val)))) wrld state)) (temp1 (cond ((eq (car temp) 'eval-and-translate-hint-expression) (eval-and-translate-hint-expression@par (cdr temp) cl-id clause wrld stable-under-simplificationp hist pspv clause-list processor keyword-alist hint-type nil ctx state)) (t (value@par (cdr temp)))))) (cond ((and chr-p (not (eq (car temp1) :computed-hint-replacement))) (value@par (list* :computed-hint-replacement chr temp1))) (t (value@par temp1)))))))))))))))
ttags-seenmacro
(defmacro ttags-seen nil '(mv-let (col state) (fmt1 "~*0Warning: This output is minimally trustworthy (see :DOC ~ ~x1).~%" `((#\0 "<no ttags seen>~%" "~q*" "~q*" "~q*" ,(GLOBAL-VAL 'TTAGS-SEEN (W STATE))) (#\1 . ttags-seen)) 0 (standard-co state) state nil) (declare (ignore col)) (value ':invisible)))
active-book-namefunction
(defun active-book-name (wrld state) (or (car (global-val 'include-book-path wrld)) (let ((info (f-get-global 'certify-book-info state))) (and info (access certify-book-info info :full-book-name)))))
other
(defrec deferred-ttag-note (val active-book-name . include-bookp) t)
fms-to-standard-cofunction
(defun fms-to-standard-co (str alist state evisc-tuple) (declare (xargs :guard (and (stringp str) (character-alistp alist) (standard-evisc-tuplep evisc-tuple)))) (fms str alist *standard-co* state evisc-tuple))
remove-lisp-suffixfunction
(defun remove-lisp-suffix (x dotp) (declare (xargs :guard (and (stringp x) (<= 5 (length x))))) (subseq x 0 (- (length x) (if dotp 5 4))))
print-ttag-notefunction
(defun print-ttag-note (val active-book-name include-bookp deferred-p state) (flet ((book-name-root (full-book-name wrld) (remove-lisp-suffix (book-name-to-filename full-book-name wrld 'print-ttag-note) t))) (pprogn (let* ((book-string (cond (active-book-name (book-name-root active-book-name (w state))) (t ""))) (included (if include-bookp " (for included book)" "")) (str (if active-book-name "TTAG NOTE~s0: Adding ttag ~x1 from book ~s2." "TTAG NOTE~s0: Adding ttag ~x1 from the top level loop.")) (bound (+ (length included) (length str) (length (symbol-package-name val)) 2 (length (symbol-name val)) (length book-string)))) (mv-let (erp val state) (state-global-let* ((fmt-hard-right-margin bound set-fmt-hard-right-margin) (fmt-soft-right-margin bound set-fmt-soft-right-margin)) (pprogn (fms-to-standard-co str (list (cons #\0 included) (cons #\1 val) (cons #\2 book-string)) state nil) (cond (deferred-p state) (t (newline *standard-co* state))) (value nil))) (declare (ignore erp val)) state)) (cond ((and (consp include-bookp) (not deferred-p)) (warning$ (car include-bookp) "Ttags" "The ttag note just printed to the terminal indicates a ~ modification to ACL2. To avoid this warning, supply ~ an explicit :TTAGS argument when including the book ~ ~x0." (book-name-root (cdr include-bookp) (w state)))) (t state)))))
show-ttag-notes1function
(defun show-ttag-notes1 (notes state) (cond ((endp notes) (newline *standard-co* state)) (t (pprogn (let ((note (car notes))) (print-ttag-note (access deferred-ttag-note note :val) (access deferred-ttag-note note :active-book-name) (access deferred-ttag-note note :include-bookp) t state)) (show-ttag-notes1 (cdr notes) state)))))
show-ttag-notes-fnfunction
(defun show-ttag-notes-fn (state) (let* ((notes0 (f-get-global 'deferred-ttag-notes-saved state)) (notes (remove-duplicates-equal notes0))) (cond (notes (pprogn (cond ((equal notes notes0) state) (t (fms-to-standard-co "Note: Duplicates have been removed from the ~ list of deferred ttag notes before printing ~ them below.~|" nil state nil))) (show-ttag-notes1 (reverse notes) state) (f-put-global 'deferred-ttag-notes-saved nil state))) (t (fms-to-standard-co "All ttag notes have already been printed.~|" nil state nil)))))
show-ttag-notesmacro
(defmacro show-ttag-notes nil '(pprogn (show-ttag-notes-fn state) (value :invisible)))
set-deferred-ttag-notesfunction
(defun set-deferred-ttag-notes (val state) (let ((ctx 'set-deferred-ttag-notes) (immediate-p (not val))) (cond ((member-eq val '(t nil)) (pprogn (cond ((eq immediate-p (eq (f-get-global 'deferred-ttag-notes state) :not-deferred)) (observation ctx "No change; ttag notes are already ~@0being ~ deferred." (if immediate-p "not " ""))) ((and immediate-p (consp (f-get-global 'deferred-ttag-notes state))) (pprogn (fms-to-standard-co "Note: Enabling immediate printing mode for ttag ~ notes. Below are the ttag notes that have been ~ deferred without being reported." nil state nil) (f-put-global 'deferred-ttag-notes-saved (f-get-global 'deferred-ttag-notes state) state) (f-put-global 'deferred-ttag-notes nil state) (show-ttag-notes-fn state))) (immediate-p (pprogn (observation ctx "Enabling immediate printing mode for ttag notes.") (f-put-global 'deferred-ttag-notes :not-deferred state) (f-put-global 'deferred-ttag-notes-saved nil state))) (t (pprogn (fms-to-standard-co "TTAG NOTE: Printing of ttag notes is being put into ~ deferred mode.~|" nil state nil) (f-put-global 'deferred-ttag-notes :empty state)))) (value :invisible))) (t (er soft ctx "The only legal values for set-deferred-ttag-notes are ~x0 and ~ ~x1. ~ The value ~x2 is thus illegal." t nil val)))))
ttags-from-deferred-ttag-notes1function
(defun ttags-from-deferred-ttag-notes1 (notes) (cond ((endp notes) nil) (t (add-to-set-eq (access deferred-ttag-note (car notes) :val) (ttags-from-deferred-ttag-notes1 (cdr notes))))))
ttags-from-deferred-ttag-notesfunction
(defun ttags-from-deferred-ttag-notes (notes) (reverse (ttags-from-deferred-ttag-notes1 notes)))
print-deferred-ttag-notes-summaryfunction
(defun print-deferred-ttag-notes-summary (state) (let ((notes (f-get-global 'deferred-ttag-notes state))) (cond ((null notes) (f-put-global 'deferred-ttag-notes :empty state)) ((atom notes) state) (t (pprogn (f-put-global 'deferred-ttag-notes-saved notes state) (fms-to-standard-co "TTAG NOTE: Printing of ttag notes has been deferred for the ~ following list of ttags:~| ~y0.To print the deferred ttag ~ notes: ~y1." (list (cons #\0 (ttags-from-deferred-ttag-notes notes)) (cons #\1 '(show-ttag-notes))) state nil) (f-put-global 'deferred-ttag-notes :empty state))))))
notify-on-defttagfunction
(defun notify-on-defttag (val active-book-name include-bookp state) (cond ((or (f-get-global 'skip-notify-on-defttag state) (eq include-bookp :quiet)) state) ((and (null include-bookp) (eq val (ttag (w state)))) state) ((eq (f-get-global 'deferred-ttag-notes state) :not-deferred) (print-ttag-note val active-book-name include-bookp nil state)) ((eq (f-get-global 'deferred-ttag-notes state) :empty) (pprogn (print-ttag-note val active-book-name include-bookp nil state) (f-put-global 'deferred-ttag-notes nil state))) (t (pprogn (cond ((null (f-get-global 'deferred-ttag-notes state)) (fms-to-standard-co "TTAG NOTE: Deferring one or more ttag notes until the current ~ top-level command completes.~|" nil state nil)) (t state)) (f-put-global 'deferred-ttag-notes (cons (make deferred-ttag-note :val val :active-book-name active-book-name :include-bookp include-bookp) (f-get-global 'deferred-ttag-notes state)) state)))))
ttag-allowed-pfunction
(defun ttag-allowed-p (ttag ttags active-book-name acc) (cond ((endp ttags) nil) ((eq ttag (car ttags)) (revappend acc (cons (list ttag active-book-name) (cdr ttags)))) ((atom (car ttags)) (ttag-allowed-p ttag (cdr ttags) active-book-name (cons (car ttags) acc))) ((eq ttag (caar ttags)) (cond ((or (null (cdar ttags)) (member-equal active-book-name (cdar ttags))) t) (t nil))) (t (ttag-allowed-p ttag (cdr ttags) active-book-name (cons (car ttags) acc)))))
chk-acceptable-ttag1function
(defun chk-acceptable-ttag1 (val active-book-name ttags-allowed ttags-seen include-bookp ctx state) (let* ((ttags-allowed0 (cond ((eq ttags-allowed :all) t) (t (ttag-allowed-p val ttags-allowed active-book-name nil)))) (ttags-allowed1 (cond ((eq ttags-allowed0 t) ttags-allowed) (t ttags-allowed0)))) (cond ((not ttags-allowed1) (er soft ctx "The ttag ~x0 associated with ~@1 is not among the set of ttags ~ permitted in the current context, specified as follows:~| ~ ~x2.~|See :DOC defttag.~@3" val (if active-book-name (msg "file ~s0" (book-name-to-filename active-book-name (w state) ctx)) "the top level loop") ttags-allowed (cond ((null (f-get-global 'skip-notify-on-defttag state)) "") (t (msg " This error is unusual since it is occurring while ~ including a book that appears to have been certified, in ~ this case, the book ~x0. Most likely, that book needs to ~ be recertified, though a temporary workaround may be to ~ delete its certificate (i.e., its .cert file). Otherwise ~ see :DOC make-event-details, section ``A note on ttags,'' ~ for a possible explanation." (f-get-global 'skip-notify-on-defttag state)))))) (t (pprogn (notify-on-defttag val active-book-name include-bookp state) (let ((old-book-names (cdr (assoc-eq val ttags-seen)))) (cond ((member-equal active-book-name old-book-names) (value (cons ttags-allowed1 ttags-seen))) (t (value (cons ttags-allowed1 (put-assoc-eq val (cons active-book-name old-book-names) ttags-seen)))))))))))
chk-acceptable-ttagfunction
(defun chk-acceptable-ttag (val include-bookp ctx wrld state) (cond ((null val) (value nil)) (t (chk-acceptable-ttag1 val (active-book-name wrld state) (f-get-global 'ttags-allowed state) (global-val 'ttags-seen wrld) include-bookp ctx state))))
chk-acceptable-ttags2function
(defun chk-acceptable-ttags2 (ttag book-names ttags-allowed ttags-seen include-bookp ctx state) (cond ((endp book-names) (value (cons ttags-allowed ttags-seen))) (t (er-let* ((pair (chk-acceptable-ttag1 ttag (car book-names) ttags-allowed ttags-seen include-bookp ctx state))) (mv-let (ttags-allowed ttags-seen) (cond ((null pair) (mv ttags-allowed ttags-seen)) (t (mv (car pair) (cdr pair)))) (chk-acceptable-ttags2 ttag (cdr book-names) ttags-allowed ttags-seen include-bookp ctx state))))))
chk-acceptable-ttags1function
(defun chk-acceptable-ttags1 (vals active-book-name ttags-allowed ttags-seen include-bookp ctx state) (cond ((endp vals) (value (cons ttags-allowed ttags-seen))) (t (er-let* ((pair (cond ((consp (car vals)) (chk-acceptable-ttags2 (caar vals) (cdar vals) ttags-allowed ttags-seen include-bookp ctx state)) (t (chk-acceptable-ttag1 (car vals) active-book-name ttags-allowed ttags-seen include-bookp ctx state))))) (mv-let (ttags-allowed ttags-seen) (cond ((null pair) (mv ttags-allowed ttags-seen)) (t (mv (car pair) (cdr pair)))) (chk-acceptable-ttags1 (cdr vals) active-book-name ttags-allowed ttags-seen include-bookp ctx state))))))
set-fast-certfunction
(defun set-fast-cert (val state) (cond ((not (member-eq val '(t nil :accept))) (er soft 'set-fast-cert "Set-fast-cert requires an argument that is t, nil, or :accept, ~ but it has been given the argument, ~x0." val)) ((f-get-global 'certify-book-info state) (er soft 'set-fast-cert "Set-fast-cert is illegal during certify-book.")) ((not (int= (f-get-global 'make-event-debug-depth state) 0)) (er soft 'set-fast-cert "Set-fast-cert is illegal during make-event expansion.")) (t (let ((status (f-get-global 'fast-cert-status state))) (cond ((and (null val) (fast-cert-included-book status)) (er soft 'set-fast-cert "Fast-cert mode must remain enabled during this ACL2 ~ session, because of prior evaluation of an include-book ~ form for a book that was certified with fast-cert mode ~ enabled. That book is ~x0. See :DOC fast-cert." status)) ((iff val status) (cond ((null val) (pprogn (observation 'set-fast-cert "No change: fast-cert mode is already disabled.") (value :no-change))) ((iff (consp status) (eq val :accept)) (pprogn (observation 'set-fast-cert (if (consp status) "No change: fast-cert is already in ACCEPT ~ mode." "No change: fast-cert mode is already active.")) (value :no-change))) (t (pprogn (f-put-global 'fast-cert-status (if (consp status) (car status) (list status)) state) (value val))))) (t (pprogn (cond ((eq val :accept) (fms-to-standard-co "TTAG NOTE: Fast-cert is in ~ ACCEPT mode (see :DOC ~ fast-cert).~|" nil state nil)) ((eq val t) (fms-to-standard-co "TTAG NOTE: Fast-cert mode is ~ active (see :DOC fast-cert).~|" nil state nil)) (t state)) (f-put-global 'fast-cert-status (if (eq val :accept) (list t) val) state) (value val))))))))
chk-table-nil-argsfunction
(defun chk-table-nil-args (op bad-arg bad-argn ctx state) (cond (bad-arg (er soft ctx "Table operation ~x0 requires that the ~n1 argument to ~ TABLE be nil. Hence, ~x2 is an illegal ~n1 argument. ~ See :DOC table." op bad-argn bad-arg)) (t (value nil))))
*badge-table-guard-msg*constant
(defconst *badge-table-guard-msg* (msg "The attempt to change the :badge-userfn-structure of the badge-table ~ failed because " nil))
chk-table-guardfunction
(defun chk-table-guard (name key val ctx wrld ens state) (cond ((and (eq name 'acl2-defaults-table) (eq key :include-book-dir-alist) (not (f-get-global 'modifying-include-book-dir-alist state))) (er soft ctx "Illegal attempt to set the :include-book-dir-alist field of the ~ acl2-defaults-table. This can only be done by calling ~v0." '(add-include-book-dir delete-include-book-dir))) ((and (eq name 'include-book-dir!-table) (not (f-get-global 'modifying-include-book-dir-alist state))) (er soft ctx "Illegal attempt to set the include-book-dir!-table. This can only ~ be done by calling ~v0." '(add-include-book-dir! delete-include-book-dir!))) ((and (eq name 'puff-included-books) (not (f-get-global 'modifying-include-book-dir-alist state))) (er soft ctx "Illegal attempt to set the puff-included-books table. This can only ~ be done by calling :puff or :puff*.")) (t (let* ((prop (getpropc name 'table-guard *t* wrld)) (mvp (and (consp prop) (eq (car prop) :mv))) (term (if mvp (cdr prop) prop))) (er-progn (mv-let (erp ev-result latches) (ev term (list (cons 'key key) (cons 'val val) (cons 'world wrld) (cons 'ens ens) (cons 'state (coerce-state-to-object state))) state (list (cons 'state (coerce-state-to-object state))) nil t) (declare (ignore latches)) (cond (erp (pprogn (error-fms nil ctx "Table-guard" (car ev-result) (cdr ev-result) state) (er-soft ctx "Table-guard" "The TABLE :guard for ~x0 on the key ~x1 and value ~ ~x2 could not be evaluated." name key val))) ((if mvp (car ev-result) ev-result) (value nil)) ((and mvp (msgp (cadr ev-result))) (er soft ctx "~@0" (cadr ev-result))) (t (er soft ctx "The TABLE :guard for ~x0 disallows the combination of key ~ ~x1 and value ~x2. The :guard~#3~[~/~@4~] is ~x5. See :DOC ~ table.~#6~[~/~@7~]" name key val (if mvp 1 0) ", representing multiple values (mv okp msg)," (untranslate term t wrld) (if (and mvp (cadr ev-result)) 1 0) (msg " Note: You are seeing this generic error message ~ even though the TABLE guard for ~x0 evaluated to ~ multiple values ~x1, because the second value does ~ not satisfy ~x2." name (list 'mv (car ev-result) (cadr ev-result)) 'msgp))))) (if (and (eq name 'acl2-defaults-table) (eq key :ttag)) (chk-acceptable-ttag val nil ctx wrld state) (value nil)))))))
chk-table-guards-recfunction
(defun chk-table-guards-rec (name alist ctx pair wrld ens state) (if alist (er-let* ((new-pair (chk-table-guard name (caar alist) (cdar alist) ctx wrld ens state))) (if (and pair new-pair) (assert$ (and (eq name 'acl2-defaults-table) (eq (caar alist) :ttag)) (er soft ctx "It is illegal to specify the :ttag twice in ~ the acl2-defaults-table.")) (chk-table-guards-rec name (cdr alist) ctx new-pair wrld ens state))) (value pair)))
chk-table-guardsfunction
(defun chk-table-guards (name alist ctx wrld ens state) (chk-table-guards-rec name alist ctx nil wrld ens state))
put-assoc-equal-fastfunction
(defun put-assoc-equal-fast (name val alist) (declare (xargs :guard (alistp alist))) (if (assoc-equal name alist) (put-assoc-equal name val alist) (acons name val alist)))
global-set?function
(defun global-set? (var val wrld old-val) (if (equal val old-val) wrld (global-set var val wrld)))
cltl-def-memoize-partialfunction
(defun cltl-def-memoize-partial (fn total wrld) (let* ((recp (getpropc total 'recursivep nil wrld)) (table-key (car recp)) (tuples (cdr (assoc-eq table-key (table-alist 'partial-functions-table wrld)))) (tuple (assoc-eq fn tuples))) (car (last tuple))))
table-cltl-cmdfunction
(defun table-cltl-cmd (name key val op ctx wrld) (let ((unsupported-str "Unsupported operation, ~x0, for updating table ~x1.")) (case name (memoize-table (cond ((eq op :guard) nil) ((not (eq op :put)) (er hard ctx unsupported-str op name)) (val (let* ((condition-fn (cdr (assoc-eq :condition-fn val))) (condition-def (and condition-fn (not (eq condition-fn t)) (cltl-def-from-name condition-fn wrld))) (condition (or (eq condition-fn t) (car (last condition-def)))) (total (cdr (assoc-eq :total val)))) `(memoize ,KEY ,CONDITION ,(CDR (ASSOC-EQ :INLINE VAL)) ,(IF TOTAL (CLTL-DEF-MEMOIZE-PARTIAL KEY TOTAL WRLD) (CLTL-DEF-FROM-NAME KEY WRLD)) ,(GETPROPC KEY 'FORMALS T WRLD) ,(GETPROPC KEY 'STOBJS-IN T WRLD) ,(GETPROPC KEY 'STOBJS-OUT T WRLD) ,(AND (SYMBOLP CONDITION) CONDITION (NOT (EQ CONDITION T)) (CLTL-DEF-FROM-NAME CONDITION WRLD)) ,(AND (CDR (ASSOC-EQ :COMMUTATIVE VAL)) T) ,(CDR (ASSOC-EQ :FORGET VAL)) ,(CDR (ASSOC-EQ :MEMO-TABLE-INIT-SIZE VAL)) ,(CDR (ASSOC-EQ :AOKP VAL)) ,(CDR (ASSOC-EQ :STATS VAL)) ,(CDR (ASSOC-EQ :INVOKE VAL))))) (t `(unmemoize ,KEY)))) (badge-table *special-cltl-cmd-attachment-mark*) (t nil))))
table-fn1function
(defun table-fn1 (name key val op term ctx wrld ens state event-form) (case op (:alist (er-progn (chk-table-nil-args :alist (or key val term) (cond (key '(2)) (val '(3)) (t '(5))) ctx state) (value (table-alist name wrld)))) (:get (er-progn (chk-table-nil-args :get (or val term) (cond (val '(3)) (t '(5))) ctx state) (value (cdr (assoc-equal key (getpropc name 'table-alist nil wrld)))))) (:put (with-ctx-summarized ctx (let* ((tbl (getpropc name 'table-alist nil wrld)) (old-pair (assoc-equal key tbl))) (er-progn (chk-table-nil-args :put term '(5) ctx state) (cond ((and (or old-pair (eq name 'memoize-table)) (equal val (cdr old-pair))) (stop-redundant-event ctx state)) (t (er-let* ((pair (chk-table-guard name key val ctx wrld ens state)) (wrld0 (value (cond ((eq name 'puff-included-books) (global-set 'include-book-alist (cons val (global-val 'include-book-alist wrld)) wrld)) (t wrld)))) (wrld1 (cond ((null pair) (value wrld0)) (t (let ((ttags-allowed1 (car pair)) (ttags-seen1 (cdr pair))) (pprogn (f-put-global 'ttags-allowed ttags-allowed1 state) (value (global-set? 'ttags-seen ttags-seen1 wrld0 (global-val 'ttags-seen wrld))))))))) (install-event name event-form 'table 0 nil (table-cltl-cmd name key val op ctx wrld) nil nil (putprop name 'table-alist (if old-pair (put-assoc-equal key val tbl) (acons key val tbl)) wrld1) state)))))))) (:clear (with-ctx-summarized ctx (er-progn (chk-table-nil-args :clear (or key term) (cond (key '(2)) (t '(5))) ctx state) (cond ((equal val (table-alist name wrld)) (stop-redundant-event ctx state)) ((not (alistp val)) (er soft 'table ":CLEAR requires an alist, but ~x0 is not." val)) (t (let ((val (if (duplicate-keysp val) (reverse (clean-up-alist val nil)) val))) (er-let* ((wrld1 (er-let* ((pair (chk-table-guards name val ctx wrld ens state))) (cond ((null pair) (value wrld)) (t (let ((ttags-allowed1 (car pair)) (ttags-seen1 (cdr pair))) (pprogn (f-put-global 'ttags-allowed ttags-allowed1 state) (value (global-set? 'ttags-seen ttags-seen1 wrld (global-val 'ttags-seen wrld)))))))))) (install-event name event-form 'table 0 nil (table-cltl-cmd name key val op ctx wrld) nil nil (putprop name 'table-alist val wrld1) state)))))))) (:guard (cond ((eq term nil) (er-progn (chk-table-nil-args op (or key val) (cond (key '(2)) (t '(3))) ctx state) (value (getpropc name 'table-guard *t* wrld)))) (t (with-ctx-summarized ctx (er-progn (chk-table-nil-args op (or key val) (cond (key '(2)) (t '(3))) ctx state) (mv-let (erp tterm bindings state) (translate1 term :stobjs-out '((:stobjs-out . :stobjs-out)) '(state) ctx wrld state) (cond (erp (silent-error state)) (t (let ((stobjs-out (translate-deref :stobjs-out bindings))) (cond ((not (or (equal stobjs-out '(nil)) (equal stobjs-out '(nil nil)))) (er soft 'table "The table :guard must return either one or two ~ values~@0; but ~x1 ~@2." (if (all-nils stobjs-out) "" ", none of them STATE, other stobjs, or :DF values") term (if (cdr stobjs-out) (msg "has output signature" (cons 'mv stobjs-out)) (msg "returns ~#0~[a :DF value~/STATE~]" (if (eq (car stobjs-out) :df) 0 (assert$ (eq (car stobjs-out) 'state) 1)))))) (t (let* ((old-guard (getpropc name 'table-guard nil wrld)) (mv-p (and (consp old-guard) (eq (car old-guard) :mv))) (old-tterm (if mv-p (cdr old-guard) old-guard))) (cond ((and (iff mv-p (cdr stobjs-out)) (equal old-tterm tterm)) (stop-redundant-event ctx state)) (old-guard (er soft ctx "It is illegal to change the :guard on a table after ~ it has been given an explicit :guard. The :guard ~ of ~x0 is ~x1 and this can be changed only by ~ undoing the event that set it. See :DOC table." name (untranslate old-tterm t wrld))) ((getpropc name 'table-alist nil wrld) (er soft ctx "It is illegal to set the :guard of the non-empty ~ table ~x0. See :DOC table." name)) (t (let ((legal-vars '(key val world ens state)) (vars (all-vars tterm))) (cond ((not (subsetp-eq vars legal-vars)) (er soft ctx "The only variables permitted in the :guard ~ of a table are ~&0, but your guard uses ~ ~&1. See :DOC table." legal-vars (reverse vars))) (t (install-event name event-form 'table 0 nil (table-cltl-cmd name key val op ctx wrld) nil nil (putprop name 'table-guard (if (cdr stobjs-out) (cons :mv tterm) tterm) wrld) state)))))))))))))))))) (otherwise (er soft ctx "Unrecognized table operation, ~x0. See :DOC table." op))))
table-fnfunction
(defun table-fn (name args state event-form) (let* ((ctx (cons 'table name)) (wrld (w state)) (ens (ens state)) (strictp (ffn-symb-p (getpropc name 'table-guard *t* wrld) 'strict-table-guard)) (alist (if (or (eq name 'acl2-defaults-table) strictp) nil (list (cons 'world wrld) (cons 'ens ens)))) (event-form (or event-form `(table ,NAME ,@ARGS))) (n (length args)) (key-form (car args)) (val-form (cadr args)) (op (cond ((= n 2) :put) ((= n 1) :get) ((= n 0) :alist) (t (caddr args)))) (term (cadddr args))) (er-progn (cond ((not (symbolp name)) (er soft ctx "The first argument to table must be a symbol, but ~ ~x0 is not. See :DOC table." name)) ((< 4 (length args)) (er soft ctx "Table may be given no more than five arguments. In ~ ~x0 it is given ~n1. See :DOC table." event-form (1+ (length args)))) (t (value nil))) (er-let* ((key-pair (simple-translate-and-eval key-form alist nil (if (eq name 'acl2-defaults-table) "In (TABLE ACL2-DEFAULTS-TABLE key ...), key" (if strictp "The second argument of TABLE when the :guard is strict" "The second argument of TABLE")) ctx wrld state nil)) (val-pair (simple-translate-and-eval val-form alist nil (if (eq name 'acl2-defaults-table) "In (TABLE ACL2-DEFAULTS-TABLE key val ...), val" (if strictp "The third argument of TABLE when the :guard is strict" "The third argument of TABLE")) ctx wrld state nil))) (table-fn1 name (cdr key-pair) (cdr val-pair) op term ctx wrld ens state event-form)))))
set-override-hints-fnfunction
(defun set-override-hints-fn (lst at-end ctx wrld state) (er-let* ((tlst (translate-override-hints 'override-hints lst ctx wrld state)) (new (case at-end ((t) (value (append (override-hints wrld) tlst))) ((nil) (value (append tlst (override-hints wrld)))) (:clear (value tlst)) (:remove (let ((old (override-hints wrld))) (value (set-difference-equal old tlst)))) (otherwise (er soft ctx "Unrecognized operation in ~x0: ~x1." 'set-override-hints-fn at-end))))) (er-progn (table-fn 'default-hints-table (list :override (kwote new)) state nil) (table-fn 'default-hints-table (list :override) state nil))))