other
(in-package "ACL2")
termpmutual-recursion
(mutual-recursion (defun termp (x w) (declare (xargs :guard (plist-worldp-with-formals w))) (cond ((atom x) (legal-variablep x)) ((eq (car x) 'quote) (and (consp (cdr x)) (null (cddr x)))) ((symbolp (car x)) (let ((arity (arity (car x) w))) (and arity (term-listp (cdr x) w) (eql (length (cdr x)) arity)))) ((and (consp (car x)) (true-listp (car x)) (eq (car (car x)) 'lambda) (eql 3 (length (car x))) (arglistp (cadr (car x))) (termp (caddr (car x)) w) (null (set-difference-eq (all-vars (caddr (car x))) (cadr (car x)))) (term-listp (cdr x) w) (eql (length (cadr (car x))) (length (cdr x)))) t) (t nil))) (defun term-listp (x w) (declare (xargs :guard (plist-worldp-with-formals w))) (cond ((atom x) (equal x nil)) ((termp (car x) w) (term-listp (cdr x) w)) (t nil))))
term-list-listpfunction
(defun term-list-listp (l w) (declare (xargs :guard (plist-worldp-with-formals w))) (if (atom l) (equal l nil) (and (term-listp (car l) w) (term-list-listp (cdr l) w))))
computed-hint-tuple-listpfunction
(defun computed-hint-tuple-listp (x wrld) (cond ((consp x) (let ((tuple (car x))) (and (true-listp tuple) (eq (car tuple) 'eval-and-translate-hint-expression) (booleanp (caddr tuple)) (termp (cadddr tuple) wrld) (computed-hint-tuple-listp (cdr x) wrld)))) (t (null x))))
other
(set-table-guard default-hints-table (case key ((t) (true-listp val)) (:override (computed-hint-tuple-listp val world)) (t nil)))
other
(table default-hints-table nil nil :clear)
macro-argsfunction
(defun macro-args (x w) (declare (xargs :guard (and (symbolp x) (plist-worldp w)))) (getpropc x 'macro-args '(:error "We thought macro-args was only called if there were ~ (zero or more) macro-args.") w))
*macro-expansion-ctx*constant
(defconst *macro-expansion-ctx* "macro expansion")
error-trace-suggestionfunction
(defun error-trace-suggestion (two-leading-spaces) (declare (xargs :mode :program)) (msg "~s0To debug see :DOC print-gv, see :DOC trace, and see :DOC wet." (if two-leading-spaces " " "")))
ignored-attachment-msgfunction
(defun ignored-attachment-msg (ignored-attachment) (cond (ignored-attachment (msg "~|~%Note that because of logical ~ considerations, attachments (including ~x0) ~ must not be called in this context. See ~ :DOC ignored-attachment." ignored-attachment)) (t "")))
ev-fncall-null-body-er-msgfunction
(defun ev-fncall-null-body-er-msg (ignored-attachment fn args) (cond ((eq fn :non-exec) (assert$ (null ignored-attachment) (msg "ACL2 has been instructed to cause an error because of an attempt ~ to evaluate the following form (see :DOC non-exec):~|~% ~ ~x0.~|~%~@1" args (error-trace-suggestion nil)))) ((consp fn) (assert$ (and (stringp (car fn)) (alistp (cdr fn))) fn)) (t (msg "ACL2 cannot ev the call of non-executable function ~x0 on ~ argument list:~|~%~x1~@2~|~%~@3" fn args (ignored-attachment-msg ignored-attachment) (error-trace-suggestion nil)))))
ev-fncall-null-body-erpfunction
(defun ev-fncall-null-body-erp (fn) `(ev-fncall-null-body-er . ,FN))
ev-fncall-null-body-erfunction
(defun ev-fncall-null-body-er (ignored-attachment fn args latches) (mv (ev-fncall-null-body-erp fn) (ev-fncall-null-body-er-msg ignored-attachment fn args) latches))
ev-fncall-creator-er-msgfunction
(defun ev-fncall-creator-er-msg (fn) (msg "An attempt has been made to call the stobj creator function ~x0. This ~ error is being reported even though guard-checking may have been turned ~ off, because ACL2 does not support non-compliant live stobj manipulation. ~ ~ If you did not explicitly call ~x0 then this error is probably due to ~ an attempt to evaluate a with-local-stobj form directly in the top-level ~ loop. Such forms are only allowed in the bodies of functions and in ~ theorems. Also see :DOC with-local-stobj.~@1" fn (error-trace-suggestion t)))
unknown-pkg-error-msgfunction
(defun unknown-pkg-error-msg (fn pkg-name) (msg "The call ~x0 is illegal because the argument is not the name of a package ~ currently known to ACL2." (list fn pkg-name)))
illegal-msgfunction
(defun illegal-msg nil (msg "Evaluation aborted.~@0" (error-trace-suggestion t)))
program-only-er-msgfunction
(defun program-only-er-msg (fn args safe-mode) (msg "The call ~x0~|is an illegal call of a function that has been marked as ~ ``program-only,'' presumably because it has special raw Lisp code~@1. ~ See :DOC program-only for further explanation and a link to possible ~ workarounds." (cons fn args) (if safe-mode " and safe-mode is active" "")))
*safe-mode-guard-er-addendum*constant
(defconst *safe-mode-guard-er-addendum* " The guard is being checked because this function is a primitive and a ~ "safe" mode is being used for defconst, defpkg, macroexpansion, or ~ another operation where safe mode is required.")
find-first-non-nilfunction
(defun find-first-non-nil (lst) (cond ((endp lst) nil) (t (or (car lst) (find-first-non-nil (cdr lst))))))
latch-stobjs1function
(defun latch-stobjs1 (stobjs-out vals latches) (cond ((endp stobjs-out) latches) ((and (car stobjs-out) (not (eq (car stobjs-out) :df))) (let ((temp (assoc-eq (car stobjs-out) latches))) (cond ((not temp) (er hard! 'latch-stobjs "We are trying to latch a value for the single-threaded ~ object named ~x0, but there is no entry for that name in ~ the stobj latches provided. The possible latch names are ~ ~&1.~#2~[~/ This error most likely is caused by the ~ attempt to ev a form that is not ``supposed'' to mention ~ stobjs but does. Often when dealing with forms that are ~ not supposed to mention stobjs we call ev with last ~ argument NIL and then ignore the resulting latches.~]" (car stobjs-out) (strip-cars latches) (if latches 0 1))) ((eq (cdr temp) (car vals)) (latch-stobjs1 (cdr stobjs-out) (cdr vals) latches)) (t (latch-stobjs1 (cdr stobjs-out) (cdr vals) (put-assoc-eq (car stobjs-out) (car vals) latches)))))) (t (latch-stobjs1 (cdr stobjs-out) (cdr vals) latches))))
latch-stobjsfunction
(defun latch-stobjs (stobjs-out vals latches) (cond ((null latches) latches) ((null stobjs-out) latches) ((null (cdr stobjs-out)) (cond ((and (car stobjs-out) (not (eq (car stobjs-out) :df))) (latch-stobjs1 stobjs-out (list vals) latches)) (t latches))) (t (latch-stobjs1 stobjs-out vals latches))))
actual-stobjs-out1function
(defun actual-stobjs-out1 (stobjs-in arg-exprs) (declare (xargs :guard (and (symbol-listp stobjs-in) (true-listp arg-exprs) (= (length stobjs-in) (length arg-exprs))))) (cond ((endp stobjs-in) (assert$ (null arg-exprs) nil)) (t (cond ((or (null (car stobjs-in)) (eq (car stobjs-in) :df) (eq (car stobjs-in) 'state) (eq (car stobjs-in) (car arg-exprs))) (actual-stobjs-out1 (cdr stobjs-in) (cdr arg-exprs))) (t (acons (car stobjs-in) (car arg-exprs) (actual-stobjs-out1 (cdr stobjs-in) (cdr arg-exprs))))))))
apply-symbol-alistfunction
(defun apply-symbol-alist (alist lst acc) (cond ((endp lst) (reverse acc)) (t (apply-symbol-alist alist (cdr lst) (cons (let ((pair (assoc-eq (car lst) alist))) (cond (pair (cdr pair)) (t (car lst)))) acc)))))
apply-inverse-symbol-alistfunction
(defun apply-inverse-symbol-alist (alist lst acc) (cond ((endp lst) (reverse acc)) (t (apply-inverse-symbol-alist alist (cdr lst) (cons (let ((pair (rassoc-eq (car lst) alist))) (cond (pair (car pair)) (t (car lst)))) acc)))))
*for-loop$-keyword-info*constant
(defconst *for-loop$-keyword-info* '((sum sum$ sum$+ acl2-numberp) (always always$ always$+ t) (thereis thereis$ thereis$+ t) (collect collect$ collect$+ t) (append append$ append$+ true-listp) (nil until$ until$+ t) (nil when$ when$+ t)))
*loop$-special-function-symbols*constant
(defconst *loop$-special-function-symbols* '(sum$ sum$+ always$ always$+ thereis$ thereis$+ collect$ collect$+ append$ append$+ until$ until$+ when$ when$+ loop$-as tails from-to-by do$))
loop$-scion-style1function
(defun loop$-scion-style1 (fn alist) (cond ((endp alist) nil) ((eq (cadr (car alist)) fn) :plain) ((eq (caddr (car alist)) fn) :fancy) (t (loop$-scion-style1 fn (cdr alist)))))
loop$-scion-stylefunction
(defun loop$-scion-style (fn) (cond ((eq fn 'do$) :do) (t (loop$-scion-style1 fn *for-loop$-keyword-info*))))
loop$-scion-restriction1function
(defun loop$-scion-restriction1 (fn alist) (cond ((endp alist) nil) ((or (eq (cadr (car alist)) fn) (eq (caddr (car alist)) fn)) (if (eq (cadddr (car alist)) t) nil (cadddr (car alist)))) (t (loop$-scion-restriction1 fn (cdr alist)))))
loop$-scion-restrictionfunction
(defun loop$-scion-restriction (fn) (cond ((eq fn 'do$) nil) (t (loop$-scion-restriction1 fn *for-loop$-keyword-info*))))
make-cartonfunction
(defun make-carton (uguard tguard ubody tbody) (cons (cons uguard tguard) (cons ubody tbody)))
excartmacro
(defmacro excart (u/t g/b carton) (declare (xargs :guard (and (or (eq u/t :untranslated) (eq u/t :translated)) (or (eq g/b :guard) (eq g/b :body))))) (if (eq g/b :guard) (if (eq u/t :untranslated) `(car (car ,CARTON)) `(cdr (car ,CARTON))) (if (eq u/t :untranslated) `(car (cdr ,CARTON)) `(cdr (cdr ,CARTON)))))
symbol-name-equalfunction
(defun symbol-name-equal (x str) (declare (xargs :guard (stringp str))) (and (symbolp x) (equal (symbol-name x) str)))
assoc-symbol-name-equalfunction
(defun assoc-symbol-name-equal (sym alist) (declare (xargs :guard (and (symbolp sym) (symbol-alistp alist)))) (cond ((endp alist) nil) ((symbol-name-equal sym (symbol-name (caar alist))) (car alist)) (t (assoc-symbol-name-equal sym (cdr alist)))))
parse-loop$-accumfunction
(defun parse-loop$-accum (stmt args ans) (case-match args ((op ':guard gexpr expr) (cond ((and (symbolp op) (not (null op)) (assoc-symbol-name-equal op *for-loop$-keyword-info*)) (mv nil (cons (make-carton gexpr nil expr nil) (cons (car (assoc-symbol-name-equal op *for-loop$-keyword-info*)) ans)))) (t (mv (msg "Parsing stopped at position ~x0, where we read ~x1 but ~ expected one of the loop$ operators ~*2." (- (length stmt) (length args)) (nth 0 args) (list "" "~x*" "~x* or " "~x*, " (collect-non-x nil (strip-cars *for-loop$-keyword-info*)))) args)))) ((op expr) (cond ((and (symbolp op) (not (null op)) (assoc-symbol-name-equal op *for-loop$-keyword-info*) (not (eq expr :guard))) (mv nil (cons (make-carton t *t* expr nil) (cons (car (assoc-symbol-name-equal op *for-loop$-keyword-info*)) ans)))) ((and (symbolp op) (not (null op)) (assoc-symbol-name-equal op *for-loop$-keyword-info*) (eq expr :guard)) (mv (msg "Parsing stopped at position ~x0, where we read :GUARD but ~ expected it to be followed by a guard test and loop$ body. ~ If you really want :GUARD to be the loop$ body write ':GUARD ~ instead." (+ 1 (- (length stmt) (length args)))) args)) (t (mv (msg "Parsing stopped at position ~x0, where we read ~x1 but ~ expected to see one of the loop$ operators ~*2." (- (length stmt) (length args)) (nth 0 args) (list "" "~x*" "~x* or " "~x*, " (collect-non-x nil (strip-cars *for-loop$-keyword-info*)))) args)))) (& (cond ((and (symbolp (car args)) (not (null (car args))) (assoc-symbol-name-equal (car args) *for-loop$-keyword-info*)) (cond ((and (eq (cadr args) :guard) (null (cddr args))) (mv (msg "Parsing stopped at position ~x0, where we read :GUARD ~ but expected a loop$ body expression. If you want the ~ body to be :GUARD, use ':GUARD instead. The bare keyword ~ :GUARD here must be followed by a guard test and a loop$ ~ body expression." (+ 1 (- (length stmt) (length args)))) args)) (t (mv (msg "Parsing stopped just after position ~x0, where we read ~ ~x1 while expecting it to be followed by either a ~ single loop$ body expression or the keyword :GUARD ~ followed by a guard test and a loop$ body expression. ~ But your loop$ has ``... ~*2)''." (- (length stmt) (length args)) (car args) (list "" "~x*" "~x* " "~x* " args)) args)))) ((car ans) (mv (msg "Parsing stopped at position ~x0, where we ~#1~[ran off the ~ end of the loop$ statement~/read ~x2 but expected one of ~ the loop$ operators ~*3~]." (- (length stmt) (length args)) (if (null args) 0 1) (car args) (list "" "~x*" "~x* or " "~x*, " (collect-non-x nil (strip-cars *for-loop$-keyword-info*)))) args)) (t (mv (msg "Parsing stopped at position ~x0, where we ~#1~[ran off the ~ end of the loop$ statement~/read ~x2 but expected WHEN or ~ one of the loop$ operators ~*3~]." (- (length stmt) (length args)) (if (null args) 0 1) (car args) (list "" "~x*" "~x* or " "~x*, " (collect-non-x nil (strip-cars *for-loop$-keyword-info*)))) args))))))
possible-typopfunction
(defun possible-typop (lst1 lst2) (cond ((endp lst1) (or (endp lst2) (endp (cdr lst2)))) ((endp lst2) (endp (cdr lst1))) ((eql (car lst1) (car lst2)) (possible-typop (cdr lst1) (cdr lst2))) (t (or (equal (cdr lst1) lst2) (equal lst1 (cdr lst2)) (equal (cdr lst1) (cdr lst2)) (and (eql (car lst1) (cadr lst2)) (eql (cadr lst1) (car lst2)) (equal (cddr lst1) (cddr lst2)))))))
maybe-meant-but-didnt-writefunction
(defun maybe-meant-but-didnt-write (written intended) (and (symbolp written) (symbolp intended) (not (eq written intended)) (or (equal (symbol-name written) (symbol-name intended)) (possible-typop (coerce (symbol-name written) 'list) (coerce (symbol-name intended) 'list)))))
parse-loop$-whenfunction
(defun parse-loop$-when (stmt args ans) (case-match args (((quote~ when) ':guard gtest test . rest) (parse-loop$-accum stmt rest (cons (make-carton gtest nil test nil) ans))) (((quote~ when) test . rest) (cond ((eq test :guard) (mv (msg "Parsing stopped at position ~x0, where we read :GUARD as the ~ WHEN test. We prohibit this. If you really want to use ~ :GUARD as the WHEN test then write ':GUARD instead, but we ~ see no reason to use this idiom at all! In addition, this ~ loop$ statement ends without specifying an accumulator loop$ ~ body." (+ 1 (- (length stmt) (length args)))) args)) (t (mv-let (msg ans1) (parse-loop$-accum stmt rest (cons (make-carton t *t* test nil) ans)) (cond (msg (cond ((eq (cadr args) :guard) (mv (msg "Parsing stopped at position ~x0, where we read ~ :GUARD but expected it to be followed by an ~ expression but the statement ends prematurely. No ~ WHEN test, loop$ accumulator, or loop$ body is ~ provided!" (+ 1 (- (length stmt) (length args)))) ans1)) ((maybe-meant-but-didnt-write test :guard) (mv (msg "~@0~%~%This error might be due to an earlier problem ~ with the purported loop$ statement. You wrote ``... ~ WHEN ~x1 ...'' and perhaps you meant ``... WHEN ~ :GUARD ...''. Given what you actually wrote, ~x1 is ~ being parsed as the (unguarded) WHEN term." msg (cadr args)) ans1)) (t (mv msg ans1)))) (t (mv msg ans1))))))) (& (mv-let (msg ans1) (parse-loop$-accum stmt args (cons nil ans)) (cond (msg (cond ((and (eq (car args) 'when) (maybe-meant-but-didnt-write (cadr args) :guard)) (mv (msg "~@0~%~%This error might be due to an earlier problem ~ with the purported loop$ statement. You wrote ``... ~ WHEN ~x1 ...'' and perhaps you meant ``... WHEN :GUARD ~ ...''. Given what you actually wrote, ~x1 is being ~ parsed as the (unguarded) WHEN term." msg (cadr args)) ans1)) ((maybe-meant-but-didnt-write (car args) 'when) (mv (msg "~@0~%~%This error might be due to an earlier ~ problem with the purported loop$ statement. You ~ wrote ``... ~x1 ...'' and perhaps you meant ``... ~ WHEN ...''." msg (car args)) ans1)) (t (mv msg ans1)))) (t (mv msg ans1)))))))
parse-loop$-untilfunction
(defun parse-loop$-until (stmt args ans) (case-match args (((quote~ until) ':guard gtest test . rest) (parse-loop$-when stmt rest (cons (make-carton gtest nil test nil) ans))) (((quote~ until) test . rest) (cond ((eq test :guard) (mv (msg "Parsing stopped at position ~x0, where we read :GUARD as the ~ UNTIL test. We prohibit this. If you really want to use ~ :GUARD as the UNTIL test then write ':GUARD instead, but we ~ see no reason to use this idiom at all! In addition, this ~ loop$ statement ends without specifying an accumulator loop$ ~ body." (+ 1 (- (length stmt) (length args)))) args)) (t (mv-let (msg ans1) (parse-loop$-when stmt rest (cons (make-carton t *t* test nil) ans)) (cond (msg (cond ((eq (cadr args) :guard) (mv (msg "Parsing stopped at position ~x0, where we read :GUARD ~ but expected it to be followed by an expression but ~ the statement ends prematurely. No UNTIL test, loop$ ~ accumulator, or loop$ body is provided!" (+ 1 (- (length stmt) (length args)))) ans1)) ((maybe-meant-but-didnt-write test :guard) (mv (msg "~@0~%~%This error might be due to an earlier problem ~ with the purported loop$ statement. You wrote ``... ~ UNTIL ~x1 ...'' and perhaps you meant ``... UNTIL ~ :GUARD ...''. Given what you actually wrote, ~x1 is ~ being parsed as the (unguarded) UNTIL term." msg (cadr args)) ans1)) (t (mv msg ans1)))) (t (mv msg ans1))))))) (& (mv-let (msg ans1) (parse-loop$-when stmt args (cons nil ans)) (cond (msg (cond ((and (eq (car args) 'until) (maybe-meant-but-didnt-write (cadr args) :guard)) (mv (msg "~@0~%~%This error might be due to an earlier problem ~ with the purported loop$ statement. You wrote ``... ~ UNTIL ~x1 ...'' and perhaps you meant ``... UNTIL ~ :GUARD ...''. Given what you actually wrote, ~x1 is ~ being parsed as the (unguarded) UNTIL term." msg (cadr args)) ans1)) ((maybe-meant-but-didnt-write (car args) 'until) (mv (msg "~@0~%~%This error might be due to an earlier ~ problem with the purported loop$ statement. You ~ wrote ``... ~x1 ...'' and perhaps you meant ``... ~ UNTIL ...''." msg (car args)) ans1)) (t (mv msg ans1)))) (t (mv msg ans1)))))))
parse-loop$-vsts-diagnose-failurefunction
(defun parse-loop$-vsts-diagnose-failure (flg1 args args1) (cond ((endp args1) (mv (if flg1 1 0) nil nil)) (t (let ((unusual-var-msg (if (or (member-symbol-name (symbol-name (car args)) '(in on from to by as until when guard)) (and (car args) (assoc-symbol-name-equal (car args) *for-loop$-keyword-info*))) (msg ". The unusual variable name, ~x0, which is a reserved ~ word in loop$ syntax, might indicate that you forgot to ~ specify the iteration variable" (car args)) (msg "")))) (cond (flg1 (mv 2 args1 (cond ((case-match args ((& (quote~ of-type) & (quote~ from) & (quote~ to) & (quote~ by)) t) ((& (quote~ from) & (quote~ to) & (quote~ by)) t) (& nil)) (msg "to read an expression after it, but the statement ends ~ prematurely~@0" unusual-var-msg)) ((and (maybe-meant-but-didnt-write (car args1) 'by) (case-match args ((& (quote~ of-type) & (quote~ from) . &) t) ((& (quote~ from) . &) t) (& nil))) (msg "BY, AS, UNTIL, WHEN, or one of the loop$ operators ~*0~@1" (list "" "~x*" "~x* or " "~x*, " (collect-non-x nil (strip-cars *for-loop$-keyword-info*))) unusual-var-msg)) (t (msg "AS, UNTIL, WHEN, or one of the loop$ operators ~*0~@1" (list "" "~x*" "~x* or " "~x*, " (collect-non-x nil (strip-cars *for-loop$-keyword-info*))) unusual-var-msg))))) (t (cond ((not (or (symbol-name-equal (nth 1 args) "OF-TYPE") (symbol-name-equal (nth 1 args) "IN") (symbol-name-equal (nth 1 args) "ON") (symbol-name-equal (nth 1 args) "FROM"))) (mv 3 (nthcdr 1 args) (cond ((maybe-meant-but-didnt-write (nth 1 args) 'of-type) (msg "OF-TYPE, IN, ON, or FROM~@0" unusual-var-msg)) ((and (maybe-meant-but-didnt-write (nth 1 args) 'in) (maybe-meant-but-didnt-write (nth 1 args) 'on)) (msg "IN, ON, FROM, or OF-TYPE~@0" unusual-var-msg)) ((maybe-meant-but-didnt-write (nth 1 args) 'in) (msg "IN, ON, FROM, or OF-TYPE~@0" unusual-var-msg)) ((maybe-meant-but-didnt-write (nth 1 args) 'on) (msg "ON, IN, FROM, or OF-TYPE~@0" unusual-var-msg)) ((maybe-meant-but-didnt-write (nth 1 args) 'from) (msg "FROM, IN, ON, or OF-TYPE~@0" unusual-var-msg)) (t (msg "OF-TYPE, IN, ON, or FROM~@0" unusual-var-msg))))) ((symbol-name-equal (nth 1 args) "FROM") (mv 3 (nthcdr 3 args) (msg "TO~@0" unusual-var-msg))) ((and (symbol-name-equal (nth 1 args) "OF-TYPE") (not (or (symbol-name-equal (nth 3 args) "IN") (symbol-name-equal (nth 3 args) "ON") (symbol-name-equal (nth 3 args) "FROM")))) (mv 3 (nthcdr 3 args) (cond ((and (maybe-meant-but-didnt-write (nth 3 args) 'in) (maybe-meant-but-didnt-write (nth 3 args) 'on)) (msg "IN, ON, or FROM~@0" unusual-var-msg)) ((maybe-meant-but-didnt-write (nth 3 args) 'in) (msg "IN, ON, or FROM~@0" unusual-var-msg)) ((maybe-meant-but-didnt-write (nth 3 args) 'on) (msg "ON, IN, or FROM~@0" unusual-var-msg)) ((maybe-meant-but-didnt-write (nth 3 args) 'from) (msg "FROM, IN, or ON~@0" unusual-var-msg)) (t (msg "IN, ON, or FROM~@0" unusual-var-msg))))) ((symbol-name-equal (nth 1 args) "FROM") (mv 3 (nthcdr 3 args) (msg "TO~@0" unusual-var-msg))) (t (mv 3 (nthcdr 1 args) (msg "OF-TYPE, IN, OR, or FROM~0@" unusual-var-msg))))))))))
parse-loop$-vstsfunction
(defun parse-loop$-vsts (stmt args vsts ans) (mv-let (flg1 args1 vsts1) (case-match args ((v (quote~ of-type) spec (quote~ in) lst . rest) (mv t rest (cons `(,V ,SPEC (in ,LST)) vsts))) ((v (quote~ of-type) spec (quote~ on) lst . rest) (mv t rest (cons `(,V ,SPEC (on ,LST)) vsts))) ((v (quote~ of-type) spec (quote~ from) i (quote~ to) j (quote~ by) k . rest) (mv t rest (cons `(,V ,SPEC (from-to-by ,I ,J ,K)) vsts))) ((v (quote~ of-type) spec (quote~ from) i (quote~ to) j . rest) (mv t rest (cons `(,V ,SPEC (from-to-by ,I ,J 1)) vsts))) ((v (quote~ in) lst . rest) (mv t rest (cons `(,V t (in ,LST)) vsts))) ((v (quote~ on) lst . rest) (mv t rest (cons `(,V t (on ,LST)) vsts))) ((v (quote~ from) i (quote~ to) j (quote~ by) k . rest) (mv t rest (cons `(,V t (from-to-by ,I ,J ,K)) vsts))) ((v (quote~ from) i (quote~ to) j . rest) (mv t rest (cons `(,V t (from-to-by ,I ,J 1)) vsts))) (& (mv nil args vsts))) (cond ((and flg1 (consp args1) (car args1) (symbolp (car args1)) (or (symbol-name-equal (car args1) "AS") (symbol-name-equal (car args1) "UNTIL") (symbol-name-equal (car args1) "WHEN") (assoc-symbol-name-equal (car args1) *for-loop$-keyword-info*))) (cond ((and (consp args1) (symbol-name-equal (car args1) "AS")) (parse-loop$-vsts stmt (cdr args1) vsts1 ans)) (t (parse-loop$-until stmt args1 (cons (revappend vsts1 nil) ans))))) (t (mv-let (failure-type tail expected-msg) (parse-loop$-vsts-diagnose-failure flg1 args args1) (cond ((or (eql failure-type 0) (eql failure-type 1)) (mv (msg "Parsing stopped at position ~x0, where the loop$ ~ statement ends prematurely. No loop$ accumulator ~ or body was provided." (length stmt)) args)) (t (mv (msg "Parsing stopped at position ~x0, where we read ~ ~x1 but expected ~@2." (- (length stmt) (length tail)) (car tail) expected-msg) args))))))))
parse-loop$-finallyfunction
(defun parse-loop$-finally (stmt args) (mv-let (flg1 ans1) (case-match args (((quote~ finally) ':guard guard-term finally-body) (cond ((or (atom guard-term) (atom finally-body)) (mv nil nil)) (t (mv t (make-carton guard-term nil finally-body nil))))) (((quote~ finally) finally-body) (cond ((atom finally-body) (mv nil nil)) (t (mv t (make-carton t *t* finally-body nil))))) (& (mv nil nil))) (cond (flg1 (mv nil ans1)) (t (mv (msg "Parsing stopped at position ~x0 where we saw an ill-formed ~ FINALLY clause. A well-formed finally clause starts with ~ the symbol FINALLY (optionally followed by :GUARD and a ~ non-atomic term) followed by the non-atomic body of the ~ finally clause. The body of the finally clause must be the ~ last element of the LOOP$ statement." (- (length stmt) (length args))) nil)))))
parse-do$-keywords-and-bodyfunction
(defun parse-do$-keywords-and-body (args measure guard values) (cond ((atom args) (mv t args nil nil nil)) (t (case (car args) (:measure (cond ((or measure (atom (cadr args)) (atom (cdr args))) (mv t args nil nil nil)) (t (parse-do$-keywords-and-body (cddr args) (cadr args) guard values)))) (:guard (cond ((or guard (atom (cadr args)) (atom (cdr args))) (mv t args nil nil nil)) (t (parse-do$-keywords-and-body (cddr args) measure (cadr args) values)))) (:values (cond ((or values (atom (cdr args)) (atom (cadr args)) (not (true-listp (cadr args)))) (mv t args nil nil nil)) (t (parse-do$-keywords-and-body (cddr args) measure guard (cadr args))))) (otherwise (cond ((or (atom args) (atom (car args))) (mv t args nil nil nil)) (t (mv nil (cdr args) measure values (if guard (make-carton guard nil (car args) nil) (make-carton t *t* (car args) nil))))))))))
parse-do$function
(defun parse-do$ (stmt args tuples) (mv-let (erp args1 measure values do-body-carton) (parse-do$-keywords-and-body args nil nil nil) (cond (erp (mv (msg "Parsing stopped at position ~x0 where we found an ~ ill-formed DO clause. A well-formed DO-clause starts ~ with the symbol DO followed by a non-atomic body form. ~ Separating the DO and its body may be the keywords ~ :MEASURE, :GUARD, and/or :VALUES, each occurring at most ~ once and followed by a non-atomic term." (- (length stmt) (length args1))) nil)) (t (mv-let (msg fin-body-carton) (cond ((null args1) (mv nil (make-carton t *t* nil *nil*))) (t (parse-loop$-finally stmt args1))) (cond (msg (mv msg fin-body-carton)) (t (mv nil (list tuples measure values do-body-carton fin-body-carton args1)))))))))
first-unusual-with-clausefunction
(defun first-unusual-with-clause (alist) (cond ((endp alist) (mv nil nil)) ((member-eq (car (car alist)) '(of-type = with do)) (mv 0 (car (car alist)))) ((member-eq (cadr (car alist)) '(of-type = with do)) (mv 1 (cons (car (car alist)) (cadr (car alist))))) ((and (caddr (car alist)) (member-eq (cadddr (car alist)) '(of-type = with do))) (mv 2 (cons (car (car alist)) (cadddr (car alist))))) (t (first-unusual-with-clause (cdr alist)))))
parse-loop$-withfunction
(defun parse-loop$-with (stmt args tuples) (mv-let (flg1 args1 tuples1) (case-match args (((quote~ with) var (quote~ of-type) spec (quote~ =) val . rest) (mv t rest (cons (list var spec t val) tuples))) (((quote~ with) var (quote~ of-type) spec . rest) (mv t rest (cons (list var spec nil nil) tuples))) (((quote~ with) var (quote~ =) val . rest) (mv t rest (cons (list var t t val) tuples))) (((quote~ with) var . rest) (mv t rest (cons (list var t nil nil) tuples))) (((quote~ do) . &) (mv t args tuples)) (& (mv nil args tuples))) (cond ((and flg1 (consp args1) (or (symbol-name-equal (car args1) "WITH") (symbol-name-equal (car args1) "DO"))) (cond ((symbol-name-equal (car args1) "WITH") (parse-loop$-with stmt args1 tuples1)) (t (parse-do$ stmt (cdr args1) (revappend tuples1 nil))))) (t (mv-let (unusual-withp culprit) (first-unusual-with-clause tuples1) (mv (msg "Parsing stopped at position ~x0 where ~#1~[the loop$ ~ statement ends prematurely.~/we read ~x2 but sort of ~ expected OF-TYPE, =, WITH, or DO.~] ~#3~[~/However, this ~ might be due to an earlier typo. For example, it is odd ~ to see ~#4~[~x5 used as a local variable name~/the ~ variable ~x5 declared to be OF-TYPE ~x6~/the variable ~x5 ~ initialized to the value of the term ~x6~] in a WITH ~ clause!~]" (- (length stmt) (length args1)) (if (endp args1) 0 1) (if (endp args1) nil (car args1)) (if unusual-withp 1 0) unusual-withp (if (equal unusual-withp 0) culprit (car culprit)) (if (equal unusual-withp 0) nil (cdr culprit))) args))))))
parse-loop$function
(defun parse-loop$ (stmt) (cond ((and (consp stmt) (eq (car stmt) 'loop$) (consp (cdr stmt)) (symbol-name-equal (cadr stmt) "FOR")) (mv-let (msg ans) (parse-loop$-vsts stmt (cddr stmt) nil nil) (cond (msg (mv t (msg "Illegal LOOP$ Syntax. The form ~X01 cannot be parsed ~ as a LOOP$ statement. ~@2" stmt nil msg))) (t (mv nil (cons 'for (revappend ans nil))))))) ((and (consp stmt) (eq (car stmt) 'loop$) (consp (cdr stmt)) (or (symbol-name-equal (cadr stmt) "WITH") (symbol-name-equal (cadr stmt) "DO"))) (mv-let (msg ans) (parse-loop$-with stmt (cdr stmt) nil) (cond (msg (mv t (msg "Illegal LOOP$ Syntax. The form ~X01 cannot be parsed ~ as a LOOP$ statement. ~@2" stmt nil msg))) (t (mv nil (cons 'do ans)))))) (t (mv t (msg "Illegal LOOP$ Syntax. The form ~X01 cannot be parsed as a ~ LOOP$ statement. One of the symbols FOR, WITH, or DO must ~ immediately follow the LOOP$ and it does not here." stmt nil)))))
unknown-stobj-namesfunction
(defun unknown-stobj-names (lst known-stobjs wrld) (declare (xargs :guard (and (true-listp lst) (or (eq known-stobjs t) (true-listp known-stobjs)) (plist-worldp wrld)))) (cond ((endp lst) nil) ((stobjp (car lst) known-stobjs wrld) (unknown-stobj-names (cdr lst) known-stobjs wrld)) (t (cons (car lst) (unknown-stobj-names (cdr lst) known-stobjs wrld)))))
do$-stobjs-outfunction
(defun do$-stobjs-out (arg-exprs) (let* ((quoted-dolia (car (last arg-exprs))) (loop$-expr (and (quotep quoted-dolia) (access dolia (unquote quoted-dolia) :untrans-do-loop$)))) (mv-let (erp parse) (if (and (true-listp loop$-expr) (eq (car loop$-expr) 'loop$)) (parse-loop$ loop$-expr) (mv t nil)) (cond ((or erp (not (eq (car parse) 'do))) (er hard! 'do$-stobjs-out "Implementation error: Unexpected failure to parse loop$ ~ expression from last argument of a call of do$, ~x0." (cons 'do$ arg-exprs))) (t (let ((values (nth 3 parse))) (cond ((null values) '(nil)) (t values))))))))
actual-stobjs-outfunction
(defun actual-stobjs-out (fn arg-exprs wrld) (declare (xargs :guard (and (symbolp fn) (or (eq fn 'do$) (not (member-eq fn *stobjs-out-invalid*))) (true-listp arg-exprs) (plist-worldp wrld)))) (cond ((eq fn 'do$) (do$-stobjs-out arg-exprs)) ((eq fn 'read-user-stobj-alist) (cond ((and (= (length arg-exprs) 2) (eq (cadr arg-exprs) 'state) (quotep (car arg-exprs)) (symbolp (unquote (car arg-exprs))) (stobjp (unquote (car arg-exprs)) t wrld)) (list (unquote (car arg-exprs)))) (t (er hard 'actual-stobjs-out "Unable to determine stobjs-out for application of ~x0 to ~ translate arguments ~x1." fn arg-exprs)))) (t (let ((stobjs-out (stobjs-out fn wrld))) (cond ((all-nils-or-dfs stobjs-out) stobjs-out) (t (let ((stobjs-in (stobjs-in fn wrld))) (let ((alist (actual-stobjs-out1 stobjs-in arg-exprs))) (cond (alist (apply-symbol-alist alist stobjs-out nil)) (t stobjs-out))))))))))
translated-acl2-unwind-protectp4function
(defun translated-acl2-unwind-protectp4 (term) (case-match term ((('lambda (mv . vars) (('lambda ('acl2-unwind-protect-erp 'acl2-unwind-protect-val 'state . vars) ('if 'acl2-unwind-protect-erp ('(lambda (state acl2-unwind-protect-val acl2-unwind-protect-erp) (cons acl2-unwind-protect-erp (cons acl2-unwind-protect-val (cons state 'nil)))) cleanup1 'acl2-unwind-protect-val 'acl2-unwind-protect-erp) ('(lambda (state acl2-unwind-protect-val acl2-unwind-protect-erp) (cons acl2-unwind-protect-erp (cons acl2-unwind-protect-val (cons state 'nil)))) cleanup2 'acl2-unwind-protect-val 'acl2-unwind-protect-erp))) '(mv-nth '0 mv) '(mv-nth '1 mv) '(mv-nth '2 mv) . vars)) body . vars) (declare (ignore mv vars)) (mv t body cleanup1 cleanup2)) ((('lambda (mv . vars) (('lambda ('acl2-unwind-protect-erp 'acl2-unwind-protect-val 'state . vars) ('(lambda (state acl2-unwind-protect-val acl2-unwind-protect-erp) (cons acl2-unwind-protect-erp (cons acl2-unwind-protect-val (cons state 'nil)))) cleanup1 'acl2-unwind-protect-val 'acl2-unwind-protect-erp)) '(mv-nth '0 mv) '(mv-nth '1 mv) '(mv-nth '2 mv) . vars)) body . vars) (declare (ignore mv vars)) (mv t body cleanup1 cleanup1)) (& (mv nil nil nil nil))))
translated-acl2-unwind-protectpfunction
(defun translated-acl2-unwind-protectp (term) (mv-let (ans body cleanup1 cleanup2) (translated-acl2-unwind-protectp4 term) (declare (ignore body cleanup1 cleanup2)) ans))
acl2-system-namepfunction
(defun acl2-system-namep (name wrld) (declare (xargs :guard (and (symbolp name) (plist-worldp wrld)))) (cond ((global-val 'boot-strap-flg wrld) t) (t (getpropc name 'predefined nil wrld))))
acl2-system-namep-statefunction
(defun acl2-system-namep-state (name state) (cond ((f-get-global 'boot-strap-flg state) t) (t (getpropc name 'predefined))))
encapsulate
(encapsulate (((big-n) => *) ((decrement-big-n *) => *) ((zp-big-n *) => *)) (logic) (local (defun big-n nil 0)) (local (defun decrement-big-n (n) (declare (ignore n)) 0)) (local (defun zp-big-n (n) (declare (ignore n)) nil)))
w-of-any-statefunction
(defun w-of-any-state (st) (cdr (assoc 'current-acl2-world (global-table st))))
untranslate-preprocess-fnfunction
(defun untranslate-preprocess-fn (wrld) (declare (xargs :guard (plist-worldp wrld))) (cdr (assoc-eq 'untranslate-preprocess (table-alist 'user-defined-functions-table wrld))))
untranslate*macro
(defmacro untranslate* (term iff-flg wrld) (declare (xargs :guard (symbolp wrld))) `(untranslate1 ,TERM ,IFF-FLG (untrans-table ,WRLD) (untranslate-preprocess-fn ,WRLD) ,WRLD))
save-ev-fncall-guard-erfunction
(defun save-ev-fncall-guard-er (fn guard stobjs-in args w) (wormhole-eval 'ev-fncall-guard-er-wormhole '(lambda nil (make-wormhole-status nil :enter (list fn guard stobjs-in args w))) nil))
other
(defrec attachment ((g . ext-succ) components . pairs) nil)
other
(defrec attachment-component ((ext-anc . ord-anc) . path) nil)
attachment-record-pairsfunction
(defun attachment-record-pairs (records acc) (cond ((endp records) acc) (t (attachment-record-pairs (cdr records) (append (access attachment (car records) :pairs) acc)))))
all-attachmentsfunction
(defun all-attachments (wrld) (attachment-record-pairs (global-val 'attachment-records wrld) nil))
gc-off1function
(defun gc-off1 (guard-checking-on) (or (eq guard-checking-on nil) (eq guard-checking-on :none)))
gc-offfunction
(defun gc-off (state) (gc-off1 (f-get-global 'guard-checking-on state)))
return-last-lookupfunction
(defun return-last-lookup (sym wrld) (assert$ (and (symbolp sym) sym) (case sym (progn 'prog2$) (mbe1-raw 'mbe1) (ec-call1-raw 'ec-call1) (with-guard-checking1-raw 'with-guard-checking1) (otherwise (cdr (assoc-eq sym (table-alist 'return-last-table wrld)))))))
add-ignore-to-restfunction
(defun add-ignore-to-rest (var rest) (case-match rest ((('declare ('ignore . vars)) . rest2) (cons `(declare (ignore ,@VARS ,VAR)) rest2)) (& (cons `(declare (ignore ,VAR)) rest))))
add-type-dcls-to-restfunction
(defun add-type-dcls-to-rest (type-dcls rest) (cond ((null type-dcls) rest) (t (case-match rest ((('declare . dcls) . rest2) (cons `(declare ,@DCLS ,@TYPE-DCLS) rest2)) (& (cons `(declare ,@TYPE-DCLS) rest))))))
collect-ignored-let-varsfunction
(defun collect-ignored-let-vars (bindings) (cond ((endp bindings) (mv nil nil)) (t (mv-let (bs is) (collect-ignored-let-vars (cdr bindings)) (let ((b (car bindings))) (case-match b ((v ('hide e)) (mv (cons (list v e) bs) (cons v is))) (& (mv (cons b bs) is))))))))
make-let-or-let*function
(defun make-let-or-let* (bindings type-dcls body) (declare (xargs :guard (doublet-listp bindings))) (cond ((and bindings (null (cdr bindings))) (let ((binding (car bindings))) (mv-let (b0 i0) (case-match binding ((v0 ('hide e0)) (mv (list v0 e0) v0)) (& (mv binding nil))) (case-match body (('let ((& &)) . x) (let ((x (add-type-dcls-to-rest type-dcls x))) `(let* (,B0 ,@(CADR BODY)) ,@(IF I0 (ADD-IGNORE-TO-REST I0 X) X)))) (('let* rest-bindings . x) (let ((x (add-type-dcls-to-rest type-dcls x))) `(let* ,(CONS B0 REST-BINDINGS) ,@(IF I0 (ADD-IGNORE-TO-REST I0 X) X)))) (& (cond (i0 (let ((ignores (list i0))) (make-let (list b0) ignores type-dcls body))) (t (make-let bindings nil type-dcls body)))))))) (t (mv-let (bs is) (collect-ignored-let-vars bindings) (make-let bs is type-dcls body)))))
untranslate*-lstmacro
(defmacro untranslate*-lst (lst iff-flg wrld) (declare (xargs :guard (symbolp wrld))) `(untranslate1-lst ,LST ,IFF-FLG (untrans-table ,WRLD) (untranslate-preprocess-fn ,WRLD) ,WRLD))
live-state-symbolpfunction
(defun live-state-symbolp (x) (declare (xargs :guard t)) (and (symbolp x) (equal (symbol-package-name x) "ACL2_INVISIBLE") (equal (symbol-name x) "The Live State Itself")))
apply-user-stobj-alist-or-kwotefunction
(defun apply-user-stobj-alist-or-kwote (user-stobj-alist lst acc) (cond ((endp lst) (reverse acc)) (t (apply-user-stobj-alist-or-kwote user-stobj-alist (cdr lst) (cons (cond ((live-state-symbolp (car lst)) 'state) ((bad-atom (car lst)) (let ((pair (rassoc-eq (car lst) user-stobj-alist))) (cond (pair (car pair)) (t '|<some-stobj>|)))) (t (kwote (car lst)))) acc)))))
signature-fnsfunction
(defun signature-fns (signatures) (cond ((endp signatures) nil) ((consp (car (car signatures))) (cons (car (car (car signatures))) (signature-fns (cdr signatures)))) (t (cons (car (car signatures)) (signature-fns (cdr signatures))))))
make-event-tuplefunction
(defun make-event-tuple (n d form ev-type namex symbol-class skipped-proofs-p local-p) (let ((x (cons (if (= d 0) n (cons n d)) (if (and (eq symbol-class :program) (consp form) (or (eq (car form) ev-type) (and (eq ev-type 'defuns) (eq (car form) 'mutual-recursion))) (equal namex (case (car form) (defuns (strip-cars (cdr form))) (mutual-recursion (strip-cadrs (cdr form))) ((verify-guards in-theory in-arithmetic-theory regenerate-tau-database push-untouchable remove-untouchable reset-prehistory set-body table) 0) (encapsulate (signature-fns (cadr form))) (otherwise (cadr form))))) form (cons (cons (cons ev-type (and (not (eq symbol-class :program)) skipped-proofs-p)) (cons namex symbol-class)) form))))) (if local-p `(local . ,X) x)))
remove-localother
(defabbrev remove-local (x) (if (eq (car x) 'local) (cdr x) x))
access-event-tuple-local-pfunction
(defun access-event-tuple-local-p (x) (eq (car x) 'local))
access-event-tuple-numberfunction
(defun access-event-tuple-number (x) (let ((x (remove-local x))) (if (integerp (car x)) (car x) (caar x))))
access-event-tuple-depthfunction
(defun access-event-tuple-depth (x) (let ((x (remove-local x))) (if (integerp (car x)) 0 (cdar x))))
access-event-tuple-typefunction
(defun access-event-tuple-type (x) (let ((x (remove-local x))) (cond ((symbolp (cdr x)) nil) ((symbolp (cadr x)) (if (eq (cadr x) 'mutual-recursion) 'defuns (cadr x))) (t (caaadr x)))))
access-event-tuple-skipped-proofs-pfunction
(defun access-event-tuple-skipped-proofs-p (x) (let ((x (remove-local x))) (cond ((symbolp (cdr x)) nil) ((symbolp (cadr x)) nil) (t (cdaadr x)))))
access-event-tuple-namexfunction
(defun access-event-tuple-namex (x) (let ((x (remove-local x))) (cond ((symbolp (cdr x)) nil) ((symbolp (cadr x)) (case (cadr x) (defuns (strip-cars (cddr x))) (mutual-recursion (strip-cadrs (cddr x))) ((verify-guards in-theory in-arithmetic-theory regenerate-tau-database push-untouchable remove-untouchable reset-prehistory set-body table) 0) (encapsulate (signature-fns (caddr x))) (t (caddr x)))) (t (cadadr x)))))
access-event-tuple-formfunction
(defun access-event-tuple-form (x) (let ((x (remove-local x))) (if (symbolp (cadr x)) (cdr x) (cddr x))))
access-event-tuple-symbol-classfunction
(defun access-event-tuple-symbol-class (x) (let ((x (remove-local x))) (if (symbolp (cadr x)) :program (cddadr x))))
make-command-tuplefunction
(defun make-command-tuple (n defun-mode form cbd last-make-event-expansion) (make command-tuple :number n :defun-mode/form (if (eq defun-mode :program) form (cons defun-mode form)) :cbd cbd :last-make-event-expansion last-make-event-expansion))
access-command-tuple-numberfunction
(defun access-command-tuple-number (x) (declare (xargs :guard (weak-command-tuple-p x))) (access command-tuple x :number))
access-command-tuple-defun-modefunction
(defun access-command-tuple-defun-mode (x) (let ((tmp (access command-tuple x :defun-mode/form))) (if (keywordp (car tmp)) (car tmp) :program)))
access-command-tuple-formfunction
(defun access-command-tuple-form (x) (let ((tmp (access command-tuple x :defun-mode/form))) (if (keywordp (car tmp)) (cdr tmp) tmp)))
safe-access-command-tuple-formfunction
(defun safe-access-command-tuple-form (x) (declare (xargs :guard t)) (let ((tmp (and (consp x) (consp (cdr x)) (access command-tuple x :defun-mode/form)))) (if (and (consp tmp) (keywordp (car tmp))) (cdr tmp) tmp)))
access-command-tuple-last-make-event-expansionfunction
(defun access-command-tuple-last-make-event-expansion (x) (access command-tuple x :last-make-event-expansion))
access-command-tuple-cbdfunction
(defun access-command-tuple-cbd (x) (access command-tuple x :cbd))
max-absolute-event-numberfunction
(defun max-absolute-event-number (wrld) (access-event-tuple-number (global-val 'event-landmark wrld)))
next-absolute-event-numberfunction
(defun next-absolute-event-number (wrld) (1+ (max-absolute-event-number wrld)))
max-absolute-command-numberfunction
(defun max-absolute-command-number (wrld) (access-command-tuple-number (global-val 'command-landmark wrld)))
next-absolute-command-numberfunction
(defun next-absolute-command-number (wrld) (1+ (max-absolute-command-number wrld)))
scan-to-landmark-numberfunction
(defun scan-to-landmark-number (flg n wrld) (declare (xargs :guard (and (natp n) (plist-worldp wrld)))) (cond ((endp wrld) (er hard 'scan-to-landmark-number "We have scanned the world looking for absolute ~ ~#0~[event~/command~] number ~x1 and failed to find it. ~ There are two likely errors. Either ~#0~[an event~/a ~ command~] with that number was never stored or the ~ index has somehow given us a tail in the past rather ~ than the future of the target world." (if (equal flg 'event-landmark) 0 1) n)) ((and (eq (caar wrld) flg) (eq (cadar wrld) 'global-value) (= n (if (eq flg 'event-landmark) (access-event-tuple-number (cddar wrld)) (access-command-tuple-number (cddar wrld))))) wrld) (t (scan-to-landmark-number flg n (cdr wrld)))))
add-to-zap-tablefunction
(defun add-to-zap-table (val zt) (cond ((null zt) (list 0 val)) (t (cons (1+ (car zt)) (cons val (cdr zt))))))
fetch-from-zap-tablefunction
(defun fetch-from-zap-table (n zt) (cond ((null zt) nil) ((> n (car zt)) nil) (t (nth (- (car zt) n) (cdr zt)))))
*event-index-interval*constant
(defconst *event-index-interval* 10)
*command-index-interval*constant
(defconst *command-index-interval* 10)
lookup-world-index1function
(defun lookup-world-index1 (n interval index wrld) (let ((i (floor (+ n (1- interval)) interval))) (cond ((or (null index) (> i (car index))) wrld) (t (fetch-from-zap-table i index)))))
lookup-world-indexfunction
(defun lookup-world-index (flg n wrld) (cond ((eq flg 'event) (let ((n (min (max-absolute-event-number wrld) (max n 0)))) (scan-to-landmark-number 'event-landmark n (lookup-world-index1 n *event-index-interval* (global-val 'event-index wrld) wrld)))) (t (let ((n (min (max-absolute-command-number wrld) (max n 0)))) (scan-to-landmark-number 'command-landmark n (lookup-world-index1 n *command-index-interval* (global-val 'command-index wrld) wrld))))))
*unspecified-xarg-value*constant
(defconst *unspecified-xarg-value* '(unspecified))
get-unambiguous-xargs-flg1/edcls1function
(defun get-unambiguous-xargs-flg1/edcls1 (key v edcls event-msg) (cond ((null edcls) v) ((eq (caar edcls) 'xargs) (let ((temp (assoc-keyword key (cdar edcls)))) (cond ((null temp) (get-unambiguous-xargs-flg1/edcls1 key v (cdr edcls) event-msg)) ((not (symbolp (cadr temp))) (msg "It is illegal to specify ~x0 to be ~x1. The value must be ~ a symbol." key (cadr temp))) ((or (consp v) (eq v (cadr temp))) (get-unambiguous-xargs-flg1/edcls1 key (cadr temp) (cdr edcls) event-msg)) (t (msg "It is illegal to specify ~x0 ~x1 in one place and ~x2 in ~ another within the same ~@3. The functionality controlled ~ by that flag operates on the entire ~@3." key v (cadr temp) event-msg))))) (t (get-unambiguous-xargs-flg1/edcls1 key v (cdr edcls) event-msg))))
get-unambiguous-xargs-flg1/edclsfunction
(defun get-unambiguous-xargs-flg1/edcls (key v edcls event-msg ctx state) (let ((ans (get-unambiguous-xargs-flg1/edcls1 key v edcls event-msg))) (cond ((or (equal ans *unspecified-xarg-value*) (atom ans)) (value ans)) (t (er soft ctx "~@0" ans)))))
get-unambiguous-xargs-flg1function
(defun get-unambiguous-xargs-flg1 (key lst event-msg ctx state) (cond ((null lst) (value *unspecified-xarg-value*)) (t (er-let* ((v (get-unambiguous-xargs-flg1 key (cdr lst) event-msg ctx state)) (ans (get-unambiguous-xargs-flg1/edcls key v (fourth (car lst)) event-msg ctx state))) (value ans)))))
get-unambiguous-xargs-flgfunction
(defun get-unambiguous-xargs-flg (key lst default ctx state) (let ((event-msg (if (cdr lst) "MUTUAL-RECURSION" "DEFUN event"))) (er-let* ((x (get-unambiguous-xargs-flg1 key lst event-msg ctx state))) (cond ((consp x) (value default)) (t (value x))))))
get-unambiguous-xargs-flg-lstfunction
(defun get-unambiguous-xargs-flg-lst (key lst default ctx state) (cond ((null lst) (value nil)) (t (er-let* ((ans (get-unambiguous-xargs-flg1/edcls key *unspecified-xarg-value* (fourth (car lst)) "DEFUN" ctx state)) (rst (get-unambiguous-xargs-flg-lst key (cdr lst) default ctx state))) (value (cons (if (consp ans) default ans) rst))))))
rev-union-equalfunction
(defun rev-union-equal (x y) (declare (xargs :guard (and (true-listp x) (true-listp y)))) (cond ((endp x) y) ((member-equal (car x) y) (rev-union-equal (cdr x) y)) (t (rev-union-equal (cdr x) (cons (car x) y)))))
translate-declaration-to-guard-gen-var-lstfunction
(defun translate-declaration-to-guard-gen-var-lst (x var-lst tflg wrld) (declare (xargs :guard (and (true-listp var-lst) (plist-worldp wrld)))) (cond ((null var-lst) nil) (t (cons (translate-declaration-to-guard-gen x (car var-lst) tflg wrld) (translate-declaration-to-guard-gen-var-lst x (cdr var-lst) tflg wrld)))))
translate-declaration-to-guard-var-lstfunction
(defun translate-declaration-to-guard-var-lst (x var-lst wrld) (declare (xargs :guard (and (true-listp var-lst) (plist-worldp wrld)))) (translate-declaration-to-guard-gen-var-lst x var-lst nil wrld))
map-predicatefunction
(defun map-predicate (fn lst) (declare (xargs :guard (true-listp lst))) (cond ((endp lst) nil) (t (cons (fcons-term* fn (car lst)) (map-predicate fn (cdr lst))))))
get-guards2function
(defun get-guards2 (edcls targets tflg wrld stobjs-acc dfs-acc guards-acc) (cond ((null edcls) (revappend stobjs-acc (revappend dfs-acc (reverse guards-acc)))) ((and (eq (caar edcls) 'xargs) (member-eq 'guards targets)) (let* ((temp1 (assoc-keyword :guard (cdar edcls))) (guard-conjuncts (if temp1 (if (and (true-listp (cadr temp1)) (eq (car (cadr temp1)) 'and)) (or (cdr (cadr temp1)) (list t)) (list (cadr temp1))) nil)) (temp2 (and (consp wrld) (assoc-keyword :stobjs (cdar edcls)))) (stobj-conjuncts (if temp2 (stobj-recognizer-terms (cond ((symbol-listp (cadr temp2)) (cadr temp2)) ((and (cadr temp2) (symbolp (cadr temp2))) (list (cadr temp2))) (t nil)) wrld) nil)) (temp3 (assoc-keyword :dfs (cdar edcls))) (df-conjuncts (cond ((null temp3) nil) ((symbol-listp (cadr temp3)) (map-predicate 'dfp (cadr temp3))) ((and (cadr temp3) (symbolp (cadr temp3))) (list (fcons-term* 'dfp (cadr temp3)))) (t nil)))) (get-guards2 (cdr edcls) targets tflg wrld (rev-union-equal stobj-conjuncts stobjs-acc) (rev-union-equal df-conjuncts dfs-acc) (rev-union-equal guard-conjuncts guards-acc)))) ((and (eq (caar edcls) 'type) (member-eq 'types targets)) (get-guards2 (cdr edcls) targets tflg wrld stobjs-acc dfs-acc (rev-union-equal (translate-declaration-to-guard-gen-var-lst (cadr (car edcls)) (cddr (car edcls)) tflg wrld) guards-acc))) (t (get-guards2 (cdr edcls) targets tflg wrld stobjs-acc dfs-acc guards-acc))))
get-guards1function
(defun get-guards1 (edcls targets args name wrld) (let ((conjuncts (get-guards2 edcls targets nil wrld nil nil nil))) (cond ((and (consp wrld) (member-eq 'guards targets) (member-eq 'state args) (not (member-equal '(state-p state) conjuncts)) (not (eq name 'state-p))) (cons (fcons-term* 'state-p 'state) conjuncts)) (t conjuncts))))
get-guardsfunction
(defun get-guards (lst split-types-lst split-types-p wrld) (cond ((null lst) nil) (t (cons (let ((targets (cond (split-types-p (and (car split-types-lst) '(types))) ((car split-types-lst) '(guards)) (t '(guards types))))) (conjoin-untranslated-terms (and targets (get-guards1 (fourth (car lst)) targets (second (car lst)) (first (car lst)) wrld)))) (get-guards (cdr lst) (cdr split-types-lst) split-types-p wrld)))))
dcls-guard-raw-from-deffunction
(defun dcls-guard-raw-from-def (def wrld) (let* ((dcls (append-lst (strip-cdrs (remove-strings (butlast (cddr def) 1))))) (split-types (get-unambiguous-xargs-flg1/edcls1 :split-types *unspecified-xarg-value* dcls "irrelevant-error-string")) (guards (get-guards1 dcls (cond ((or (equal split-types *unspecified-xarg-value*) (eq split-types nil)) '(guards types)) (t (assert$ (eq split-types t) '(guards)))) (cadr def) (car def) wrld)) (guard (cond ((null guards) t) ((null (cdr guards)) (car guards)) (t (cons 'and guards))))) (mv dcls guard)))
get-eventfunction
(defun get-event (name wrld) (let ((index (getpropc name 'absolute-event-number nil wrld))) (and index (access-event-tuple-form (cddr (car (lookup-world-index 'event index wrld)))))))
get-skipped-proofs-pfunction
(defun get-skipped-proofs-p (name wrld) (declare (xargs :mode :program)) (let ((index (getpropc name 'absolute-event-number nil wrld))) (and index (access-event-tuple-skipped-proofs-p (cddr (car (lookup-world-index 'event index wrld)))) (not (getpropc name 'predefined nil wrld)))))
negate-untranslated-formfunction
(defun negate-untranslated-form (x iff-flg) (cond ((and iff-flg (consp x) (eq (car x) 'not)) (assert$ (consp (cdr x)) (cadr x))) (t (list 'not x))))
event-tuple-fn-namesfunction
(defun event-tuple-fn-names (ev-tuple) (case (access-event-tuple-type ev-tuple) ((defun) (list (access-event-tuple-namex ev-tuple))) ((defuns defstobj) (access-event-tuple-namex ev-tuple)) (otherwise nil)))
cltl-def-from-name2function
(defun cltl-def-from-name2 (fn stobj-function axiomatic-p wrld) (cond ((endp wrld) nil) ((and (eq 'cltl-command (caar wrld)) (eq 'global-value (cadar wrld)) (let ((cltl-command-value (cddar wrld))) (assoc-eq fn (if stobj-function (nth (if axiomatic-p 6 4) cltl-command-value) (cdddr cltl-command-value)))))) (t (cltl-def-from-name2 fn stobj-function axiomatic-p (cdr wrld)))))
cltl-def-from-name1function
(defun cltl-def-from-name1 (fn stobj-function axiomatic-p wrld) (and (function-symbolp fn wrld) (let* ((event-number (getpropc (or stobj-function fn) 'absolute-event-number nil wrld)) (wrld (and event-number (lookup-world-index 'event event-number wrld))) (def (and wrld (cltl-def-from-name2 fn stobj-function axiomatic-p wrld)))) (and def (or (null stobj-function) (and (not (member-equal *stobj-inline-declare* def)) (or axiomatic-p (not (getpropc stobj-function 'absstobj-info nil wrld))))) (cons 'defun def)))))
cltl-def-from-namefunction
(defun cltl-def-from-name (fn wrld) (cltl-def-from-name1 fn (getpropc fn 'stobj-function nil wrld) nil wrld))
unmake-true-list-cons-nestfunction
(defun unmake-true-list-cons-nest (formal-args) (declare (xargs :guard (pseudo-termp formal-args))) (cond ((equal formal-args *nil*) nil) ((quotep formal-args) (let ((lst (unquote formal-args))) (if (true-listp lst) (kwote-lst lst) :fail))) ((ffn-symb-p formal-args 'cons) (let ((rest (unmake-true-list-cons-nest (fargn formal-args 2)))) (if (eq rest :fail) :fail (cons (fargn formal-args 1) rest)))) (t :fail)))
unmake-formal-pairlis2function
(defun unmake-formal-pairlis2 (term digits) (case-match term (('pairlis2 ('quote !digits) formal-args) (unmake-true-list-cons-nest formal-args)) (('quote args-alist) (let ((len (length args-alist))) (if (and (<= len (length digits)) (alistp args-alist) (equal (strip-cars args-alist) (take len digits))) (kwote-lst (strip-cdrs args-alist)) :fail))) (('cons ('quote (digit . x)) rest) (if (and (consp digits) (eql digit (car digits))) (let ((y (unmake-formal-pairlis2 rest (cdr digits)))) (if (eq y :fail) :fail (cons (kwote x) y))) :fail)) (('cons ('cons ('quote digit) x) rest) (if (and (consp digits) (eql digit (car digits))) (let ((y (unmake-formal-pairlis2 rest (cdr digits)))) (if (eq y :fail) :fail (cons x y))) :fail)) (& :fail)))
collect-ignored-mv-varsfunction
(defun collect-ignored-mv-vars (mv-var i bound vars/rest mv-nths/rest) (cond ((= i bound) (mv t nil)) (t (mv-let (flg ignored-vars) (collect-ignored-mv-vars mv-var (1+ i) bound (cdr vars/rest) (cdr mv-nths/rest)) (cond ((null flg) (mv nil nil)) (t (let ((next (car mv-nths/rest))) (case-match next (('hide ('mv-nth ('quote !i) !mv-var)) (mv t (cons (car vars/rest) ignored-vars))) (('mv-nth ('quote !i) !mv-var) (mv t ignored-vars)) (& (mv nil nil))))))))))
all-quotepsfunction
(defun all-quoteps (lst) (cond ((null lst) t) (t (and (quotep (car lst)) (all-quoteps (cdr lst))))))
subst-varmutual-recursion
(mutual-recursion (defun subst-var (new old form) (declare (xargs :guard (and (pseudo-termp new) (variablep old) (pseudo-termp form)))) (cond ((variablep form) (cond ((eq form old) new) (t form))) ((fquotep form) form) (t (cons-term (ffn-symb form) (subst-var-lst new old (fargs form)))))) (defun subst-var-lst (new old l) (declare (xargs :guard (and (pseudo-termp new) (variablep old) (pseudo-term-listp l)))) (cond ((endp l) nil) (t (cons (subst-var new old (car l)) (subst-var-lst new old (cdr l)))))))
subst-each-for-varfunction
(defun subst-each-for-var (new-lst old term) (declare (xargs :guard (and (pseudo-term-listp new-lst) (variablep old) (pseudo-termp term)))) (cond ((endp new-lst) nil) (t (cons (subst-var (car new-lst) old term) (subst-each-for-var (cdr new-lst) old term)))))
type-expressions-from-type-specfunction
(defun type-expressions-from-type-spec (x vars wrld) (declare (xargs :guard (and (symbol-listp vars) (or (symbolp wrld) (plist-worldp wrld))))) (cond ((null vars) nil) (t (let ((expr (translate-declaration-to-guard-gen x (car vars) t wrld))) (cond ((null expr) nil) (t (cons expr (subst-each-for-var (cdr vars) (car vars) expr))))))))
syntactically-plausible-lambda-objectp1function
(defun syntactically-plausible-lambda-objectp1 (edcls formals ignores ignorables type-exprs satisfies-exprs guard) (declare (xargs :guard (and (symbol-listp formals) (true-listp satisfies-exprs)))) (cond ((atom edcls) (mv (and (eq edcls nil) (not (and (or (null guard) (equal guard *nil*)) type-exprs))) ignores ignorables type-exprs satisfies-exprs (or guard *t*))) (t (let ((item (car edcls))) (case-match item (('type spec . vars) (cond ((and (true-listp vars) (subsetp-eq vars formals)) (let ((exprs (type-expressions-from-type-spec spec vars nil))) (cond (exprs (syntactically-plausible-lambda-objectp1 (cdr edcls) formals ignores ignorables (revappend exprs type-exprs) (if (and (consp spec) (eq (car spec) 'satisfies)) (add-to-set-equal (list (cadr spec) 'x) satisfies-exprs) satisfies-exprs) guard)) (t (mv nil nil nil nil nil nil))))) (t (mv nil nil nil nil nil nil)))) (('ignore . vars) (cond ((and (true-listp vars) (subsetp-eq vars formals)) (syntactically-plausible-lambda-objectp1 (cdr edcls) formals (revappend vars ignores) ignorables type-exprs satisfies-exprs guard)) (t (mv nil nil nil nil nil nil)))) (('ignorable . vars) (cond ((and (true-listp vars) (subsetp-eq vars formals)) (syntactically-plausible-lambda-objectp1 (cdr edcls) formals ignores (revappend vars ignorables) type-exprs satisfies-exprs guard)) (t (mv nil nil nil nil nil nil)))) (('xargs :guard g :split-types 't) (cond ((null guard) (if (null g) (mv nil nil nil nil nil nil) (syntactically-plausible-lambda-objectp1 (cdr edcls) formals ignores ignorables type-exprs satisfies-exprs g))) (t (mv nil nil nil nil nil nil)))) (& (mv nil nil nil nil nil nil)))))))
flatten-ands-in-litfunction
(defun flatten-ands-in-lit (term) (declare (xargs :guard (pseudo-termp term))) (case-match term (('if t1 t2 t3) (cond ((equal t2 *nil*) (append (flatten-ands-in-lit (dumb-negate-lit t1)) (flatten-ands-in-lit t3))) ((equal t3 *nil*) (append (flatten-ands-in-lit t1) (flatten-ands-in-lit t2))) (t (list term)))) (& (cond ((equal term *t*) nil) (t (list term))))))
flatten-ands-in-lit-lstfunction
(defun flatten-ands-in-lit-lst (x) (declare (xargs :guard (pseudo-term-listp x))) (if (endp x) nil (append (flatten-ands-in-lit (car x)) (flatten-ands-in-lit-lst (cdr x)))))
syntactically-plausible-lambda-objectpmutual-recursion
(mutual-recursion (defun syntactically-plausible-lambda-objectp (gflg x) (case-match x (('lambda formals body) (if (and (arglistp formals) (pseudo-termp body) (let ((used-vars (all-vars body))) (subsetp-eq used-vars formals))) (let ((ans (syntactically-plausible-lambda-objectsp-within gflg body))) (cond ((null ans) nil) ((eq ans t) (list (make splo-extracts-tuple :gflg gflg :satisfies-exprs nil :guard *t* :body body))) (t (cons (make splo-extracts-tuple :gflg gflg :satisfies-exprs nil :guard *t* :body body) ans)))) nil)) (('lambda formals ('declare . edcls) body) (if (arglistp formals) (mv-let (flg ignores ignorables type-exprs satisfies-exprs guard) (syntactically-plausible-lambda-objectp1 edcls formals nil nil nil nil nil) (if (and flg (pseudo-termp guard) (subsetp-equal (flatten-ands-in-lit-lst type-exprs) (flatten-ands-in-lit guard)) (pseudo-termp body) (subsetp-eq (all-vars guard) formals) (let ((used-vars (all-vars body))) (and (subsetp-eq used-vars formals) (not (intersectp-eq used-vars ignores)) (subsetp-eq (set-difference-eq (set-difference-eq formals used-vars) ignores) ignorables)))) (let* ((ans1 (syntactically-plausible-lambda-objectsp-within t guard)) (ans2 (if ans1 (syntactically-plausible-lambda-objectsp-within gflg body) nil))) (cond ((null ans2) nil) ((eq ans1 t) (if (eq ans2 t) (list (make splo-extracts-tuple :gflg gflg :satisfies-exprs satisfies-exprs :guard guard :body body)) (cons (make splo-extracts-tuple :gflg gflg :satisfies-exprs satisfies-exprs :guard guard :body body) ans2))) ((eq ans2 t) (cons (make splo-extracts-tuple :gflg gflg :satisfies-exprs satisfies-exprs :guard guard :body body) ans1)) (t (cons (make splo-extracts-tuple :gflg gflg :satisfies-exprs satisfies-exprs :guard guard :body body) (append ans1 ans2))))) nil)) nil)) (& nil))) (defun syntactically-plausible-lambda-objectsp-within (gflg body) (declare (xargs :guard (pseudo-termp body))) (cond ((variablep body) t) ((fquotep body) (cond ((and (consp (unquote body)) (eq (car (unquote body)) 'lambda)) (syntactically-plausible-lambda-objectp gflg (unquote body))) (t t))) ((flambda-applicationp body) (let* ((ans1 (syntactically-plausible-lambda-objectp gflg (ffn-symb body))) (ans2 (if ans1 (syntactically-plausible-lambda-objectsp-within-lst gflg (fargs body)) nil))) (cond ((null ans2) nil) ((eq ans1 t) ans2) ((eq ans2 t) ans1) (t (append ans1 ans2))))) (t (syntactically-plausible-lambda-objectsp-within-lst gflg (fargs body))))) (defun syntactically-plausible-lambda-objectsp-within-lst (gflg args) (declare (xargs :guard (pseudo-term-listp args))) (cond ((endp args) t) (t (let* ((ans1 (syntactically-plausible-lambda-objectsp-within gflg (car args))) (ans2 (if ans1 (syntactically-plausible-lambda-objectsp-within-lst gflg (cdr args)) nil))) (cond ((null ans2) nil) ((eq ans1 t) ans2) ((eq ans2 t) ans1) (t (append ans1 ans2))))))))
collect-programsfunction
(defun collect-programs (names wrld) (cond ((null names) nil) ((programp (car names) wrld) (cons (car names) (collect-programs (cdr names) wrld))) (t (collect-programs (cdr names) wrld))))
all-fnnames1function
(defun all-fnnames1 (flg x acc) (declare (xargs :guard (and (true-listp acc) (cond (flg (pseudo-term-listp x)) (t (pseudo-termp x)))))) (cond (flg (cond ((endp x) acc) (t (all-fnnames1 nil (car x) (all-fnnames1 t (cdr x) acc))))) ((variablep x) acc) ((fquotep x) acc) ((flambda-applicationp x) (all-fnnames1 nil (lambda-body (ffn-symb x)) (all-fnnames1 t (fargs x) acc))) (t (all-fnnames1 t (fargs x) (add-to-set-eq (ffn-symb x) acc)))))
all-fnnamesmacro
(defmacro all-fnnames (term) `(all-fnnames1 nil ,TERM nil))
all-fnnames-lstmacro
(defmacro all-fnnames-lst (lst) `(all-fnnames1 t ,LST nil))
make-badge-userfn-structure-tuplefunction
(defun make-badge-userfn-structure-tuple (fn warrantp badge) (list fn warrantp badge))
put-badge-userfn-structure-tuple-in-alistfunction
(defun put-badge-userfn-structure-tuple-in-alist (tuple alist ctx) (let ((pair (assoc-eq (car tuple) alist))) (cond (pair (cond ((equal (cddr pair) (cddr tuple)) (cond ((and (not (cadr pair)) (cadr tuple)) (put-assoc-eq (car tuple) (cdr tuple) alist)) (t alist))) (t (er hard! ctx "The function symbol ~x0 already has the badge, ~ ~x1. So it is illegal to try to assign it the ~ badge, ~x2." (car tuple) (cdr pair) (cdr tuple))))) (t (cons tuple alist)))))
weak-badge-userfn-structure-tuplepfunction
(defun weak-badge-userfn-structure-tuplep (x) (declare (xargs :mode :logic :guard t)) (and (consp x) (consp (cdr x)) (consp (cddr x))))
access-badge-userfn-structure-tuple-warrantpmacro
(defmacro access-badge-userfn-structure-tuple-warrantp (x) `(cadr ,X))
access-badge-userfn-structure-tuple-badgemacro
(defmacro access-badge-userfn-structure-tuple-badge (x) `(caddr ,X))
get-warrantpmacro
(defmacro get-warrantp (fn wrld) `(access-badge-userfn-structure-tuple-warrantp (assoc-eq ,FN (cdr (assoc-eq :badge-userfn-structure (table-alist 'badge-table ,WRLD))))))
get-badgemacro
(defmacro get-badge (fn wrld) `(access-badge-userfn-structure-tuple-badge (assoc-eq ,FN (cdr (assoc-eq :badge-userfn-structure (table-alist 'badge-table ,WRLD))))))
get-badge-and-warrantpmacro
(defmacro get-badge-and-warrantp (fn wrld) `(let ((temp (assoc-eq ,FN (cdr (assoc-eq :badge-userfn-structure (table-alist 'badge-table ,WRLD)))))) (mv (access-badge-userfn-structure-tuple-badge temp) (access-badge-userfn-structure-tuple-warrantp temp))))
warrant-namefunction
(defun warrant-name (fn) (declare (xargs :mode :logic :guard (symbolp fn))) (intern-in-package-of-symbol (concatenate 'string "APPLY$-WARRANT-" (symbol-name fn)) fn))
warrant-name-inversefunction
(defun warrant-name-inverse (warrant-fn) (declare (xargs :guard (symbolp warrant-fn))) (let ((warrant-fn-name (symbol-name warrant-fn))) (and (string-prefixp "APPLY$-WARRANT-" warrant-fn-name) (intern-in-package-of-symbol (subseq warrant-fn-name 15 (length warrant-fn-name)) warrant-fn))))
warrant-function-namepfunction
(defun warrant-function-namep (warrant-fn wrld) (declare (xargs :guard (and (symbolp warrant-fn) (plist-worldp wrld)))) (let ((fn (warrant-name-inverse warrant-fn))) (and fn (get-warrantp fn wrld))))
encapsulate
(encapsulate nil (logic) (defrec apply$-badge (arity out-arity . ilks) nil))
apply$-badge-aritymacro
(defmacro apply$-badge-arity (x) `(cadr ,X))
*generic-tame-badge-1*constant
(defconst *generic-tame-badge-1* (make apply$-badge :arity 1 :out-arity 1 :ilks t))
*generic-tame-badge-2*constant
(defconst *generic-tame-badge-2* (make apply$-badge :arity 2 :out-arity 1 :ilks t))
*generic-tame-badge-3*constant
(defconst *generic-tame-badge-3* (make apply$-badge :arity 3 :out-arity 1 :ilks t))
*apply$-badge*constant
(defconst *apply$-badge* (make apply$-badge :arity 2 :out-arity 1 :ilks '(:fn nil)))
*ev$-badge*constant
(defconst *ev$-badge* (make apply$-badge :arity 2 :out-arity 1 :ilks '(:expr nil)))
weak-badge-userfn-structure-alistpfunction
(defun weak-badge-userfn-structure-alistp (x) (declare (xargs :guard t)) (cond ((atom x) (null x)) (t (and (weak-badge-userfn-structure-tuplep (car x)) (symbolp (car (car x))) (booleanp (access-badge-userfn-structure-tuple-warrantp (car x))) (weak-apply$-badge-p (access-badge-userfn-structure-tuple-badge (car x))) (weak-badge-userfn-structure-alistp (cdr x))))))
apply$-badge-pfunction
(defun apply$-badge-p (x) (declare (xargs :guard t)) (and (weak-apply$-badge-p x) (natp (access apply$-badge x :arity)) (natp (access apply$-badge x :out-arity)) (let ((ilks (access apply$-badge x :ilks))) (or (eq ilks t) (symbol-listp ilks)))))
badge-userfn-structure-alistpfunction
(defun badge-userfn-structure-alistp (x) (declare (xargs :guard t)) (cond ((atom x) (null x)) (t (and (weak-badge-userfn-structure-tuplep (car x)) (symbolp (car (car x))) (booleanp (access-badge-userfn-structure-tuple-warrantp (car x))) (apply$-badge-p (access-badge-userfn-structure-tuple-badge (car x))) (badge-userfn-structure-alistp (cdr x))))))
apply$-badge-alistp-ilks-tfunction
(defun apply$-badge-alistp-ilks-t (alist) (declare (xargs :guard t)) (cond ((atom alist) (null alist)) (t (let ((x (car alist))) (and (consp x) (weak-apply$-badge-p (cdr x)) (natp (access apply$-badge (cdr x) :arity)) (natp (access apply$-badge (cdr x) :out-arity)) (eq (access apply$-badge (cdr x) :ilks) t) (apply$-badge-alistp-ilks-t (cdr alist)))))))
ilks-plist-worldpfunction
(defun ilks-plist-worldp (wrld) (declare (xargs :guard t)) (and (plist-worldp wrld) (let ((tbl (fgetprop 'badge-table 'table-alist nil wrld))) (and (alistp tbl) (badge-userfn-structure-alistp (cdr (assoc-equal :badge-userfn-structure tbl))))) (let ((temp (getpropc '*badge-prim-falist* 'const nil wrld))) (or (null temp) (and (consp temp) (consp (cdr temp)) (apply$-badge-alistp-ilks-t (unquote temp)))))))
executable-badgefunction
(defun executable-badge (fn wrld) (declare (xargs :mode :program :guard (ilks-plist-worldp wrld))) (cond ((and (global-val 'boot-strap-flg wrld) (or (not (getpropc '*badge-prim-falist* 'const nil wrld)) (not (getpropc 'badge-table 'table-guard nil wrld)))) (er hard? 'executable-badge "It is illegal to call this function during boot strapping because ~ primitives have not yet been identified and badges not yet ~ computed!")) ((symbolp fn) (let* ((badge-prim-falist (getpropc '*badge-prim-falist* 'const nil wrld)) (temp (hons-get fn (unquote badge-prim-falist)))) (cond ((consp temp) (cdr temp)) ((eq fn 'badge) *generic-tame-badge-1*) ((eq fn 'tamep) *generic-tame-badge-1*) ((eq fn 'tamep-functionp) *generic-tame-badge-1*) ((eq fn 'suitably-tamep-listp) *generic-tame-badge-3*) ((eq fn 'apply$) *apply$-badge*) ((eq fn 'ev$) *ev$-badge*) (t (get-badge fn wrld))))) (t nil)))
find-warrant-function-namefunction
(defun find-warrant-function-name (fn wrld) (declare (xargs :mode :program :guard (ilks-plist-worldp wrld))) (cond ((and (global-val 'boot-strap-flg wrld) (or (not (getpropc '*badge-prim-falist* 'const nil wrld)) (not (getpropc 'badge-table 'table-guard nil wrld)))) (er hard? 'find-warrant-function-name "It is illegal to call this function during boot strapping because ~ primitives have not yet been identified and warrants not yet ~ computed!")) ((symbolp fn) (let ((temp (hons-get fn (unquote (getpropc '*badge-prim-falist* 'const nil wrld))))) (cond (temp t) ((eq fn 'badge) t) ((eq fn 'tamep) t) ((eq fn 'tamep-functionp) t) ((eq fn 'suitably-tamep-listp) t) ((eq fn 'apply$) t) ((eq fn 'ev$) t) (t (let ((temp (get-warrantp fn wrld))) (cond (temp (warrant-name fn)) (t nil))))))) (t nil)))
executable-tamep-lambdapother
(defabbrev executable-tamep-lambdap (fn wrld) (and (lambda-object-shapep fn) (symbol-listp (lambda-object-formals fn)) (executable-tamep (lambda-object-body fn) wrld)))
executable-tamepmutual-recursion
(mutual-recursion (defun executable-tamep (x wrld) (declare (xargs :mode :program :measure (acl2-count x) :guard (ilks-plist-worldp wrld))) (cond ((atom x) (symbolp x)) ((eq (car x) 'quote) (and (consp (cdr x)) (null (cddr x)))) ((symbolp (car x)) (let ((bdg (executable-badge (car x) wrld))) (cond ((null bdg) nil) ((eq (access apply$-badge bdg :ilks) t) (and (= (access apply$-badge bdg :arity) (len (cdr x))) (executable-suitably-tamep-listp nil (cdr x) wrld))) (t (and (= (access apply$-badge bdg :arity) (len (cdr x))) (executable-suitably-tamep-listp (access apply$-badge bdg :ilks) (cdr x) wrld)))))) ((consp (car x)) (let ((fn (car x))) (and (executable-tamep-lambdap fn wrld) (= (length (cadr fn)) (len (cdr x))) (executable-suitably-tamep-listp nil (cdr x) wrld)))) (t nil))) (defun executable-tamep-functionp (fn wrld) (declare (xargs :mode :program :measure (acl2-count fn) :guard (ilks-plist-worldp wrld))) (if (symbolp fn) (let ((bdg (executable-badge fn wrld))) (and bdg (eq (access apply$-badge bdg :ilks) t))) (and (consp fn) (executable-tamep-lambdap fn wrld)))) (defun executable-suitably-tamep-listp (flags args wrld) (declare (xargs :mode :program :measure (acl2-count args) :guard (and (true-listp flags) (ilks-plist-worldp wrld)))) (cond ((atom args) (null args)) (t (and (let ((arg (car args))) (case (car flags) (:fn (and (consp arg) (eq (car arg) 'quote) (consp (cdr arg)) (null (cddr arg)) (executable-tamep-functionp (cadr arg) wrld))) (:expr (and (consp arg) (eq (car arg) 'quote) (consp (cdr arg)) (null (cddr arg)) (executable-tamep (cadr arg) wrld))) (otherwise (executable-tamep arg wrld)))) (executable-suitably-tamep-listp (cdr flags) (cdr args) wrld))))))
weak-splo-extracts-tuple-listpfunction
(defun weak-splo-extracts-tuple-listp (x) (declare (xargs :guard t)) (cond ((atom x) (null x)) (t (and (weak-splo-extracts-tuple-p (car x)) (weak-splo-extracts-tuple-listp (cdr x))))))
well-formed-lambda-objectp1function
(defun well-formed-lambda-objectp1 (extracts wrld) (declare (xargs :guard (and (weak-splo-extracts-tuple-listp extracts) (plist-worldp-with-formals wrld) (ilks-plist-worldp wrld)))) (cond ((endp extracts) t) (t (let ((gflg (access splo-extracts-tuple (car extracts) :gflg)) (satisfies-exprs (access splo-extracts-tuple (car extracts) :satisfies-exprs)) (guard (access splo-extracts-tuple (car extracts) :guard)) (body (access splo-extracts-tuple (car extracts) :body))) (and (term-listp satisfies-exprs wrld) (termp guard wrld) (termp body wrld) (or gflg (executable-tamep body wrld)) (well-formed-lambda-objectp1 (cdr extracts) wrld))))))
well-formed-lambda-objectpfunction
(defun well-formed-lambda-objectp (x wrld) (declare (xargs :guard (and (plist-worldp-with-formals wrld) (ilks-plist-worldp wrld)))) (let ((extracts (syntactically-plausible-lambda-objectp nil x))) (and extracts (well-formed-lambda-objectp1 extracts wrld))))
all-fnnames!function
(defun all-fnnames! (lst-flg where-flg collect-flg term ilk wrld acc) (cond (lst-flg (cond ((endp term) acc) (t (all-fnnames! nil where-flg collect-flg (car term) (car ilk) wrld (all-fnnames! t where-flg collect-flg (cdr term) (cdr ilk) wrld acc))))) ((variablep term) acc) ((fquotep term) (cond ((eq where-flg :outside) acc) ((eq ilk :fn) (let ((evg (unquote term))) (cond ((symbolp evg) (add-to-set-eq evg acc)) ((and (consp evg) (eq (car evg) 'lambda) (well-formed-lambda-objectp evg wrld)) (all-fnnames! nil where-flg t (lambda-object-body evg) nil wrld acc)) (t acc)))) ((eq ilk :expr) (let ((evg (unquote term))) (cond ((termp evg wrld) (all-fnnames! nil where-flg t evg nil wrld acc)) (t acc)))) (t acc))) ((lambda-applicationp term) (all-fnnames! t where-flg collect-flg (fargs term) nil wrld (all-fnnames! nil where-flg collect-flg (lambda-body (ffn-symb term)) nil wrld acc))) (t (let ((bdg (executable-badge (ffn-symb term) wrld))) (all-fnnames! t where-flg collect-flg (fargs term) (if (or (null bdg) (eq (access apply$-badge bdg :ilks) t)) nil (access apply$-badge bdg :ilks)) wrld (if collect-flg (add-to-set-eq (ffn-symb term) acc) acc))))))
other
(defattach remove-guard-holders-blocked-by-hide-p constant-t-function-arity-0)
possibly-dirty-lambda-objectp1mutual-recursion
(mutual-recursion (defun possibly-dirty-lambda-objectp1 (x) (declare (xargs :guard (pseudo-termp x))) (cond ((variablep x) nil) ((fquotep x) nil) ((and (eq (ffn-symb x) 'hide) (remove-guard-holders-blocked-by-hide-p)) nil) ((lambda-applicationp x) t) ((member-eq (ffn-symb x) '(return-last mv-list cons-with-hint the-check)) t) (t (possibly-dirty-lambda-objectp1-lst (fargs x))))) (defun possibly-dirty-lambda-objectp1-lst (x) (declare (xargs :guard (pseudo-term-listp x))) (cond ((endp x) nil) (t (or (possibly-dirty-lambda-objectp1 (car x)) (possibly-dirty-lambda-objectp1-lst (cdr x)))))))
possibly-dirty-lambda-objectpfunction
(defun possibly-dirty-lambda-objectp (obj) (and (lambda-object-shapep obj) (or (lambda-object-dcl obj) (and (pseudo-termp (lambda-object-body obj)) (possibly-dirty-lambda-objectp1 (lambda-object-body obj))))))
may-contain-dirty-lambda-objectspmutual-recursion
(mutual-recursion (defun may-contain-dirty-lambda-objectsp (term) (declare (xargs :guard (pseudo-termp term))) (cond ((variablep term) nil) ((fquotep term) (possibly-dirty-lambda-objectp (unquote term))) ((and (eq (ffn-symb term) 'hide) (remove-guard-holders-blocked-by-hide-p)) nil) ((lambda-applicationp term) (or (may-contain-dirty-lambda-objectsp (lambda-body (ffn-symb term))) (may-contain-dirty-lambda-objectsp-lst (fargs term)))) (t (may-contain-dirty-lambda-objectsp-lst (fargs term))))) (defun may-contain-dirty-lambda-objectsp-lst (terms) (cond ((endp terms) nil) (t (or (may-contain-dirty-lambda-objectsp (car terms)) (may-contain-dirty-lambda-objectsp-lst (cdr terms)))))))
expand-all-lambdasmutual-recursion
(mutual-recursion (defun expand-all-lambdas (term) (declare (xargs :guard (pseudo-termp term) :verify-guards nil)) (cond ((variablep term) term) ((fquotep term) term) ((flambdap (ffn-symb term)) (subcor-var (lambda-formals (ffn-symb term)) (expand-all-lambdas-lst (fargs term)) (expand-all-lambdas (lambda-body (ffn-symb term))))) (t (fcons-term (ffn-symb term) (expand-all-lambdas-lst (fargs term)))))) (defun expand-all-lambdas-lst (terms) (declare (xargs :guard (pseudo-term-listp terms) :verify-guards nil)) (cond ((endp terms) nil) (t (cons (expand-all-lambdas (car terms)) (expand-all-lambdas-lst (cdr terms)))))))
dumb-occur-varmutual-recursion
(mutual-recursion (defun dumb-occur-var (var term) (declare (xargs :guard (and (symbolp var) (pseudo-termp term)))) (cond ((eq var term) t) ((variablep term) nil) ((fquotep term) nil) (t (dumb-occur-var-lst var (fargs term))))) (defun dumb-occur-var-lst (var lst) (declare (xargs :guard (and (symbolp var) (pseudo-term-listp lst)))) (cond ((endp lst) nil) (t (or (dumb-occur-var var (car lst)) (dumb-occur-var-lst var (cdr lst)))))))
trivial-lambda-pfunction
(defun trivial-lambda-p (formals args body) (declare (xargs :guard (and (symbol-listp formals) (true-listp args) (equal (length formals) (length args)) (pseudo-termp body)))) (declare (ignore body)) (equal formals args))
remove-guard-holders1mutual-recursion
(mutual-recursion (defun remove-guard-holders1 (changedp0 term lamp) (declare (xargs :guard (pseudo-termp term) :measure (acl2-count term))) (cond ((variablep term) (mv changedp0 term)) ((fquotep term) (mv changedp0 term)) ((and (eq (ffn-symb term) 'hide) (remove-guard-holders-blocked-by-hide-p)) (mv changedp0 term)) ((member-eq (ffn-symb term) '(return-last mv-list the-check)) (remove-guard-holders1 t (car (last (fargs term))) lamp)) ((eq (ffn-symb term) 'cons-with-hint) (mv-let (changedp1 arg1) (remove-guard-holders1 nil (fargn term 1) lamp) (declare (ignore changedp1)) (mv-let (changedp2 arg2) (remove-guard-holders1 nil (fargn term 2) lamp) (declare (ignore changedp2)) (mv t (mcons-term* 'cons arg1 arg2))))) ((eq (ffn-symb term) 'to-df) (let ((arg (fargn term 1))) (cond ((and (quotep arg) (dfp (unquote arg))) (mv t arg)) (t (mv-let (changedp1 arg1) (remove-guard-holders1 nil arg lamp) (mv changedp1 (fcons-term* 'to-df arg1))))))) ((eq (ffn-symb term) 'from-df) (mv-let (changedp1 arg1) (remove-guard-holders1 nil (fargn term 1) lamp) (declare (ignore changedp1)) (mv t arg1))) ((eq (ffn-symb term) 'df0) (mv t *0*)) ((eq (ffn-symb term) 'df1) (mv t *1*)) ((flambdap (ffn-symb term)) (case-match term ((('lambda ('var) ('the-check & & 'var)) val) (remove-guard-holders1 t val lamp)) ((('lambda formals ('return-last ''mbe1-raw & logic)) . args) (mv-let (changedp1 args1) (remove-guard-holders1-lst args lamp) (declare (ignore changedp1)) (mv-let (changedp2 logic2) (remove-guard-holders1 nil logic lamp) (declare (ignore changedp2)) (mv t (subcor-var formals args1 logic2))))) (& (mv-let (changedp1 lambda-body) (remove-guard-holders1 nil (lambda-body (ffn-symb term)) lamp) (let ((lambda-formals (lambda-formals (ffn-symb term)))) (mv-let (changedp2 args) (remove-guard-holders1-lst (fargs term) lamp) (cond ((and lamp (consp lambda-formals) (null (cdr lambda-formals)) (eq (car lambda-formals) lambda-body)) (mv t (car args))) ((and lamp (trivial-lambda-p lambda-formals args lambda-body)) (mv t lambda-body)) ((or changedp1 changedp2) (mv t (mcons-term (if changedp1 (make-lambda lambda-formals lambda-body) (ffn-symb term)) args))) (t (mv changedp0 term))))))))) (t (mv-let (changedp1 args) (remove-guard-holders1-lst (fargs term) lamp) (cond ((and (eq (ffn-symb term) 'do$) (quotep (fargn term 6)) (unquote (fargn term 6))) (mv t (mcons-term 'do$ (append (take 5 args) (list *nil*))))) ((null changedp1) (cond ((quote-listp args) (let ((new-term (mcons-term (ffn-symb term) args))) (cond ((equal term new-term) (mv changedp0 term)) (t (mv t new-term))))) (t (mv changedp0 term)))) (t (mv t (mcons-term (ffn-symb term) args)))))))) (defun remove-guard-holders1-lst (lst lamp) (declare (xargs :guard (pseudo-term-listp lst) :measure (acl2-count lst))) (cond ((endp lst) (mv nil nil)) (t (mv-let (changedp1 a) (remove-guard-holders1 nil (car lst) lamp) (mv-let (changedp2 b) (remove-guard-holders1-lst (cdr lst) lamp) (cond ((or changedp1 changedp2) (mv t (cons a b))) (t (mv nil lst)))))))))
remove-guard-holders-weakfunction
(defun remove-guard-holders-weak (term lamp) (declare (xargs :guard (pseudo-termp term))) (mv-let (changedp result) (remove-guard-holders1 nil term lamp) (declare (ignore changedp)) result))
remove-guard-holders-weak-lstfunction
(defun remove-guard-holders-weak-lst (lst lamp) (declare (xargs :guard (pseudo-term-listp lst))) (mv-let (changedp result) (remove-guard-holders1-lst lst lamp) (declare (ignore changedp)) result))
remove-guard-holders1-lst-lstfunction
(defun remove-guard-holders1-lst-lst (lst lamp) (declare (xargs :guard (pseudo-term-list-listp lst))) (cond ((null lst) (mv nil nil)) (t (mv-let (changedp1 a) (remove-guard-holders1-lst (car lst) lamp) (mv-let (changedp2 b) (remove-guard-holders1-lst-lst (cdr lst) lamp) (cond ((or changedp1 changedp2) (mv t (cons a b))) (t (mv nil lst))))))))
remove-guard-holders-weak-lst-lstfunction
(defun remove-guard-holders-weak-lst-lst (lst lamp) (declare (xargs :guard (pseudo-term-list-listp lst))) (mv-let (changedp result) (remove-guard-holders1-lst-lst lst lamp) (declare (ignore changedp)) result))
warrants-for-tamep-lambdapother
(defabbrev warrants-for-tamep-lambdap (fn wrld warrants unwarranteds) (warrants-for-tamep (lambda-object-body fn) wrld warrants unwarranteds))
warrants-for-tamepmutual-recursion
(mutual-recursion (defun warrants-for-tamep (x wrld warrants unwarranteds) (declare (xargs :mode :program :measure (acl2-count x) :guard (and (ilks-plist-worldp wrld) (executable-tamep x wrld) (true-listp warrants) (symbol-listp unwarranteds)))) (cond ((atom x) (mv warrants unwarranteds)) ((eq (car x) 'quote) (mv warrants unwarranteds)) ((symbolp (car x)) (let* ((fn (car x)) (bdg (executable-badge fn wrld)) (temp (access apply$-badge bdg :ilks)) (ilks (if (eq temp t) nil temp)) (warrant-name (find-warrant-function-name fn wrld))) (warrants-for-suitably-tamep-listp ilks (fargs x) wrld (if (or (eq warrant-name t) (eq warrant-name nil)) warrants (add-to-set-equal (list warrant-name) warrants)) (if (eq warrant-name nil) (add-to-set-eq fn unwarranteds) unwarranteds)))) ((consp (car x)) (let ((fn (car x))) (mv-let (warrants1 unwarranteds1) (warrants-for-tamep-lambdap fn wrld warrants unwarranteds) (warrants-for-suitably-tamep-listp nil (cdr x) wrld warrants1 unwarranteds1)))) (t (mv warrants unwarranteds)))) (defun warrants-for-tamep-functionp (fn wrld warrants unwarranteds) (declare (xargs :mode :program :measure (acl2-count fn) :guard (and (ilks-plist-worldp wrld) (executable-tamep-functionp fn wrld) (true-listp warrants) (symbol-listp unwarranteds)))) (if (flambdap fn) (warrants-for-tamep-lambdap fn wrld warrants unwarranteds) (let ((warrant-name (find-warrant-function-name fn wrld))) (mv (if (or (eq warrant-name t) (eq warrant-name nil)) warrants (add-to-set-equal (list warrant-name) warrants)) (if (eq warrant-name nil) (add-to-set-eq fn unwarranteds) unwarranteds))))) (defun warrants-for-suitably-tamep-listp (flags args wrld warrants unwarranteds) (declare (xargs :mode :program :measure (acl2-count args) :guard (and (ilks-plist-worldp wrld) (true-listp flags) (executable-suitably-tamep-listp flags args wrld) (true-listp warrants) (symbol-listp unwarranteds)))) (cond ((endp args) (mv warrants unwarranteds)) (t (mv-let (warrants1 unwarranteds1) (let ((arg (car args))) (case (car flags) (:fn (warrants-for-tamep-functionp (cadr arg) wrld warrants unwarranteds)) (:expr (warrants-for-tamep (cadr arg) wrld warrants unwarranteds)) (otherwise (warrants-for-tamep arg wrld warrants unwarranteds)))) (warrants-for-suitably-tamep-listp (cdr flags) (cdr args) wrld warrants1 unwarranteds1))))))
warrants-for-tamep-lambdap-lstfunction
(defun warrants-for-tamep-lambdap-lst (lst wrld warrants unwarranteds) (cond ((endp lst) (mv warrants unwarranteds)) (t (mv-let (warrants1 unwarranteds1) (warrants-for-tamep (lambda-object-body (car lst)) wrld warrants unwarranteds) (warrants-for-tamep-lambdap-lst (cdr lst) wrld warrants1 unwarranteds1)))))
clean-up-dirty-lambda-object-bodyother
(defabbrev clean-up-dirty-lambda-object-body (hyps body wrld lamp) (expand-all-lambdas (clean-up-dirty-lambda-objects hyps (remove-guard-holders-weak body lamp) nil wrld lamp)))
clean-up-dirty-lambda-objectsmutual-recursion
(mutual-recursion (defun clean-up-dirty-lambda-objects (hyps term ilk wrld lamp) (declare (xargs :guard (and (pseudo-termp term) (plist-worldp wrld)))) (cond ((not (mbt (pseudo-termp term))) term) ((variablep term) term) ((fquotep term) (let ((evg (unquote term))) (cond ((eq ilk :fn) (cond ((and (consp evg) (eq (car evg) 'lambda) (well-formed-lambda-objectp evg wrld)) (cond ((or (eq hyps :all) (mv-let (warrants unwarranteds) (warrants-for-tamep-lambdap evg wrld nil nil) (and (null unwarranteds) (subsetp-equal warrants hyps)))) (kwote (list 'lambda (lambda-object-formals evg) (clean-up-dirty-lambda-object-body hyps (lambda-object-body evg) wrld lamp)))) ((null (lambda-object-dcl evg)) term) (t (kwote (list 'lambda (lambda-object-formals evg) (lambda-object-body evg)))))) (t term))) (t term)))) ((and (eq (ffn-symb term) 'hide) (remove-guard-holders-blocked-by-hide-p)) term) ((lambda-applicationp term) (fcons-term (list 'lambda (lambda-formals (ffn-symb term)) (clean-up-dirty-lambda-objects hyps (lambda-body (ffn-symb term)) nil wrld lamp)) (clean-up-dirty-lambda-objects-lst hyps (fargs term) nil wrld lamp))) (t (let ((bdg (executable-badge (ffn-symb term) wrld))) (fcons-term (ffn-symb term) (clean-up-dirty-lambda-objects-lst hyps (fargs term) (if (or (null bdg) (eq (access apply$-badge bdg :ilks) t)) nil (access apply$-badge bdg :ilks)) wrld lamp)))))) (defun clean-up-dirty-lambda-objects-lst (hyps terms ilks wrld lamp) (declare (xargs :guard (and (pseudo-term-listp terms) (plist-worldp wrld)))) (cond ((not (mbt (pseudo-term-listp terms))) terms) ((endp terms) nil) (t (cons (clean-up-dirty-lambda-objects hyps (car terms) (car ilks) wrld lamp) (clean-up-dirty-lambda-objects-lst hyps (cdr terms) (cdr ilks) wrld lamp))))))
possibly-clean-up-dirty-lambda-objectsfunction
(defun possibly-clean-up-dirty-lambda-objects (hyps term wrld lamp) (cond ((and (not (global-val 'boot-strap-flg wrld)) (may-contain-dirty-lambda-objectsp term)) (clean-up-dirty-lambda-objects hyps term nil wrld lamp)) (t term)))
possibly-clean-up-dirty-lambda-objects-lstfunction
(defun possibly-clean-up-dirty-lambda-objects-lst (hyps terms wrld lamp) (cond ((endp terms) nil) (t (cons (possibly-clean-up-dirty-lambda-objects hyps (car terms) wrld lamp) (possibly-clean-up-dirty-lambda-objects-lst hyps (cdr terms) wrld lamp)))))
strip-force-and-case-splitfunction
(defun strip-force-and-case-split (lst) (cond ((endp lst) nil) (t (let* ((hyp (car lst)) (rest (strip-force-and-case-split (cdr lst)))) (case-match hyp (('force hyp) (cons hyp rest)) (('case-split hyp) (cons hyp rest)) (& (cons hyp rest)))))))
possibly-clean-up-dirty-lambda-objects-in-pairsfunction
(defun possibly-clean-up-dirty-lambda-objects-in-pairs (pairs wrld lamp) (cond ((endp pairs) nil) (t (let ((hyps (car (car pairs))) (concl (cdr (car pairs)))) (cons (cons hyps (possibly-clean-up-dirty-lambda-objects (strip-force-and-case-split hyps) concl wrld lamp)) (possibly-clean-up-dirty-lambda-objects-in-pairs (cdr pairs) wrld lamp))))))
other
(defattach remove-guard-holders-lamp constant-t-function-arity-0)
remove-guard-holdersfunction
(defun remove-guard-holders (term wrld) (declare (xargs :guard (and (pseudo-termp term) (plist-worldp wrld)))) (let ((lamp (remove-guard-holders-lamp))) (cond (wrld (possibly-clean-up-dirty-lambda-objects nil (remove-guard-holders-weak term lamp) wrld lamp)) (t (remove-guard-holders-weak term lamp)))))
remove-guard-holders-lstfunction
(defun remove-guard-holders-lst (lst wrld) (declare (ignore wrld) (xargs :guard (and (pseudo-term-listp lst) (plist-worldp wrld)))) (let ((lamp (remove-guard-holders-lamp))) (remove-guard-holders-weak-lst lst lamp)))
remove-guard-holders-lst-lstfunction
(defun remove-guard-holders-lst-lst (lst wrld) (declare (ignore wrld) (xargs :guard (and (pseudo-term-list-listp lst) (plist-worldp wrld)))) (let ((lamp (remove-guard-holders-lamp))) (remove-guard-holders-weak-lst-lst lst lamp)))
lambda-object-guardfunction
(defun lambda-object-guard (x) (or (cadr (assoc-keyword :guard (cdr (assoc-eq 'xargs (cdr (lambda-object-dcl x)))))) *t*))
tag-translated-lambda$-bodyfunction
(defun tag-translated-lambda$-body (lambda$-expr tbody) `(return-last 'progn ',LAMBDA$-EXPR ,TBODY))
lambda$-bodypfunction
(defun lambda$-bodyp (body) (and (consp body) (eq (ffn-symb body) 'return-last) (equal (fargn body 1) ''progn) (quotep (fargn body 2)) (consp (unquote (fargn body 2))) (eq (car (unquote (fargn body 2))) 'lambda$)))
member-lambda-objectpfunction
(defun member-lambda-objectp (args) (cond ((endp args) nil) ((and (quotep (car args)) (consp (unquote (car args))) (eq (car (unquote (car args))) 'lambda)) t) (t (member-lambda-objectp (cdr args)))))
attachment-alistfunction
(defun attachment-alist (fn wrld) (let ((prop (getpropc fn 'attachment nil wrld))) (and prop (cond ((symbolp prop) (getpropc prop 'attachment nil wrld)) ((eq (car prop) :attachment-disallowed) prop) (t prop)))))
attachment-pairfunction
(defun attachment-pair (fn wrld) (let ((attachment-alist (attachment-alist fn wrld))) (and attachment-alist (not (eq (car attachment-alist) :attachment-disallowed)) (assoc-eq fn attachment-alist))))
apply$-lambda-guardfunction
(defun apply$-lambda-guard (fn args) (declare (xargs :guard t :mode :logic)) (and (consp fn) (consp (cdr fn)) (true-listp args) (equal (len (cadr fn)) (length args))))
apply$-guardfunction
(defun apply$-guard (fn args) (declare (xargs :guard t :mode :logic)) (if (atom fn) (true-listp args) (apply$-lambda-guard fn args)))
other
(partial-encapsulate ((ev-fncall-rec-logical-unknown-constraints (fn args w user-stobj-alist big-n safe-mode gc-off latches hard-error-returns-nilp aok warranted-fns) (mv t t t))) nil (logic) (local (defun ev-fncall-rec-logical-unknown-constraints (fn args w user-stobj-alist big-n safe-mode gc-off latches hard-error-returns-nilp aok warranted-fns) (declare (ignore fn args w user-stobj-alist big-n safe-mode gc-off latches hard-error-returns-nilp aok warranted-fns)) (mv nil nil nil))))
scan-to-eventfunction
(defun scan-to-event (wrld) (cond ((null wrld) wrld) ((and (eq (caar wrld) 'event-landmark) (eq (cadar wrld) 'global-value)) wrld) (t (scan-to-event (cdr wrld)))))
get-defun-eventfunction
(defun get-defun-event (fn wrld) (let ((ev (get-event fn wrld))) (and (consp ev) (case (car ev) (defun ev) (mutual-recursion (assoc-eq-cadr fn (cdr ev))) ((defstobj defabsstobj) (and (eq (cadr ev) (getpropc fn 'stobj-function nil wrld)) (let* ((index (getpropc fn 'absolute-event-number nil wrld)) (wrld2 (assert$ index (lookup-world-index 'event index wrld))) (ev (get-event fn (scan-to-event (cdr wrld2))))) (and (eq (car ev) 'defun) ev)))) (verify-termination-boot-strap (cltl-def-from-name fn wrld)) (otherwise nil)))))
*one-way-unify1-implicit-fns*constant
(defconst *one-way-unify1-implicit-fns* '(binary-+ binary-* unary-- unary-/ intern-in-package-of-symbol coerce cons))
one-way-unify1-quotep-subproblemsfunction
(defun one-way-unify1-quotep-subproblems (pat term) (declare (xargs :guard (and (pseudo-termp pat) (nvariablep pat) (not (fquotep pat)) (pseudo-termp term) (quotep term)))) (let ((evg (cadr term))) (cond ((acl2-numberp evg) (let ((ffn-symb (ffn-symb pat))) (case ffn-symb (binary-+ (cond ((quotep (fargn pat 1)) (let ((new-evg (- evg (fix (cadr (fargn pat 1)))))) (cond ((<= (acl2-count new-evg) (acl2-count evg)) (mv (fargn pat 2) (kwote new-evg) nil nil)) (t (mv nil nil nil nil))))) ((quotep (fargn pat 2)) (let ((new-evg (- evg (fix (cadr (fargn pat 2)))))) (cond ((<= (acl2-count new-evg) (acl2-count evg)) (mv (fargn pat 1) (kwote new-evg) nil nil)) (t (mv nil nil nil nil))))) (t (mv nil nil nil nil)))) (binary-* (cond ((or (not (integerp evg)) (int= evg 0)) (mv nil nil nil nil)) ((and (quotep (fargn pat 1)) (integerp (cadr (fargn pat 1))) (> (abs (cadr (fargn pat 1))) 1)) (let ((new-term-evg (/ evg (cadr (fargn pat 1))))) (cond ((integerp new-term-evg) (mv (fargn pat 2) (kwote new-term-evg) nil nil)) (t (mv nil nil nil nil))))) ((and (quotep (fargn pat 2)) (integerp (cadr (fargn pat 2))) (> (abs (cadr (fargn pat 2))) 1)) (let ((new-term-evg (/ evg (cadr (fargn pat 2))))) (cond ((integerp new-term-evg) (mv (fargn pat 1) (kwote new-term-evg) nil nil)) (t (mv nil nil nil nil))))) (t (mv nil nil nil nil)))) (unary-- (cond ((>= (+ (realpart evg) (imagpart evg)) 0) (mv nil nil nil nil)) (t (mv (fargn pat 1) (kwote (- evg)) nil nil)))) (unary-/ (cond ((or (>= (* evg (conjugate evg)) 1) (eql 0 evg)) (mv nil nil nil nil)) (t (mv (fargn pat 1) (kwote (/ evg)) nil nil)))) (otherwise (mv nil nil nil nil))))) ((symbolp evg) (cond ((eq (ffn-symb pat) 'intern-in-package-of-symbol) (let ((pkg (symbol-package-name evg)) (name (symbol-name evg))) (cond ((and (nvariablep (fargn pat 2)) (fquotep (fargn pat 2))) (cond ((symbolp (cadr (fargn pat 2))) (if (equal pkg (symbol-package-name (cadr (fargn pat 2)))) (mv (fargn pat 1) (kwote name) nil nil) (mv nil nil nil nil))) (t (mv (eq evg nil) nil nil nil)))) (t (mv (fargn pat 1) (kwote name) (fargn pat 2) term))))) (t (mv nil nil nil nil)))) ((stringp evg) (cond ((and (eq (ffn-symb pat) 'coerce) (equal (fargn pat 2) ''string)) (mv (fargn pat 1) (kwote (coerce evg 'list)) nil nil)) (t (mv nil nil nil nil)))) ((consp evg) (cond ((eq (ffn-symb pat) 'cons) (mv (fargn pat 1) (kwote (car evg)) (fargn pat 2) (kwote (cdr evg)))) (t (mv nil nil nil nil)))) (t (mv nil nil nil nil)))))
one-way-unify1mutual-recursion
(mutual-recursion (defun one-way-unify1 (pat term alist) (declare (xargs :measure (make-ord 1 (+ 1 (acl2-count pat)) 2) :guard (and (pseudo-termp pat) (pseudo-termp term) (alistp alist)) :verify-guards nil)) (cond ((variablep pat) (let ((pair (assoc-eq pat alist))) (cond (pair (cond ((equal (cdr pair) term) (mv t alist)) (t (mv nil alist)))) (t (mv t (cons (cons pat term) alist)))))) ((fquotep pat) (cond ((equal pat term) (mv t alist)) (t (mv nil alist)))) ((variablep term) (mv nil alist)) ((fquotep term) (mv-let (pat1 term1 pat2 term2) (one-way-unify1-quotep-subproblems pat term) (cond ((eq pat1 t) (mv t alist)) ((eq pat1 nil) (mv nil alist)) ((eq pat2 nil) (one-way-unify1 pat1 term1 alist)) (t (mv-let (ans alist1) (one-way-unify1 pat1 term1 alist) (cond ((eq ans nil) (mv nil alist)) (t (mv-let (ans alist2) (one-way-unify1 pat2 term2 alist1) (cond (ans (mv ans alist2)) (t (mv nil alist))))))))))) ((cond ((flambda-applicationp pat) (equal (ffn-symb pat) (ffn-symb term))) (t (eq (ffn-symb pat) (ffn-symb term)))) (cond ((eq (ffn-symb pat) 'equal) (one-way-unify1-equal (fargn pat 1) (fargn pat 2) (fargn term 1) (fargn term 2) alist)) (t (mv-let (ans alist1) (one-way-unify1-lst (fargs pat) (fargs term) alist) (cond (ans (mv ans alist1)) (t (mv nil alist))))))) (t (mv nil alist)))) (defun one-way-unify1-lst (pl tl alist) (declare (xargs :measure (make-ord 1 (+ 1 (acl2-count pl)) 2) :guard (and (pseudo-term-listp pl) (pseudo-term-listp tl) (alistp alist)))) (cond ((endp pl) (mv t alist)) (t (mv-let (ans alist) (one-way-unify1 (car pl) (car tl) alist) (cond (ans (one-way-unify1-lst (cdr pl) (cdr tl) alist)) (t (mv nil alist))))))) (defun one-way-unify1-equal1 (pat1 pat2 term1 term2 alist) (declare (xargs :measure (make-ord 1 (+ 2 (acl2-count pat1) (acl2-count pat2)) 0) :guard (and (pseudo-termp pat1) (pseudo-termp term1) (pseudo-termp pat2) (pseudo-termp term2) (alistp alist)))) (mv-let (ans alist1) (one-way-unify1 pat1 term1 alist) (cond (ans (mv-let (ans alist2) (one-way-unify1 pat2 term2 alist1) (cond (ans (mv ans alist2)) (t (mv nil alist))))) (t (mv nil alist))))) (defun one-way-unify1-equal (pat1 pat2 term1 term2 alist) (declare (xargs :measure (make-ord 1 (+ 2 (acl2-count pat1) (acl2-count pat2)) 1) :guard (and (pseudo-termp pat1) (pseudo-termp term1) (pseudo-termp pat2) (pseudo-termp term2) (alistp alist)))) (mv-let (ans alist) (one-way-unify1-equal1 pat1 pat2 term1 term2 alist) (cond (ans (mv ans alist)) (t (one-way-unify1-equal1 pat2 pat1 term1 term2 alist))))))
one-way-unifyfunction
(defun one-way-unify (pat term) (declare (xargs :guard (and (pseudo-termp pat) (pseudo-termp term)))) (one-way-unify1 pat term nil))
fetch-addr1function
(defun fetch-addr1 (n x) (cond ((consp x) (cond ((zp n) nil) ((eql n 1) (car x)) (t (fetch-addr1 (- n 1) (cdr x))))) ((zp n) nil) ((eql n 1) '.) ((eql n 2) x) (t nil)))
fetch-addrfunction
(defun fetch-addr (addr x) (cond ((endp addr) x) (t (let ((x1 (fetch-addr1 (car addr) x)) (addr1 (cdr addr))) (cond ((and (atom x1) addr1) nil) (t (fetch-addr addr1 x1)))))))
one-way-unify1-frmutual-recursion
(mutual-recursion (defun one-way-unify1-fr (pat term alist raddr) (declare (xargs :measure (make-ord 1 (+ 1 (acl2-count pat)) 2) :guard (and (pseudo-termp pat) (pseudo-termp term) (alistp alist)) :verify-guards nil)) (cond ((variablep pat) (let ((pair (assoc-eq pat alist))) (cond (pair (cond ((equal (cdr pair) term) (mv t alist raddr alist term)) (t (mv nil alist raddr alist term)))) (t (mv t (cons (cons pat term) alist) raddr alist term))))) ((fquotep pat) (cond ((equal pat term) (mv t alist raddr alist term)) (t (mv nil alist raddr alist term)))) ((variablep term) (mv nil alist raddr alist term)) ((fquotep term) (mv-let (pat1 term1 pat2 term2) (one-way-unify1-quotep-subproblems pat term) (cond ((eq pat1 t) (mv t alist raddr alist term)) ((eq pat1 nil) (mv nil alist raddr alist term)) ((eq pat2 nil) (mv-let (ans alist1) (one-way-unify1 pat1 term1 alist) (cond (ans (mv ans alist1 raddr alist term)) (t (mv nil alist raddr alist term))))) (t (mv-let (ans alist1) (one-way-unify1 pat1 term1 alist) (cond ((eq ans nil) (mv nil alist raddr alist term)) (t (mv-let (ans alist2) (one-way-unify1 pat2 term2 alist1) (cond (ans (mv ans alist2 raddr alist term)) (t (mv nil alist raddr alist term))))))))))) ((cond ((flambda-applicationp pat) (equal (ffn-symb pat) (ffn-symb term))) (t (eq (ffn-symb pat) (ffn-symb term)))) (cond ((eq (ffn-symb pat) 'equal) (mv-let (ans alist1) (one-way-unify1-equal (fargn pat 1) (fargn pat 2) (fargn term 1) (fargn term 2) alist) (cond (ans (mv ans alist1 raddr alist term)) (t (mv nil alist raddr alist term))))) (t (mv-let (ans alist1 fr-raddr1 fr-alist1 fr-term1) (one-way-unify1-lst-fr (fargs pat) (fargs term) alist 2 raddr) (cond (ans (mv ans alist1 raddr alist term)) (t (mv nil alist fr-raddr1 fr-alist1 fr-term1))))))) (t (mv nil alist raddr alist term)))) (defun one-way-unify1-lst-fr (pl tl alist n raddr) (declare (xargs :measure (make-ord 1 (+ 1 (acl2-count pl)) 2) :guard (and (pseudo-term-listp pl) (pseudo-term-listp tl) (alistp alist)))) (cond ((endp pl) (mv t alist raddr alist tl)) (t (mv-let (ans alist fr-raddr1 fr-alist fr-term) (one-way-unify1-fr (car pl) (car tl) alist (cons n raddr)) (cond (ans (one-way-unify1-lst-fr (cdr pl) (cdr tl) alist (+ 1 n) raddr)) (t (mv nil alist fr-raddr1 fr-alist fr-term))))))))
one-way-unify-frfunction
(defun one-way-unify-fr (pat term) (declare (xargs :guard (and (pseudo-termp pat) (pseudo-termp term)))) (mv-let (ans alist fr-raddr fr-alist fr-term) (one-way-unify1-fr pat term nil nil) (mv ans alist (revappend fr-raddr nil) fr-alist fr-term)))
*initial-return-last-table*constant
(defconst *initial-return-last-table* '((time$1-raw . time$1) (with-prover-time-limit1-raw . with-prover-time-limit1) (with-fast-alist-raw . with-fast-alist) (with-stolen-alist-raw . with-stolen-alist) (fast-alist-free-on-exit-raw . fast-alist-free-on-exit) (progn . prog2$) (mbe1-raw . mbe1) (ec-call1-raw . ec-call1) (with-guard-checking1-raw . with-guard-checking1)))
maybe-convert-to-mvfunction
(defun maybe-convert-to-mv (uterm) (cond ((atom uterm) uterm) ((and (eq (car uterm) 'list) (consp (cddr uterm))) (cons 'mv (cdr uterm))) ((and (eq (car uterm) 'if) (= (length uterm) 4)) (list 'if (cadr uterm) (maybe-convert-to-mv (caddr uterm)) (maybe-convert-to-mv (cadddr uterm)))) ((member-eq (car uterm) '(let let* mv-let)) (append (butlast uterm 1) (list (maybe-convert-to-mv (car (last uterm)))))) ((and (eq (car uterm) 'mbe) (= (length uterm) 5) (eq (nth 1 uterm) :logic) (eq (nth 3 uterm) :exec)) `(mbe :logic ,(MAYBE-CONVERT-TO-MV (NTH 2 UTERM)) :exec ,(MAYBE-CONVERT-TO-MV (NTH 4 UTERM)))) ((or (member-eq (car uterm) '(return-last prog2$)) (rassoc-eq (car uterm) *initial-return-last-table*)) (append (butlast uterm 1) (list (maybe-convert-to-mv (car (last uterm)))))) ((member-eq (car uterm) '(ec-call time$)) (list* (car uterm) (maybe-convert-to-mv (cadr uterm)) (cddr uterm))) (t uterm)))
*type-expr-to-type-spec-alist*constant
(defconst *type-expr-to-type-spec-alist* '(((integerp var) . integer) ((if (integerp var) (not (< var int-lo)) 'nil) integer int-lo *) ((if (integerp var) (not (< int-hi var)) 'nil) integer * int-hi) ((if (integerp var) (if (not (< var int-lo)) (not (< int-hi var)) 'nil) 'nil) integer int-lo int-hi) ((rationalp var) . rational) ((complex-rationalp var) . complex) ((if (rationalp var) (not (< var rat-lo)) 'nil) rational rat-lo *) ((if (rationalp var) (not (< rat-hi var)) 'nil) rational * rat-hi) ((if (rationalp var) (if (not (< var rat-lo)) (not (< rat-hi var)) 'nil) 'nil) rational rat-lo rat-hi) ((if (equal var '1) (equal var '1) (equal var '0)) . bit) ((atom var) . atom) ((characterp var) . character) ((consp var) . cons) ((listp var) . list) ((eq var 'nil) . null) ((if (rationalp var) (not (integerp var)) 'nil) . ratio) ((standard-char-p+ var) . standard-char) ((stringp var) . string) ((if (stringp var) (equal (length var) nat) 'nil) string nat) ((symbolp var) . symbol) ('t . t)))
type-spec-fix-unify-substfunction
(defun type-spec-fix-unify-subst (alist) (cond ((endp alist) nil) (t (let ((rest (type-spec-fix-unify-subst (cdr alist)))) (cond ((eq rest :fail) :fail) ((eq (caar alist) 'var) (cons (car alist) rest)) ((quotep (cdar alist)) (acons (caar alist) (list :fake-unquote (cdar alist)) rest)) (t :fail))))))
remove-fake-unquotesmutual-recursion
(mutual-recursion (defun remove-fake-unquotes (term) (declare (xargs :guard (pseudo-termp term))) (cond ((or (variablep term) (fquotep term)) term) ((eq (ffn-symb term) :fake-unquote) (let ((args (fargs term))) (cond ((and (consp args) (null (cdr args)) (quotep (car args))) (unquote (car args))) (t (er hard? 'remove-fake-unquotes "Implementation error: Unexpected pseudo-term, ~x0. ~ Please contact the ACL2 implementors." term))))) (t (cons (ffn-symb term) (remove-fake-unquotes-lst (cdr term)))))) (defun remove-fake-unquotes-lst (term) (declare (xargs :guard (pseudo-term-listp term))) (cond ((endp term) nil) (t (cons (remove-fake-unquotes (car term)) (remove-fake-unquotes-lst (cdr term)))))))
type-spec-and-var-from-type-expression-1function
(defun type-spec-and-var-from-type-expression-1 (x alist) (cond ((endp alist) nil) (t (let* ((pair (car alist)) (expr (car pair)) (type (cdr pair))) (mv-let (flg unify-subst) (one-way-unify expr x) (cond (flg (let ((unify-subst (type-spec-fix-unify-subst unify-subst))) (cond ((eq unify-subst :fail) nil) (t (cons (remove-fake-unquotes (sublis-var unify-subst type)) (cdr (assoc-eq 'var unify-subst))))))) (t (type-spec-and-var-from-type-expression-1 x (cdr alist)))))))))
type-spec-and-var-from-type-expressionfunction
(defun type-spec-and-var-from-type-expression (x alist) (let ((pair (type-spec-and-var-from-type-expression-1 x alist))) (cond (pair (let ((type-spec (car pair)) (var (cdr pair))) (cons type-spec var))) (t (case-match x (('if x1 x2 *nil*) (let ((pair1 (type-spec-and-var-from-type-expression x1 alist))) (and pair1 (let ((pair2 (type-spec-and-var-from-type-expression x2 alist))) (and pair2 (eq (cdr pair1) (cdr pair2)) (cons `(and ,(CAR PAIR1) ,(CAR PAIR2)) (cdr pair1))))))) (('if x1 x1 x2) (let ((pair1 (type-spec-and-var-from-type-expression x1 alist))) (and pair1 (let ((pair2 (type-spec-and-var-from-type-expression x2 alist))) (and pair2 (eq (cdr pair1) (cdr pair2)) (cons `(or ,(CAR PAIR1) ,(CAR PAIR2)) (cdr pair1))))))) (('not x1) (let ((pair (type-spec-and-var-from-type-expression x1 alist))) (and pair (cons `(not ,(CAR PAIR)) (cdr pair))))) (('(lambda (x l) (return-last 'mbe1-raw (member-eql-exec x l) (return-last 'progn (member-eql-exec$guard-check x l) (member-equal x l)))) x1 ('quote lst)) (and (legal-variablep x1) (eqlable-listp lst) (cons `(member ,@LST) x1))) (('if ('complex-rationalp var) ('if (tp ('realpart var)) (tp ('imagpart var)) *nil*) *nil*) (let ((pair (type-spec-and-var-from-type-expression `(,TP ,VAR) alist))) (and pair (cons `(complex ,(CAR PAIR)) (cdr pair))))) (& nil))))))
type-spec-to-varlist-alistfunction
(defun type-spec-to-varlist-alist (lst alist) (cond ((endp lst) nil) (t (let* ((expr (car lst)) (pair (type-spec-and-var-from-type-expression expr alist))) (and pair (let ((rest (type-spec-to-varlist-alist (cdr lst) alist)) (key (car pair)) (var (cdr pair))) (put-assoc-equal key (add-to-set-eq var (cdr (assoc-equal key rest))) rest)))))))
recover-type-spec-exprs!1function
(defun recover-type-spec-exprs!1 (term) (case-match term (('return-last ''progn ('check-dcl-guardian guard ('quote guard)) rest) (cons guard (recover-type-spec-exprs!1 rest))) (('check-dcl-guardian guard ('quote guard)) (cons guard nil)) (& nil)))
recover-type-spec-exprs!function
(defun recover-type-spec-exprs! (x) (case-match x (('return-last ''progn ('return-last ''progn ('check-dcl-guardian & &) &) term) (let ((lst (recover-type-spec-exprs!1 (fargn x 2)))) (cond (lst (mv lst term)) (t (mv nil x))))) (('return-last ''progn ('check-dcl-guardian guard ('quote guard)) term) (mv (list guard) term)) (& (mv nil x))))
split-type-specs-from-termfunction
(defun split-type-specs-from-term (term) (mv-let (lst term) (recover-type-spec-exprs! term) (cond ((null lst) (mv nil term)) (t (mv (pairlis-x1 'type (reverse (type-spec-to-varlist-alist lst *type-expr-to-type-spec-alist*))) term)))))
other
(defattach untranslate-lambda-object-p constant-t-function-arity-0)
untranslate-lambda-object-cheatfunction
(defun untranslate-lambda-object-cheat nil (declare (xargs :guard t :mode :logic)) :untranslate-lambda-object-cheat)
do-body-guard-wrapperfunction
(defun do-body-guard-wrapper (x y) (declare (xargs :guard t :mode :logic) (ignore y)) x)
collect-all-stobj-namesfunction
(defun collect-all-stobj-names (vars known-stobjs wrld) (cond ((endp vars) nil) ((stobjp (car vars) known-stobjs wrld) (cons (car vars) (collect-all-stobj-names (cdr vars) known-stobjs wrld))) (t (collect-all-stobj-names (cdr vars) known-stobjs wrld))))
eviscerate-do$-alistfunction
(defun eviscerate-do$-alist (alist all-stobj-names) (declare (xargs :guard (true-listp all-stobj-names) :mode :program)) (cond ((atom alist) nil) ((or (atom (car alist)) (not (symbolp (caar alist)))) (cons (car alist) (eviscerate-do$-alist (cdr alist) all-stobj-names))) (t (let* ((key (caar alist)) (val (cdar alist)) (new-val (cond ((dfp val) (to-dfp val)) ((member-eq key all-stobj-names) (stobj-print-name key)) (t val)))) (cons (cons key new-val) (eviscerate-do$-alist (cdr alist) all-stobj-names))))))
guard-rawmutual-recursion
(mutual-recursion (defun guard-raw (fn wrld) (let ((trip (assoc-eq fn *primitive-formals-and-guards*))) (cond (trip (untranslate* (caddr trip) t wrld)) (t (let ((def (get-defun-event fn wrld))) (cond ((null def) (er hard! 'guard-raw "Unable to find defining event for ~x0." fn)) (t (mv-let (dcls guard) (dcls-guard-raw-from-def (cdr def) wrld) (declare (ignore dcls)) guard)))))))) (defun ev-fncall-guard-er (fn args w user-stobj-alist latches extra) (mv t (ev-fncall-guard-er-msg fn (guard-raw fn w) (stobjs-in fn w) args w user-stobj-alist extra) latches)) (defun ev-fncall-rec-logical (fn arg-values arg-exprs w user-stobj-alist big-n safe-mode gc-off latches hard-error-returns-nilp aok warranted-fns) (declare (xargs :guard (and (plist-worldp w) (symbol-listp warranted-fns)))) (cond ((zp-big-n big-n) (mv t (cons "Evaluation ran out of time." nil) latches)) (t (let* ((x (car arg-values)) (y (cadr arg-values)) (pair (assoc-eq 'state latches)) (w (if pair (w-of-any-state (cdr pair)) w)) (safe-mode-requires-check (and safe-mode (acl2-system-namep fn w) (not (equal (symbol-package-name fn) "ACL2")))) (stobj-primitive-p (let ((st (getpropc fn 'stobj-function nil w))) (and st (member-eq st (stobjs-in fn w))))) (guard-checking-off (and gc-off (not safe-mode-requires-check) (not stobj-primitive-p))) (extra (if gc-off (cond (safe-mode-requires-check t) ((not guard-checking-off) :live-stobj) (t nil)) (and stobj-primitive-p :live-stobj-gc-on)))) (case fn (acl2-numberp (mv nil (acl2-numberp x) latches)) (bad-atom<= (cond ((or guard-checking-off (and (bad-atom x) (bad-atom y))) (mv nil (bad-atom<= x y) latches)) (t (ev-fncall-guard-er fn arg-values w user-stobj-alist latches extra)))) (binary-* (cond ((or guard-checking-off (and (acl2-numberp x) (acl2-numberp y))) (mv nil (* x y) latches)) (t (ev-fncall-guard-er fn arg-values w user-stobj-alist latches extra)))) (binary-+ (cond ((or guard-checking-off (and (acl2-numberp x) (acl2-numberp y))) (mv nil (+ x y) latches)) (t (ev-fncall-guard-er fn arg-values w user-stobj-alist latches extra)))) (unary-- (cond ((or guard-checking-off (acl2-numberp x)) (mv nil (- x) latches)) (t (ev-fncall-guard-er fn arg-values w user-stobj-alist latches extra)))) (unary-/ (cond ((or guard-checking-off (and (acl2-numberp x) (not (= x 0)))) (mv nil (/ x) latches)) (t (ev-fncall-guard-er fn arg-values w user-stobj-alist latches extra)))) (< (cond ((or guard-checking-off (and (real/rationalp x) (real/rationalp y))) (mv nil (< x y) latches)) (t (ev-fncall-guard-er fn arg-values w user-stobj-alist latches extra)))) (car (cond ((or guard-checking-off (or (consp x) (eq x nil))) (mv nil (car x) latches)) (t (ev-fncall-guard-er fn arg-values w user-stobj-alist latches extra)))) (cdr (cond ((or guard-checking-off (or (consp x) (eq x nil))) (mv nil (cdr x) latches)) (t (ev-fncall-guard-er fn arg-values w user-stobj-alist latches extra)))) (char-code (cond ((or guard-checking-off (characterp x)) (mv nil (char-code x) latches)) (t (ev-fncall-guard-er fn arg-values w user-stobj-alist latches extra)))) (characterp (mv nil (characterp x) latches)) (code-char (cond ((or guard-checking-off (and (integerp x) (<= 0 x) (< x 256))) (mv nil (code-char x) latches)) (t (ev-fncall-guard-er fn arg-values w user-stobj-alist latches extra)))) (complex (cond ((or guard-checking-off (and (real/rationalp x) (real/rationalp y))) (mv nil (complex x y) latches)) (t (ev-fncall-guard-er fn arg-values w user-stobj-alist latches extra)))) (complex-rationalp (mv nil (complex-rationalp x) latches)) (coerce (cond ((or guard-checking-off (or (and (stringp x) (eq y 'list)) (and (character-listp x) (eq y 'string)))) (mv nil (coerce x y) latches)) (t (ev-fncall-guard-er fn arg-values w user-stobj-alist latches extra)))) (cons (mv nil (cons x y) latches)) (consp (mv nil (consp x) latches)) (denominator (cond ((or guard-checking-off (rationalp x)) (mv nil (denominator x) latches)) (t (ev-fncall-guard-er fn arg-values w user-stobj-alist latches extra)))) (equal (mv nil (equal x y) latches)) (if (mv nil (er hard 'ev-fncall-rec "This function should not be called with fn = 'IF!") latches)) (imagpart (cond ((or guard-checking-off (acl2-numberp x)) (mv nil (imagpart x) latches)) (t (ev-fncall-guard-er fn arg-values w user-stobj-alist latches extra)))) (integerp (mv nil (integerp x) latches)) (intern-in-package-of-symbol (cond ((or guard-checking-off (and (stringp x) (symbolp y))) (mv nil (intern-in-package-of-symbol x y) latches)) (t (ev-fncall-guard-er fn arg-values w user-stobj-alist latches extra)))) (numerator (cond ((or guard-checking-off (rationalp x)) (mv nil (numerator x) latches)) (t (ev-fncall-guard-er fn arg-values w user-stobj-alist latches extra)))) (pkg-imports (cond ((or guard-checking-off (stringp x)) (mv nil (pkg-imports x) latches)) (t (ev-fncall-guard-er fn arg-values w user-stobj-alist latches extra)))) (pkg-witness (cond ((or guard-checking-off (and (stringp x) (not (equal x "")))) (mv nil (pkg-witness x) latches)) (t (ev-fncall-guard-er fn arg-values w user-stobj-alist latches extra)))) (rationalp (mv nil (rationalp x) latches)) (realpart (cond ((or guard-checking-off (acl2-numberp x)) (mv nil (realpart x) latches)) (t (ev-fncall-guard-er fn arg-values w user-stobj-alist latches extra)))) (stringp (mv nil (stringp x) latches)) (symbol-name (cond ((or guard-checking-off (symbolp x)) (mv nil (symbol-name x) latches)) (t (ev-fncall-guard-er fn arg-values w user-stobj-alist latches extra)))) (symbol-package-name (cond ((or guard-checking-off (symbolp x)) (mv nil (symbol-package-name x) latches)) (t (ev-fncall-guard-er fn arg-values w user-stobj-alist latches extra)))) (symbolp (mv nil (symbolp x) latches)) (otherwise (cond ((and (eq fn 'apply$-userfn) (consp warranted-fns) (member-eq x warranted-fns) (or guard-checking-off (true-listp arg-values))) (ev-fncall-rec-logical x y nil w user-stobj-alist big-n safe-mode gc-off latches hard-error-returns-nilp aok warranted-fns)) ((and (eq fn 'badge-userfn) (consp warranted-fns) (member-eq x warranted-fns)) (mv nil (get-badge x w) latches)) ((and (null arg-values) (car (stobjs-out fn w))) (mv t (ev-fncall-creator-er-msg fn) latches)) (t (let ((alist (pairlis$ (formals fn w) arg-values)) (body (body fn nil w)) (attachment (and aok (not (member-eq fn (global-val 'attach-nil-lst w))) (cdr (attachment-pair fn w))))) (mv-let (er val latches) (ev-rec (if guard-checking-off ''t (guard fn nil w)) alist w user-stobj-alist (decrement-big-n big-n) (eq extra t) guard-checking-off latches hard-error-returns-nilp aok) (cond (er (mv er val latches)) ((null val) (ev-fncall-guard-er fn arg-values w user-stobj-alist latches extra)) ((and (eq fn 'hard-error) (not hard-error-returns-nilp)) (mv t (illegal-msg) latches)) ((eq fn 'throw-nonexec-error) (ev-fncall-null-body-er nil (car arg-values) (cadr arg-values) latches)) ((member-eq fn '(pkg-witness pkg-imports)) (mv t (unknown-pkg-error-msg fn (car arg-values)) latches)) (attachment (ev-fncall-rec-logical attachment arg-values arg-exprs w user-stobj-alist (decrement-big-n big-n) safe-mode gc-off latches hard-error-returns-nilp aok warranted-fns)) ((null body) (cond ((eq (getpropc fn 'constrainedp nil w) *unknown-constraints*) (ev-fncall-rec-logical-unknown-constraints fn arg-values w user-stobj-alist (decrement-big-n big-n) safe-mode gc-off latches hard-error-returns-nilp aok warranted-fns)) (t (ev-fncall-null-body-er attachment (car arg-values) (cadr arg-values) latches)))) (t (mv-let (er val latches) (ev-rec body alist w user-stobj-alist (decrement-big-n big-n) (eq extra t) guard-checking-off latches hard-error-returns-nilp aok) (cond (er (mv er val latches)) ((eq fn 'return-last) (mv nil val latches)) (t (mv nil val (and latches (latch-stobjs (actual-stobjs-out fn arg-exprs w) val latches)))))))))))))))))) (defun ev-fncall-rec (fn arg-values arg-exprs w user-stobj-alist big-n safe-mode gc-off latches hard-error-returns-nilp aok) (declare (xargs :guard (plist-worldp w))) (ev-fncall-rec-logical fn arg-values arg-exprs w user-stobj-alist big-n safe-mode gc-off latches hard-error-returns-nilp aok nil)) (defun ev-rec-return-last (fn arg2 arg3 alist w user-stobj-alist big-n safe-mode gc-off latches hard-error-returns-nilp aok) (assert$ (not (eq fn 'mbe1-raw)) (mv-let (er arg2-val latches) (let nil (ev-rec arg2 alist w user-stobj-alist (decrement-big-n big-n) safe-mode gc-off latches hard-error-returns-nilp t)) (cond (er (mv er arg2-val latches)) (t (case fn ((progn ec-call1-raw) (ev-rec arg3 alist w user-stobj-alist (decrement-big-n big-n) safe-mode gc-off latches hard-error-returns-nilp aok)) (with-guard-checking1-raw (return-last 'with-guard-checking1-raw arg2-val (ev-rec arg3 alist w user-stobj-alist (decrement-big-n big-n) safe-mode (gc-off1 arg2-val) latches hard-error-returns-nilp aok))) (otherwise (ev-rec arg3 alist w user-stobj-alist (decrement-big-n big-n) safe-mode gc-off latches hard-error-returns-nilp aok)))))))) (defun ev-rec (form alist w user-stobj-alist big-n safe-mode gc-off latches hard-error-returns-nilp aok) (declare (xargs :guard (and (plist-worldp w) (termp form w) (symbol-alistp alist)))) (cond ((zp-big-n big-n) (mv t (cons "Evaluation ran out of time." nil) latches)) ((variablep form) (let ((pair (assoc-eq form alist))) (cond (pair (mv nil (cdr pair) latches)) (t (mv t (msg "Unbound variable ~x0.~#1~[~/ Note that ~x0 is ~ not a global stobj; see :DOC add-global-stobj.~]" form (if (stobjp form t w) 1 0)) latches))))) ((fquotep form) (mv nil (cadr form) latches)) ((translated-acl2-unwind-protectp form) (ev-rec-acl2-unwind-protect form alist w user-stobj-alist (decrement-big-n big-n) safe-mode gc-off latches hard-error-returns-nilp aok)) ((eq (ffn-symb form) 'wormhole-eval) (mv nil nil latches)) ((eq (ffn-symb form) 'if) (mv-let (test-er test latches) (ev-rec (fargn form 1) alist w user-stobj-alist (decrement-big-n big-n) safe-mode gc-off latches hard-error-returns-nilp aok) (cond (test-er (mv test-er test latches)) (test (ev-rec (fargn form 2) alist w user-stobj-alist (decrement-big-n big-n) safe-mode gc-off latches hard-error-returns-nilp aok)) (t (ev-rec (fargn form 3) alist w user-stobj-alist (decrement-big-n big-n) safe-mode gc-off latches hard-error-returns-nilp aok))))) ((eq (ffn-symb form) 'mv-list) (ev-rec (fargn form 2) alist w user-stobj-alist (decrement-big-n big-n) safe-mode gc-off latches hard-error-returns-nilp aok)) ((and (eq (ffn-symb form) 'return-last) (not (and (equal (fargn form 1) ''mbe1-raw) safe-mode))) (let ((fn (and (quotep (fargn form 1)) (unquote (fargn form 1))))) (cond ((and fn (symbolp fn)) (cond ((eq fn 'mbe1-raw) (ev-rec (fargn form 3) alist w user-stobj-alist (decrement-big-n big-n) safe-mode gc-off latches hard-error-returns-nilp aok)) (t (ev-rec-return-last fn (fargn form 2) (fargn form 3) alist w user-stobj-alist big-n safe-mode gc-off latches hard-error-returns-nilp aok)))) (t (mv-let (args-er args latches) (ev-rec-lst (fargs form) alist w user-stobj-alist (decrement-big-n big-n) safe-mode gc-off latches hard-error-returns-nilp aok) (cond (args-er (mv args-er args latches)) (t (mv nil (car (last args)) latches)))))))) (t (mv-let (args-er args latches) (ev-rec-lst (fargs form) alist w user-stobj-alist (decrement-big-n big-n) safe-mode gc-off latches hard-error-returns-nilp aok) (cond (args-er (mv args-er args latches)) ((flambda-applicationp form) (ev-rec (lambda-body (ffn-symb form)) (pairlis$ (lambda-formals (ffn-symb form)) args) w user-stobj-alist (decrement-big-n big-n) safe-mode gc-off latches hard-error-returns-nilp aok)) (t (ev-fncall-rec (ffn-symb form) args (fargs form) w user-stobj-alist (decrement-big-n big-n) safe-mode gc-off latches hard-error-returns-nilp aok))))))) (defun ev-rec-lst (lst alist w user-stobj-alist big-n safe-mode gc-off latches hard-error-returns-nilp aok) (declare (xargs :guard (and (plist-worldp w) (term-listp lst w) (symbol-alistp alist)))) (cond ((zp-big-n big-n) (mv t (cons "Evaluation ran out of time." nil) latches)) ((null lst) (mv nil nil latches)) (t (mv-let (first-er first-val first-latches) (ev-rec (car lst) alist w user-stobj-alist (decrement-big-n big-n) safe-mode gc-off latches hard-error-returns-nilp aok) (cond (first-er (mv first-er first-val first-latches)) (t (mv-let (rest-er rest-val rest-latches) (ev-rec-lst (cdr lst) alist w user-stobj-alist (decrement-big-n big-n) safe-mode gc-off first-latches hard-error-returns-nilp aok) (cond (rest-er (mv rest-er rest-val rest-latches)) (t (mv nil (cons first-val rest-val) rest-latches)))))))))) (defun ev-rec-acl2-unwind-protect (form alist w user-stobj-alist big-n safe-mode gc-off latches hard-error-returns-nilp aok) (declare (xargs :guard (and (plist-worldp w) (termp form w) (symbol-alistp alist)))) (let ((temp nil)) (declare (ignore temp)) (mv-let (ans body cleanup1 cleanup2) (translated-acl2-unwind-protectp4 form) (declare (ignore ans)) (mv-let (body-erp body-val body-latches) (ev-rec body alist w user-stobj-alist big-n safe-mode gc-off latches hard-error-returns-nilp aok) (cond (body-erp (mv-let (clean-erp clean-val clean-latches) (ev-rec cleanup1 (put-assoc-eq 'state (cdr (assoc-eq 'state body-latches)) alist) w user-stobj-alist big-n safe-mode gc-off body-latches hard-error-returns-nilp aok) (cond (clean-erp (mv t (msg "An evaluation error, ``~@0'', occurred while ~ evaluating the body of an acl2-unwind-protect ~ form. While evaluating the first cleanup form a ~ second evaluation error occurred, ``~@1''. The ~ body of the acl2-unwind-protect is ~p2 and the ~ first cleanup form is ~p3. Because the cleanup ~ form failed, the state being returned may not be ~ fully cleaned up." body-val clean-val (untranslate* body nil w) (untranslate* cleanup1 nil w)) clean-latches)) (t (mv body-erp body-val clean-latches))))) ((car body-val) (mv-let (clean-erp clean-val clean-latches) (ev-rec cleanup1 (put-assoc-eq 'state (cdr (assoc-eq 'state body-latches)) alist) w user-stobj-alist big-n safe-mode gc-off body-latches hard-error-returns-nilp aok) (cond (clean-erp (mv t (msg "An evaluation error, ``~@0'', occurred while ~ evaluating the first cleanup form of an ~ acl2-unwind-protect. The body of the ~ acl2-unwind-protect is ~p1 and the first cleanup ~ form is ~p2. Because the cleanup form failed, ~ the state being returned may not be fully cleaned ~ up." clean-val (untranslate* body nil w) (untranslate* cleanup1 nil w)) clean-latches)) (t (mv nil (list (car body-val) (cadr body-val) (cdr (assoc-eq 'state clean-latches))) clean-latches))))) (t (mv-let (clean-erp clean-val clean-latches) (ev-rec cleanup2 (put-assoc-eq 'state (cdr (assoc-eq 'state body-latches)) alist) w user-stobj-alist big-n safe-mode gc-off body-latches hard-error-returns-nilp aok) (cond (clean-erp (mv t (msg "An evaluation error, ``~@0'', occurred while ~ evaluating the second cleanup form of an ~ acl2-unwind-protect. The body of the ~ acl2-unwind-protect is ~p1 and the second cleanup ~ form is ~p2. Because the cleanup form failed, ~ the state being returned may not be fully cleaned ~ up." clean-val (untranslate* body nil w) (untranslate* cleanup2 nil w)) clean-latches)) (t (mv nil (list (car body-val) (cadr body-val) (cdr (assoc-eq 'state clean-latches))) clean-latches)))))))))) (defun ev-fncall-w-body (fn args w user-stobj-alist safe-mode gc-off hard-error-returns-nilp aok) (mv-let (erp val latches) (ev-fncall-rec fn args nil w user-stobj-alist (big-n) safe-mode gc-off nil hard-error-returns-nilp aok) (declare (ignore latches)) (mv erp val))) (defun ev-fncall-w (fn args w user-stobj-alist safe-mode gc-off hard-error-returns-nilp aok) (declare (xargs :guard (ev-fncall-w-guard fn args w nil))) (ev-fncall-w-body fn args w user-stobj-alist safe-mode gc-off hard-error-returns-nilp aok)) (defun ev-fncall-w! (fn args w user-stobj-alist safe-mode gc-off hard-error-returns-nilp aok) (declare (xargs :guard t)) (if (ev-fncall-w-guard fn args w nil) (ev-fncall-w-body fn args w user-stobj-alist safe-mode gc-off hard-error-returns-nilp aok) (mv t (msg "Guard failure for ~x0 in a call of ~x1: fn = ~x2, args = ~X34" 'ev-fncall-w-guard 'ev-fncall-w! fn args (evisc-tuple 5 7 (list (cons w *evisceration-world-mark*)) nil))))) (defun ev-w (form alist w user-stobj-alist safe-mode gc-off hard-error-returns-nilp aok) (declare (xargs :guard (and (plist-worldp w) (termp form w) (symbol-alistp alist)))) (mv-let (erp val latches) (ev-rec form alist w user-stobj-alist (big-n) safe-mode gc-off nil hard-error-returns-nilp aok) (declare (ignore latches)) (mv erp val))) (defun guard-er-message-coda (fn stobjs-in args w extra erp) (msg "~@0~@1~@2~@3" (cond ((and (eq fn 'return-last) (eq (car args) 'mbe1-raw)) (msg " This offending call is equivalent to the more common ~ form, ~x0." `(mbe :logic ,(UNTRANSLATE* (KWOTE (CADDR ARGS)) NIL W) :exec ,(UNTRANSLATE* (KWOTE (CADR ARGS)) NIL W)))) (t "")) (cond ((eq extra :live-stobj) (msg "~|This error is being reported even though guard-checking ~ has been turned off, because a stobj argument of ~x0 is ~ the ``live'' ~p1 and ACL2 does not support non-compliant ~ live stobj manipulation." fn (let ((stobjs (collect-non-nil-df stobjs-in))) (assert$ (consp stobjs) (car stobjs))))) ((eq extra :live-stobj-gc-on) (msg "~|This error will be reported even if guard-checking is ~ turned off, because a stobj argument of ~x0 is the ~ ``live'' ~p1 and ACL2 does not support non-compliant live ~ stobj manipulation." fn (let ((stobjs (collect-non-nil-df stobjs-in))) (assert$ (consp stobjs) (car stobjs))))) ((eq extra :no-extra) "") (extra *safe-mode-guard-er-addendum*) (t "~|See :DOC set-guard-checking for information about ~ suppressing this check with (set-guard-checking :none), as ~ recommended for new users.")) (error-trace-suggestion t) (if erp (msg "~|~%Note: Evaluation has resulted in an error for the form ~ associated with ~x0 in the table, ~x1, to obtain a custom ~ guard error message. Consider modifying that table entry; ~ see :doc set-guard-msg." fn 'guard-msg-table) ""))) (defun do-body-guard-form (fn args wrld) (and (flambdap fn) (consp args) (null (cdr args)) (case-match fn (('lambda '(alist) ('declare ('xargs :guard ('do-body-guard-wrapper g ('quote all-stobj-names)) . &) . &) . &) (if (true-listp all-stobj-names) (list 'quote (msg "The guard for a DO$ form,~|~x0,~| has been violated by the ~ following alist:~|~x1.~|See :DOC do-loop$." (untranslate* g nil wrld) (eviscerate-do$-alist (car args) all-stobj-names))) nil)) (& nil)))) (defun ev-fncall-guard-er-msg (fn guard stobjs-in args w user-stobj-alist extra) (prog2$ (save-ev-fncall-guard-er fn guard stobjs-in args w) (let ((form (if (symbolp fn) (cdr (assoc-eq fn (table-alist 'guard-msg-table w))) (do-body-guard-form fn args w)))) (mv-let (erp msg) (cond (form (ev-w form (list (cons 'world w) (cons 'args args) (cons 'coda (guard-er-message-coda fn stobjs-in args w extra nil))) w user-stobj-alist nil t t t)) (t (mv nil nil))) (or msg (if (and (consp fn) (consp guard) (eq (car guard) :not-a-term)) (msg "The guard for the function call ~X01, which is ~X21, is not a ~ term and so cannot be evaluated! (This can happen when ~ lambda objects in the compiled lambda cache have had ~ supporters undone but then the now-invalid quoted constant is ~ applied with apply$.)~@3" (cons fn (lambda-object-formals fn)) nil (cdr guard) (guard-er-message-coda fn stobjs-in args w extra erp)) (msg "The guard for the~#0~[ :program~/~] function call ~x1, which ~ is ~P23, is violated by the arguments in the call ~P45.~@6" (if (and (symbolp fn) (programp fn w)) 0 1) (cons fn (if (symbolp fn) (formals fn w) (lambda-object-formals fn))) guard nil (cons fn (untranslate*-lst (apply-user-stobj-alist-or-kwote user-stobj-alist args nil) nil w)) (evisc-tuple 3 4 nil nil) (guard-er-message-coda fn stobjs-in args w extra erp)))))))) (defun ev-fncall-msg (val wrld user-stobj-alist) (cond ((and (consp val) (eq (car val) 'ev-fncall-null-body-er)) (ev-fncall-null-body-er-msg (cadr val) (caddr val) (cdddr val))) ((and (consp val) (eq (car val) 'ev-fncall-guard-er)) (ev-fncall-guard-er-msg (cadr val) (cadddr val) (car (cddddr val)) (caddr val) wrld user-stobj-alist (cadr (cddddr val)))) ((and (consp val) (eq (car val) 'ev-fncall-creator-er)) (ev-fncall-creator-er-msg (cadr val))) ((and (consp val) (member-eq (car val) '(pkg-witness pkg-imports))) (unknown-pkg-error-msg (car val) (cadr val))) ((eq val 'illegal) (illegal-msg)) (t (er hard 'raw-ev-fncall "An unrecognized value, ~x0, was thrown to 'raw-ev-fncall.~@1" val (error-trace-suggestion t))))) (defun untranslate1-lambda-object-edcls (edcls untrans-tbl preprocess-fn wrld) (cond ((endp edcls) nil) ((eq (car (car edcls)) 'xargs) (let ((g (caddr (car edcls)))) (cons `(xargs :guard ,(UNTRANSLATE1 G T UNTRANS-TBL PREPROCESS-FN WRLD) :split-types t) (untranslate1-lambda-object-edcls (cdr edcls) untrans-tbl preprocess-fn wrld)))) ((or (eq (car (car edcls)) 'ignore) (eq (car (car edcls)) 'ignorable)) (untranslate1-lambda-object-edcls (cdr edcls) untrans-tbl preprocess-fn wrld)) (t (cons (car edcls) (untranslate1-lambda-object-edcls (cdr edcls) untrans-tbl preprocess-fn wrld))))) (defun untranslate1-lambda-object (x untrans-tbl preprocess-fn wrld) (let* ((formals (lambda-object-formals x)) (dcl (lambda-object-dcl x)) (edcls1 (untranslate1-lambda-object-edcls (cdr dcl) untrans-tbl preprocess-fn wrld)) (body (if (lambda$-bodyp (lambda-object-body x)) (fargn (lambda-object-body x) 3) (lambda-object-body x)))) `(lambda$ ,FORMALS ,@(IF EDCLS1 `((DECLARE ,@EDCLS1)) NIL) ,(UNTRANSLATE1 BODY NIL UNTRANS-TBL PREPROCESS-FN WRLD)))) (defun untranslate1-lambda-objects-in-fn-slots (args ilks iff-flg untrans-tbl preprocess-fn wrld) (cond ((endp args) nil) ((and (eq (car ilks) :fn) (quotep (car args)) (eq (car (unquote (car args))) 'lambda)) (let* ((lp (untranslate-lambda-object-p)) (obj (unquote (car args))) (first (cond ((or (not lp) (not (well-formed-lambda-objectp obj wrld))) (car args)) ((and (eq lp (untranslate-lambda-object-cheat)) (let ((body (lambda-object-body obj))) (and (lambda$-bodyp body) (unquote (fargn body 2)))))) ((lambda$-bodyp (lambda-object-body obj)) (let ((alleged-lambda$ (unquote (fargn (lambda-object-body obj) 2)))) (mv-let (erp val bindings) (translate11-lambda-object-proxy alleged-lambda$ t nil t nil nil 'untranslate1-lambda-objects-in-fn-slots wrld *default-state-vars* nil) (declare (ignore bindings)) (cond ((and (null erp) (equal val (car args))) alleged-lambda$) (t (car args)))))) ((mv-let (warrants unwarranteds) (warrants-for-tamep-lambdap obj wrld nil nil) (declare (ignore warrants)) unwarranteds) (car args)) (t (untranslate1-lambda-object obj untrans-tbl preprocess-fn wrld))))) (cons first (untranslate1-lambda-objects-in-fn-slots (cdr args) (cdr ilks) iff-flg untrans-tbl preprocess-fn wrld)))) (t (cons (untranslate1 (car args) iff-flg untrans-tbl preprocess-fn wrld) (untranslate1-lambda-objects-in-fn-slots (cdr args) (cdr ilks) iff-flg untrans-tbl preprocess-fn wrld))))) (defun untranslate1-possible-scion-call (term iff-flg untrans-tbl preprocess-fn wrld) (declare (ignore iff-flg)) (let* ((fn (ffn-symb term)) (args (fargs term)) (badge (executable-badge fn wrld)) (ilks (if badge (access apply$-badge badge :ilks) t))) (cons fn (if (eq ilks t) (untranslate1-lst args nil untrans-tbl preprocess-fn wrld) (untranslate1-lambda-objects-in-fn-slots args ilks nil untrans-tbl preprocess-fn wrld))))) (defun untranslate1 (term iff-flg untrans-tbl preprocess-fn wrld) (let ((term (if preprocess-fn (mv-let (erp term1) (ev-fncall-w preprocess-fn (list term wrld) wrld nil nil nil nil t) (or (and (null erp) term1) term)) term))) (cond ((variablep term) term) ((fquotep term) (cond ((or (acl2-numberp (cadr term)) (stringp (cadr term)) (characterp (cadr term)) (eq (cadr term) nil) (eq (cadr term) t) (keywordp (cadr term))) (cadr term)) (t term))) ((flambda-applicationp term) (or (case-match term ((('lambda (mv-var . rest) (('lambda vars/rest body) . mv-nths/rest)) tm . rest) (let* ((len-rest (len rest)) (len-vars/rest (len vars/rest)) (len-vars (- len-vars/rest len-rest))) (and (true-listp rest) (true-listp mv-nths/rest) (true-listp vars/rest) (<= 2 len-vars) (equal len-vars/rest (len mv-nths/rest)) (equal (nthcdr len-vars vars/rest) rest) (equal (nthcdr len-vars mv-nths/rest) rest) (mv-let (flg ignores) (collect-ignored-mv-vars mv-var 0 len-vars vars/rest mv-nths/rest) (and flg (mv-let (type-specs body) (split-type-specs-from-term body) (let* ((uterm (untranslate1 tm nil untrans-tbl preprocess-fn wrld)) (uterm (maybe-convert-to-mv uterm)) (ubody (untranslate1 body iff-flg untrans-tbl preprocess-fn wrld))) `(mv-let ,(TAKE LEN-VARS VARS/REST) ,UTERM ,@(AND (OR IGNORES TYPE-SPECS) `((DECLARE ,@(AND IGNORES `((IGNORE ,@IGNORES))) ,@TYPE-SPECS))) ,UBODY))))))))) (mv-let (type-specs body) (split-type-specs-from-term (lambda-body (ffn-symb term))) (let ((bindings (collect-non-trivial-bindings (lambda-formals (ffn-symb term)) (untranslate1-lst (fargs term) nil untrans-tbl preprocess-fn wrld)))) (make-let-or-let* bindings type-specs (untranslate1 body iff-flg untrans-tbl preprocess-fn wrld)))))) ((eq (ffn-symb term) 'if) (case-match term (('if x1 *nil* *t*) (negate-untranslated-form (untranslate1 x1 t untrans-tbl preprocess-fn wrld) iff-flg)) (('if x1 x2 *nil*) (untranslate-and (untranslate1 x1 t untrans-tbl preprocess-fn wrld) (untranslate1 x2 iff-flg untrans-tbl preprocess-fn wrld) iff-flg)) (('if x1 *nil* x2) (untranslate-and (negate-untranslated-form (untranslate1 x1 t untrans-tbl preprocess-fn wrld) t) (untranslate1 x2 iff-flg untrans-tbl preprocess-fn wrld) iff-flg)) (('if x1 x1 x2) (untranslate-or (untranslate1 x1 iff-flg untrans-tbl preprocess-fn wrld) (untranslate1 x2 iff-flg untrans-tbl preprocess-fn wrld))) (('if x1 x2 *t*) (untranslate-or (negate-untranslated-form (untranslate1 x1 t untrans-tbl preprocess-fn wrld) iff-flg) (untranslate1 x2 iff-flg untrans-tbl preprocess-fn wrld))) (('if x1 *t* x2) (cond ((or iff-flg (and (nvariablep x1) (not (fquotep x1)) (member-eq (ffn-symb x1) *untranslate-boolean-primitives*))) (untranslate-or (untranslate1 x1 t untrans-tbl preprocess-fn wrld) (untranslate1 x2 iff-flg untrans-tbl preprocess-fn wrld))) (t (untranslate-if term iff-flg untrans-tbl preprocess-fn wrld)))) (& (untranslate-if term iff-flg untrans-tbl preprocess-fn wrld)))) ((and (eq (ffn-symb term) 'not) (nvariablep (fargn term 1)) (not (fquotep (fargn term 1))) (member-eq (ffn-symb (fargn term 1)) '(< o<))) (list (if (eq (ffn-symb (fargn term 1)) '<) '<= 'o<=) (untranslate1 (fargn (fargn term 1) 2) nil untrans-tbl preprocess-fn wrld) (untranslate1 (fargn (fargn term 1) 1) nil untrans-tbl preprocess-fn wrld))) ((member-eq (ffn-symb term) '(implies iff)) (fcons-term* (ffn-symb term) (untranslate1 (fargn term 1) t untrans-tbl preprocess-fn wrld) (untranslate1 (fargn term 2) t untrans-tbl preprocess-fn wrld))) ((eq (ffn-symb term) 'cons) (untranslate-cons term untrans-tbl preprocess-fn wrld)) ((and (eq (ffn-symb term) 'synp) (all-quoteps (fargs term)) (let ((uarg2 (unquote (fargn term 2)))) (and (consp uarg2) (member-eq (car uarg2) '(syntaxp bind-free))))) (cadr (fargn term 2))) ((and (eq (ffn-symb term) 'return-last) (quotep (fargn term 1)) (let* ((key (unquote (fargn term 1))) (fn (and (symbolp key) key (let ((tmp (return-last-lookup key wrld))) (if (consp tmp) (car tmp) tmp)))) (args (and fn (untranslate1-lst (cdr (fargs term)) nil untrans-tbl preprocess-fn wrld)))) (and fn (case fn (mbe1 (let ((exec (car args)) (logic (cadr args))) (cond ((eq exec t) `(mbt ,LOGIC)) (t `(mbe :logic ,LOGIC :exec ,EXEC))))) (ec-call1 (cond ((eq (car args) nil) `(ec-call ,(CADR ARGS))) (t (cons fn args)))) (time$1 (or (and (eq key 'time$1-raw) (let ((car-args (car args)) (cadr-args (cadr args))) (mv-let (real-mintime run-mintime minalloc msg msg-args) (case-match car-args (('list real-mintime run-mintime minalloc msg msg-args) (mv real-mintime run-mintime minalloc msg msg-args)) (('quote (real-mintime run-mintime minalloc msg msg-args)) (mv (maybe-kwote real-mintime) (maybe-kwote run-mintime) (maybe-kwote minalloc) (maybe-kwote msg) (maybe-kwote msg-args))) (& (mv :fail nil nil nil nil))) (cond ((eq real-mintime :fail) (cons fn args)) (t `(time$ ,CADR-ARGS ,@(AND (NOT (EQL REAL-MINTIME 0)) `(:REAL-MINTIME ,REAL-MINTIME)) ,@(AND RUN-MINTIME `(:RUN-MINTIME ,RUN-MINTIME)) ,@(AND MINALLOC `(:MINALLOC ,MINALLOC)) ,@(AND MSG `(:MSG ,MSG)) ,@(AND MSG-ARGS `(:ARGS ,MSG-ARGS)))))))) (cons fn args))) (prog2$ (cond ((and (quotep (car args)) (consp (unquote (car args))) (eq (car (unquote (car args))) :comment)) (list 'comment (cdr (unquote (car args))) (cadr args))) (t (cons fn args)))) (otherwise (cons fn args))))))) (t (or (case-match term ((fmt-to-comment-window ('quote str) x ('quote '0) ('quote 'nil) base/radix) (and (member-eq fmt-to-comment-window '(fmt-to-comment-window fmt-to-comment-window!)) (let ((y (unmake-formal-pairlis2 x *base-10-chars*))) (cond ((eq y :fail) nil) ((equal base/radix *nil*) (list* (if (eq fmt-to-comment-window 'fmt-to-comment-window) 'cw 'cw!) str (untranslate1-lst y nil untrans-tbl preprocess-fn wrld))) (t (list* (if (eq fmt-to-comment-window 'fmt-to-comment-window) 'cw-print-base-radix 'cw-print-base-radix!) (untranslate1 base/radix nil untrans-tbl preprocess-fn wrld) str (untranslate1-lst y nil untrans-tbl preprocess-fn wrld))))))) (& nil)) (let* ((pair (cdr (assoc-eq (ffn-symb term) untrans-tbl))) (op (car pair)) (flg (cdr pair)) (const (and (member-eq (ffn-symb term) '(nth update-nth update-nth-array)) (quotep (fargn term 1)) (integerp (cadr (fargn term 1))) (<= 0 (cadr (fargn term 1))) (accessor-root (cadr (fargn term 1)) (case (ffn-symb term) (nth (fargn term 2)) (update-nth (fargn term 3)) (t (fargn term 4))) wrld)))) (cond (op (cons op (cond (const (cons const (untranslate1-lst (cdr (fargs term)) nil untrans-tbl preprocess-fn wrld))) (t (untranslate1-lst (cond ((and flg (cdr (fargs term)) (null (cddr (fargs term)))) (right-associated-args (ffn-symb term) term)) (t (fargs term))) nil untrans-tbl preprocess-fn wrld))))) (const (list* (ffn-symb term) const (untranslate1-lst (cdr (fargs term)) nil untrans-tbl preprocess-fn wrld))) (t (mv-let (ad-list base) (make-reversed-ad-list term nil) (cond (ad-list (pretty-parse-ad-list ad-list '(#\R) 1 (untranslate1 base nil untrans-tbl preprocess-fn wrld))) ((member-lambda-objectp (fargs term)) (untranslate1-possible-scion-call term iff-flg untrans-tbl preprocess-fn wrld)) (t (cons (ffn-symb term) (untranslate1-lst (fargs term) nil untrans-tbl preprocess-fn wrld))))))))))))) (defun untranslate-cons1 (term untrans-tbl preprocess-fn wrld) (cond ((variablep term) (mv nil (untranslate1 term nil untrans-tbl preprocess-fn wrld))) ((fquotep term) (mv nil (untranslate1 term nil untrans-tbl preprocess-fn wrld))) ((eq (ffn-symb term) 'cons) (mv-let (elements x) (untranslate-cons1 (fargn term 2) untrans-tbl preprocess-fn wrld) (mv (cons (untranslate1 (fargn term 1) nil untrans-tbl preprocess-fn wrld) elements) x))) (t (mv nil (untranslate1 term nil untrans-tbl preprocess-fn wrld))))) (defun untranslate-cons (term untrans-tbl preprocess-fn wrld) (mv-let (elements x) (untranslate-cons1 term untrans-tbl preprocess-fn wrld) (cond ((eq x nil) (cons 'list elements)) ((null (cdr elements)) (list 'cons (car elements) x)) (t (cons 'list* (append elements (list x))))))) (defun untranslate-if (term iff-flg untrans-tbl preprocess-fn wrld) (cond ((> (case-length nil term) 2) (case-match term (('if (& key &) & &) (list* 'case key (untranslate-into-case-clauses key term iff-flg untrans-tbl preprocess-fn wrld))))) ((> (cond-length term) 2) (cons 'cond (untranslate-into-cond-clauses term iff-flg untrans-tbl preprocess-fn wrld))) (t (list 'if (untranslate1 (fargn term 1) t untrans-tbl preprocess-fn wrld) (untranslate1 (fargn term 2) iff-flg untrans-tbl preprocess-fn wrld) (untranslate1 (fargn term 3) iff-flg untrans-tbl preprocess-fn wrld))))) (defun untranslate-into-case-clauses (key term iff-flg untrans-tbl preprocess-fn wrld) (case-match term (('if (pred !key ('quote val)) x y) (cond ((and (or (eq pred 'equal) (eq pred 'eql)) (eqlablep val)) (cond ((or (eq val t) (eq val nil) (eq val 'otherwise)) (cons (list (list val) (untranslate1 x iff-flg untrans-tbl preprocess-fn wrld)) (untranslate-into-case-clauses key y iff-flg untrans-tbl preprocess-fn wrld))) (t (cons (list val (untranslate1 x iff-flg untrans-tbl preprocess-fn wrld)) (untranslate-into-case-clauses key y iff-flg untrans-tbl preprocess-fn wrld))))) ((and (eq pred 'member) (eqlable-listp val)) (cons (list val (untranslate1 x iff-flg untrans-tbl preprocess-fn wrld)) (untranslate-into-case-clauses key y iff-flg untrans-tbl preprocess-fn wrld))) (t (list (list 'otherwise (untranslate1 term iff-flg untrans-tbl preprocess-fn wrld)))))) (& (list (list 'otherwise (untranslate1 term iff-flg untrans-tbl preprocess-fn wrld)))))) (defun untranslate-into-cond-clauses (term iff-flg untrans-tbl preprocess-fn wrld) (case-match term (('if x1 x2 x3) (cons (list (untranslate1 x1 t untrans-tbl preprocess-fn wrld) (untranslate1 x2 iff-flg untrans-tbl preprocess-fn wrld)) (untranslate-into-cond-clauses x3 iff-flg untrans-tbl preprocess-fn wrld))) (& (list (list t (untranslate1 term iff-flg untrans-tbl preprocess-fn wrld)))))) (defun untranslate1-lst (lst iff-flg untrans-tbl preprocess-fn wrld) (cond ((null lst) nil) (t (cons (untranslate1 (car lst) iff-flg untrans-tbl preprocess-fn wrld) (untranslate1-lst (cdr lst) iff-flg untrans-tbl preprocess-fn wrld))))))
ev-fncallfunction
(defun ev-fncall (fn arg-values arg-exprs state latches hard-error-returns-nilp aok) (declare (xargs :guard (state-p state))) (let nil (ev-fncall-rec fn arg-values arg-exprs (w state) (user-stobj-alist state) (big-n) (f-get-global 'safe-mode state) (gc-off state) latches hard-error-returns-nilp aok)))
evfunction
(defun ev (form alist state latches hard-error-returns-nilp aok) (declare (xargs :guard (and (state-p state) (termp form (w state)) (symbol-alistp alist)))) (let nil (ev-rec form alist (w state) (user-stobj-alist state) (big-n) (f-get-global 'safe-mode state) (gc-off state) latches hard-error-returns-nilp aok)))
ev-lstfunction
(defun ev-lst (lst alist state latches hard-error-returns-nilp aok) (declare (xargs :guard (and (state-p state) (term-listp lst (w state)) (symbol-alistp alist)))) (let nil (ev-rec-lst lst alist (w state) (user-stobj-alist state) (big-n) (f-get-global 'safe-mode state) (gc-off state) latches hard-error-returns-nilp aok)))
make-ersatz-mv-setqfunction
(defun make-ersatz-mv-setq (vars body) (list* 'ersatz-mv-setq body vars))
ersatz-mv-setq-varsfunction
(defun ersatz-mv-setq-vars (x) (cdr (fargs x)))
ersatz-mv-setq-bodyfunction
(defun ersatz-mv-setq-body (x) (car (fargs x)))
*cltl-to-ersatz-fns*constant
(defconst *cltl-to-ersatz-fns* '((prog2 ersatz-prog2 2) (setq ersatz-setq 2) (mv-setq ersatz-mv-setq 2) (return ersatz-return 1) (loop-finish ersatz-loop-finish 0)))
ersatz-functionpfunction
(defun ersatz-functionp (fn) (assoc-eq-cadr fn *cltl-to-ersatz-fns*))
ersatz-symbolsmutual-recursion
(mutual-recursion (defun ersatz-symbols (flg x) (cond ((variablep x) nil) ((fquotep x) nil) ((flambda-applicationp x) (let* ((temp1 (ersatz-symbols flg (lambda-body (ffn-symb x)))) (temp2 (if (and (eq flg t) temp1) t (ersatz-symbols-list flg (fargs x))))) (if (eq flg t) (or temp1 temp2) (union-eq temp1 temp2)))) ((ersatz-functionp (ffn-symb x)) (if (eq flg t) t (add-to-set-eq (if (eq flg :rename) (car (assoc-eq-cadr (ffn-symb x) *cltl-to-ersatz-fns*)) (ffn-symb x)) (ersatz-symbols-list flg (fargs x))))) (t (ersatz-symbols-list flg (fargs x))))) (defun ersatz-symbols-list (flg x) (cond ((endp x) nil) (t (let* ((temp1 (ersatz-symbols flg (car x))) (temp2 (if (and (eq flg t) temp1) t (ersatz-symbols-list flg (cdr x))))) (if (eq flg t) (or temp1 temp2) (union-eq temp1 temp2)))))))
untranslatefunction
(defun untranslate (term iff-flg wrld) (let ((user-untranslate (cdr (assoc-eq 'untranslate (table-alist 'user-defined-functions-table wrld))))) (if user-untranslate (mv-let (erp val) (ev-fncall-w user-untranslate (list term iff-flg wrld) wrld nil nil nil nil t) (cond (erp (untranslate* term iff-flg wrld)) (t val))) (untranslate* term iff-flg wrld))))
untranslate-lstfunction
(defun untranslate-lst (lst iff-flg wrld) (let ((user-untranslate-lst (cdr (assoc-eq 'untranslate-lst (table-alist 'user-defined-functions-table wrld))))) (if user-untranslate-lst (mv-let (erp val) (ev-fncall-w user-untranslate-lst (list lst iff-flg wrld) wrld nil nil nil nil t) (cond (erp (untranslate1-lst lst iff-flg (untrans-table wrld) (untranslate-preprocess-fn wrld) wrld)) (t val))) (untranslate1-lst lst iff-flg (untrans-table wrld) (untranslate-preprocess-fn wrld) wrld))))
replace-ersatz-functionsmutual-recursion
(mutual-recursion (defun replace-ersatz-functions (x) (cond ((variablep x) x) ((fquotep x) x) ((flambda-applicationp x) (let* ((formals (lambda-formals (ffn-symb x))) (body (lambda-body (ffn-symb x))) (actuals (fargs x)) (body1 (replace-ersatz-functions body))) (cons (list 'lambda formals body1) (replace-ersatz-functions-list actuals)))) ((ersatz-functionp (ffn-symb x)) (cond ((eq (ffn-symb x) 'ersatz-prog2) (let ((arg1 (replace-ersatz-functions (fargn x 1))) (arg2 (replace-ersatz-functions (fargn x 2)))) (cons 'progn (append (if (and (consp arg1) (eq (car arg1) 'progn)) (cdr arg1) (list arg1)) (if (and (consp arg2) (eq (car arg2) 'progn)) (cdr arg1) (list arg2)))))) ((eq (ffn-symb x) 'ersatz-mv-setq) (list 'mv-setq (ersatz-mv-setq-vars x) (replace-ersatz-functions (ersatz-mv-setq-body x)))) (t (let ((temp (assoc-eq-cadr (ffn-symb x) *cltl-to-ersatz-fns*))) (cons (car temp) (replace-ersatz-functions-list (fargs x))))))) (t (cons (ffn-symb x) (replace-ersatz-functions-list (fargs x)))))) (defun replace-ersatz-functions-list (x) (cond ((endp x) nil) (t (cons (replace-ersatz-functions (car x)) (replace-ersatz-functions-list (cdr x)))))))
untranslate-do-bodyfunction
(defun untranslate-do-body (x wrld) (untranslate (replace-ersatz-functions x) nil wrld))
progn$-of-check-dcl-guardianspfunction
(defun progn$-of-check-dcl-guardiansp (term) (case-match term (('check-dcl-guardian & ('quote &)) t) (('return-last ''progn ('check-dcl-guardian & ('quote &)) rest) (progn$-of-check-dcl-guardiansp rest)) (& nil)))
lambda-do-body-deconstructorfunction
(defun lambda-do-body-deconstructor (body) (case-match body (('return-last ''progn check-dcl-guardians-term true-body) (cond ((progn$-of-check-dcl-guardiansp check-dcl-guardians-term) (mv t check-dcl-guardians-term true-body)) (t (mv nil nil nil)))) (& (mv t nil body))))
well-formed-do-bodymutual-recursion
(mutual-recursion (defun well-formed-do-body (finallyp x settable-vars wrld) (cond ((flambda-applicationp x) (let ((body (lambda-body (ffn-symb x)))) (cond ((and (not (consp finallyp)) (null (ersatz-symbols t body))) (mv t nil)) (t (let ((bad-fns (ersatz-symbols-list :rename (fargs x)))) (cond (bad-fns (mv nil (msg "~&0 ~#0~[is~/are~] called in one or more bindings ~ of local variables in ~x1 (which might have ~ originally been written as a LET, LET* or lambda ~ application in a DO loop$)." bad-fns (untranslate-do-body x wrld)))) (t (mv-let (okp check-dcl-guardians-term true-body) (lambda-do-body-deconstructor body) (declare (ignore check-dcl-guardians-term)) (cond ((not okp) (mv nil (msg "~x0 (which might have originally been written as ~ a LET, LET*, or lambda application in a DO loop$) ~ could not be destructured as expected to identify ~ guards." (untranslate-do-body x wrld)))) (t (well-formed-do-body finallyp true-body settable-vars wrld))))))))))) ((and (consp finallyp) (or (variablep x) (fquotep x) (not (member-eq (ffn-symb x) '(ersatz-return if ersatz-prog2))))) (mv nil (let ((expr (untranslate-do-body x wrld))) (msg "the FINALLY clause in a DO loop$ must exit using solely ~ RETURN expressions when the :VALUES is other than (NIL). In ~ this case :VALUES is ~x0 yet the FINALLY clause may exit ~ with~@1 the expression, ~x2." finallyp (cond ((and (consp expr) (eq (car expr) 'list)) " (logically)") (t "")) expr)))) ((variablep x) (mv t nil)) ((fquotep x) (mv t nil)) (t (case (ffn-symb x) (if (let ((bad-fns (ersatz-symbols :rename (fargn x 1)))) (cond (bad-fns (mv nil (msg "the tests of IFs must be ACL2 terms, even in the body ~ of a DO loop$. Thus it is illegal to call ~&0 in the ~ test ~x1." bad-fns (untranslate-do-body (fargn x 1) wrld)))) (t (mv-let (okp msg) (well-formed-do-body finallyp (fargn x 2) settable-vars wrld) (if okp (well-formed-do-body finallyp (fargn x 3) settable-vars wrld) (mv nil msg))))))) (ersatz-setq (cond ((not (legal-variablep (fargn x 1))) (mv nil (msg "it is illegal to attempt an assignment (with ~x0 or ~x1) ~ to ~x2, as it is not a legal variable." 'setq 'mv-setq (fargn x 1)))) ((not (member-eq (fargn x 1) settable-vars)) (mv nil (msg "it is illegal to attempt an assignment (with ~x0) to ~ ~x1, which is not in the list ~x2 of settable variables ~ for the form ~x3." 'setq (fargn x 1) settable-vars (untranslate-do-body x wrld)))) (t (let ((bad-fns (ersatz-symbols :rename (fargn x 2)))) (cond (bad-fns (mv nil (msg "the second argument of every SETQ must be an ACL2 ~ term. Thus it is illegal to call ~&0 in ~x1." bad-fns (untranslate-do-body x wrld)))) (t (mv t nil))))))) (ersatz-mv-setq (let ((x-vars (ersatz-mv-setq-vars x))) (cond ((not (arglistp x-vars)) (mv-let (culprit explan) (find-first-bad-arg x-vars) (mv nil (msg "the first argument of an MV-SETQ expression must be ~ a list of distinct variables of length 2 or more, ~ but ~x0 is not such a list. The element ~x1 ~@2." x-vars culprit explan)))) ((not (subsetp-eq x-vars settable-vars)) (mv nil (msg "it is illegal to attempt an assignment (with ~x0) to ~ ~&1, which ~#1~[is~/are~] not in the list ~x2 of local ~ settable variables for ~x3." 'mv-setq (set-difference-eq x-vars settable-vars) settable-vars (untranslate-do-body x wrld)))) (t (let ((bad-fns (ersatz-symbols :rename (ersatz-mv-setq-body x)))) (cond (bad-fns (mv nil (msg "the second argument of every MV-SETQ must be an ~ ACL2 term. Thus it is illegal to call ~&0 in ~ ~x1." bad-fns (untranslate-do-body x wrld)))) (t (mv t nil)))))))) (ersatz-prog2 (mv-let (okp msg) (well-formed-do-body (and finallyp t) (fargn x 1) settable-vars wrld) (if okp (well-formed-do-body finallyp (fargn x 2) settable-vars wrld) (mv nil msg)))) (ersatz-loop-finish (cond (finallyp (mv nil (msg "it is illegal to use loop-finish in a finally clause of ~ a DO loop$."))) (t (mv t nil)))) (ersatz-return (let ((bad-fns (ersatz-symbols :rename (fargn x 1)))) (cond (bad-fns (mv nil (msg "the argument of a RETURN must be an ACL2 term. Thus ~ it is illegal to call ~&0 in ~x1." bad-fns (untranslate-do-body x wrld)))) (t (mv t nil))))) (otherwise (let ((bad-fns (ersatz-symbols-list :rename (fargs x)))) (cond (bad-fns (mv nil (msg "it is illegal to call ~&0 in the argument list of an ~ ACL2 function, as is done in ~x1." bad-fns (untranslate-do-body x wrld)))) (t (mv t nil))))))))) (defun well-formed-do-body-list (finallyp x settable-vars wrld) (cond ((endp x) (mv t nil)) (t (mv-let (okp msg) (well-formed-do-body finallyp (car x) settable-vars wrld) (if okp (well-formed-do-body-list finallyp (cdr x) settable-vars wrld) (mv nil msg)))))))
dumb-occurmutual-recursion
(mutual-recursion (defun dumb-occur (x y) (cond ((equal x y) t) ((variablep y) nil) ((fquotep y) nil) (t (dumb-occur-lst x (fargs y))))) (defun dumb-occur-lst (x lst) (cond ((null lst) nil) (t (or (dumb-occur x (car lst)) (dumb-occur-lst x (cdr lst)))))))
var-on-if-leaffunction
(defun var-on-if-leaf (var term) (cond ((eq var term) t) ((ffn-symb-p term 'if) (or (var-on-if-leaf var (fargn term 2)) (var-on-if-leaf var (fargn term 3)))) (t nil)))
guess-do-body-measure-varsfunction
(defun guess-do-body-measure-vars (x tested alist) (cond ((or (variablep x) (fquotep x)) nil) ((flambda-applicationp x) (let* ((fn (ffn-symb x)) (formals (lambda-formals fn)) (body (lambda-body fn))) (guess-do-body-measure-vars body tested (pairlis$ formals (fargs x))))) (t (case (ffn-symb x) (if (let* ((tested (union-eq tested (all-vars (sublis-var alist (fargn x 1))))) (ans1 (guess-do-body-measure-vars (fargn x 2) tested alist)) (ans2 (guess-do-body-measure-vars (fargn x 3) tested alist))) (cond ((eq ans1 t) ans2) ((eq ans2 t) ans1) (t (intersection-eq ans1 ans2))))) (ersatz-setq (let ((var (fargn x 1))) (if (and (member-eq var tested) (or (let ((pair (assoc-eq var alist))) (and pair (not (eq var (cdr pair))))) (not (var-on-if-leaf var (fargn x 2))))) (list var) nil))) (ersatz-mv-setq (intersection-eq (cdr (fargs x)) tested)) (ersatz-prog2 (let ((x1 (fargn x 1)) (x2 (fargn x 2))) (case-match x1 (('if tst tbr fbr) (guess-do-body-measure-vars `(if ,TST (ersatz-prog2 ,TBR ,X2) (ersatz-prog2 ,FBR ,X2)) tested alist)) (& (let ((ans1 (guess-do-body-measure-vars x1 tested alist)) (ans2 (guess-do-body-measure-vars x2 tested alist))) (cond ((or (eq ans1 t) (eq ans2 t)) t) (t (union-eq ans1 ans2)))))))) ((ersatz-return ersatz-loop-finish) t) (otherwise nil)))))
guess-do-body-measurefunction
(defun guess-do-body-measure (x) (let ((vars (guess-do-body-measure-vars x nil nil))) (cond ((eq vars nil) nil) ((eq vars t) *0*) (t `(acl2-count ,(CAR VARS))))))
cmp-do-body-alistfunction
(defun cmp-do-body-alist (vars) (cond ((endp vars) *nil*) (t (fcons-term* 'cons (fcons-term* 'cons (kwote (car vars)) (car vars)) (cmp-do-body-alist (cdr vars))))))
make-true-list-cons-nestfunction
(defun make-true-list-cons-nest (term-lst) (declare (xargs :guard (pseudo-term-listp term-lst))) (cond ((endp term-lst) *nil*) (t (cons-term 'cons (list (car term-lst) (make-true-list-cons-nest (cdr term-lst)))))))
cmp-do-body-exitfunction
(defun cmp-do-body-exit (exit-flg val aterm) (make-true-list-cons-nest (list (kwote exit-flg) val aterm)))
cmp-do-body-guardianfunction
(defun cmp-do-body-guardian (var val twvts) (let* ((temp (assoc-eq var twvts)) (type-spec (cadr temp)) (pred (caddr temp))) (and pred (not (equal pred *t*)) (fcons-term* 'check-dcl-guardian pred `'(setq ,VAR (the ,TYPE-SPEC ,VAL))))))
prog2$-callmacro
(defmacro prog2$-call (x y) `(fcons-term* 'return-last ''progn ,X ,Y))
cmp-do-body-mv-guardian-1function
(defun cmp-do-body-mv-guardian-1 (mv-var vars twvts index) (cond ((endp vars) nil) (t (let ((g (cmp-do-body-guardian (car vars) (fcons-term* 'mv-nth (kwote index) mv-var) twvts)) (gs (cmp-do-body-mv-guardian-1 mv-var (cdr vars) twvts (1+ index)))) (cond (g (cond (gs (prog2$-call g gs)) (t g))) (t gs))))))
cmp-do-body-mv-guardianfunction
(defun cmp-do-body-mv-guardian (mv-var vars twvts) (cmp-do-body-mv-guardian-1 mv-var vars twvts 0))
translated-mv-nth-callsfunction
(defun translated-mv-nth-calls (mv-var i max) (cond ((= i max) nil) (t (cons (fcons-term* 'mv-nth (kwote i) mv-var) (translated-mv-nth-calls mv-var (1+ i) max)))))
make-lambda-applicationfunction
(defun make-lambda-application (formals body actuals) (declare (xargs :guard (and (symbol-listp formals) (pseudo-termp body) (true-listp actuals) (eql (length formals) (length actuals))))) (let ((vars (all-vars body))) (cond ((null vars) body) ((equal formals actuals) body) (t (let ((extra-vars (set-difference-eq vars formals))) (fcons-term (make-lambda (append? (intersection-eq formals vars) extra-vars) body) (append? (collect-by-position vars formals actuals) extra-vars)))))))
make-lambda-termfunction
(defun make-lambda-term (formals actuals body) (declare (xargs :guard (and (symbol-listp formals) (pseudo-term-listp actuals) (pseudo-termp body)))) (let* ((body-vars (all-vars body)) (extra-body-vars (set-difference-eq body-vars formals))) (fcons-term (make-lambda (append formals extra-body-vars) body) (append actuals extra-body-vars))))
cmp-to-error-triplemacro
(defmacro cmp-to-error-triple (form &optional summary) (declare (xargs :guard (or (null summary) (stringp summary)))) `(mv-let (ctx msg-or-val) ,FORM (cond (ctx (cond (msg-or-val (assert$ (not (eq ctx t)) (er-soft ctx ',SUMMARY "~@0" msg-or-val))) (t (silent-error state)))) (t (value msg-or-val)))))
cmp-to-error-doublemacro
(defmacro cmp-to-error-double (form &optional summary) (declare (xargs :guard (or (null summary) (stringp summary)))) `(mv-let (ctx msg-or-val) ,FORM (cond (ctx (prog2$ (cond (msg-or-val (assert$ (not (eq ctx t)) (error-fms-cw nil ctx ,SUMMARY "~@0" (list (cons #\0 msg-or-val))))) (t nil)) (mv t nil))) (t (mv nil msg-or-val)))))
cmp-and-value-to-error-quadruplemacro
(defmacro cmp-and-value-to-error-quadruple (form &optional summary) (declare (xargs :guard (or (null summary) (stringp summary)))) `(mv-let (ctx msg-or-val extra-value) ,FORM (cond (ctx (cond (msg-or-val (assert$ (not (eq ctx t)) (mv-let (erp val state) (er-soft ctx ,SUMMARY "~@0" msg-or-val) (declare (ignore erp val)) (mv t nil extra-value state)))) (t (mv t nil extra-value state)))) (t (mv nil msg-or-val extra-value state)))))
er-progn-fn-cmpfunction
(defun er-progn-fn-cmp (lst) (declare (xargs :guard (true-listp lst))) (cond ((endp lst) nil) ((endp (cdr lst)) (car lst)) (t (list 'mv-let '(er-progn-not-to-be-used-elsewhere-ctx er-progn-not-to-be-used-elsewhere-msg) (car lst) '(declare (ignorable er-progn-not-to-be-used-elsewhere-msg)) (list 'if 'er-progn-not-to-be-used-elsewhere-ctx '(mv er-progn-not-to-be-used-elsewhere-ctx er-progn-not-to-be-used-elsewhere-msg) (list 'check-vars-not-free '(er-progn-not-to-be-used-elsewhere-ctx er-progn-not-to-be-used-elsewhere-msg) (er-progn-fn-cmp (cdr lst))))))))
er-progn-cmpmacro
(defmacro er-progn-cmp (&rest lst) (declare (xargs :guard (and (true-listp lst) lst))) (er-progn-fn-cmp lst))
er-let*-cmpmacro
(defmacro er-let*-cmp (alist body) (declare (xargs :guard (and (doublet-listp alist) (symbol-alistp alist)))) (cond ((null alist) (list 'check-vars-not-free '(er-let-star-use-nowhere-else) body)) (t (list 'mv-let (list 'er-let-star-use-nowhere-else (caar alist)) (cadar alist) (list 'cond (list 'er-let-star-use-nowhere-else (list 'mv 'er-let-star-use-nowhere-else (caar alist))) (list t (list 'er-let*-cmp (cdr alist) body)))))))
cmp-do-body-setqfunction
(defun cmp-do-body-setq (x twvts term) (let* ((var (fargn x 1)) (val (fargn x 2)) (guardian (cmp-do-body-guardian var val twvts)) (term+ (if guardian (prog2$-call guardian term) term))) (make-lambda-application (list var) term+ (list val))))
cmp-do-body-mv-setqfunction
(defun cmp-do-body-mv-setq (x vars twvts term) (let* ((mv-var (genvar 'cmp-do-body "MV" 0 vars)) (mvars (ersatz-mv-setq-vars x)) (mbody (ersatz-mv-setq-body x)) (guardian (cmp-do-body-mv-guardian mv-var mvars twvts)) (term+ (if guardian (prog2$-call guardian term) term))) (make-lambda-application (list mv-var) (make-lambda-term mvars (translated-mv-nth-calls mv-var 0 (length mvars)) term+) (list mbody))))
chk-no-ersatz-symbols-pfunction
(defun chk-no-ersatz-symbols-p (x ctx) (let ((bad (ersatz-symbols nil x))) (or (null bad) (er hard ctx "Implementation error: the term ~x0 unexpectedly contains ~ ``ersatz'' symbols: ~&1. Please contact the ACL2 implementors." x bad))))
collect-nontrivial-formals-in-setfunction
(defun collect-nontrivial-formals-in-set (formals actuals vars) (declare (xargs :guard (and (symbol-listp formals) (true-listp actuals) (= (length formals) (length actuals)) (symbol-listp vars)))) (cond ((endp formals) nil) ((or (eq (car formals) (car actuals)) (not (member-eq (car formals) vars))) (collect-nontrivial-formals-in-set (cdr formals) (cdr actuals) vars)) (t (cons (car formals) (collect-nontrivial-formals-in-set (cdr formals) (cdr actuals) vars)))))
cmp-do-body-1function
(defun cmp-do-body-1 (x twvts aterm vars wrld) (cond ((or (variablep x) (fquotep x)) (value-cmp (cmp-do-body-exit nil *nil* aterm))) ((flambda-applicationp x) (let ((body (lambda-body (ffn-symb x)))) (cond ((ersatz-symbols t body) (let* ((formals (lambda-formals (ffn-symb x))) (actuals (fargs x)) (bad (collect-nontrivial-formals-in-set formals actuals vars))) (cond (bad (er-cmp t "The variable~#0~[ ~&0 is~/s ~&0 are~] illegally ~ bound in the enclosing expression ~x1. This is ~ illegal because no bound variable may occur free in ~ its enclosing DO loop$ expression. See :DOC ~ do-loop$." bad (untranslate-do-body x wrld))) (t (er-let*-cmp ((val (cmp-do-body-1 (lambda-body (ffn-symb x)) twvts aterm vars wrld))) (value-cmp (make-lambda-application (lambda-formals (ffn-symb x)) val (fargs x)))))))) (t (value-cmp (prog2$-call x (cmp-do-body-exit nil *nil* aterm))))))) (t (case (ffn-symb x) (if (cond ((and (not (ersatz-symbols t (fargn x 2))) (not (ersatz-symbols t (fargn x 3)))) (value-cmp (prog2$-call x (cmp-do-body-exit nil *nil* aterm)))) (t (er-let*-cmp ((arg2 (cmp-do-body-1 (fargn x 2) twvts aterm vars wrld)) (arg3 (cmp-do-body-1 (fargn x 3) twvts aterm vars wrld))) (value-cmp (fcons-term* 'if (fargn x 1) arg2 arg3)))))) (return-last (prog2$ (chk-no-ersatz-symbols-p (fargn x 2) 'cmp-do-body-1) (cond ((not (ersatz-symbols t (fargn x 3))) (value-cmp (prog2$-call x (cmp-do-body-exit nil *nil* aterm)))) ((equal (fargn x 1) ''progn) (er-let*-cmp ((arg3 (cmp-do-body-1 (fargn x 3) twvts aterm vars wrld))) (value-cmp (prog2$-call (fargn x 2) arg3)))) (t (er-cmp t "Implementation error: unexpected term, ~x0. Please ~ contact the ACL2 implementors." x))))) (ersatz-loop-finish (value-cmp (cmp-do-body-exit :loop-finish *nil* aterm))) (ersatz-return (value-cmp (cmp-do-body-exit :return (fargn x 1) aterm))) (ersatz-setq (value-cmp (cmp-do-body-exit nil *nil* (cmp-do-body-setq x twvts aterm)))) (ersatz-mv-setq (value-cmp (cmp-do-body-exit nil *nil* (cmp-do-body-mv-setq x vars twvts aterm)))) (ersatz-prog2 (let ((x1 (fargn x 1)) (x2 (fargn x 2))) (cond ((or (variablep x1) (fquotep x1)) (cmp-do-body-1 x2 twvts aterm vars wrld)) ((flambda-applicationp x1) (let ((body (lambda-body (ffn-symb x1)))) (cond ((ersatz-symbols t body) (cmp-do-body-1 (make-lambda-term (lambda-formals (ffn-symb x1)) (fargs x1) (fcons-term* 'ersatz-prog2 body x2)) twvts aterm vars wrld)) (t (er-let*-cmp ((arg2 (cmp-do-body-1 x2 twvts aterm vars wrld))) (value-cmp (prog2$-call x1 arg2))))))) (t (case (ffn-symb x1) (if (cond ((and (not (ersatz-symbols t (fargn x1 2))) (not (ersatz-symbols t (fargn x1 3)))) (er-let*-cmp ((arg2 (cmp-do-body-1 x2 twvts aterm vars wrld))) (value-cmp (prog2$-call x1 arg2)))) (t (er-let*-cmp ((arg2 (cmp-do-body-1 (fcons-term* 'ersatz-prog2 (fargn x1 2) x2) twvts aterm vars wrld)) (arg3 (cmp-do-body-1 (fcons-term* 'ersatz-prog2 (fargn x1 3) x2) twvts aterm vars wrld))) (value-cmp (fcons-term* 'if (fargn x1 1) arg2 arg3)))))) (return-last (prog2$ (chk-no-ersatz-symbols-p (fargn x1 2) 'cmp-do-body-1) (cond ((not (ersatz-symbols t (fargn x1 3))) (er-let*-cmp ((arg2 (cmp-do-body-1 x2 twvts aterm vars wrld))) (value-cmp (prog2$-call x1 arg2)))) ((equal (fargn x1 1) ''progn) (er-let*-cmp ((arg2 (cmp-do-body-1 (fcons-term* 'ersatz-prog2 (fargn x1 3) x2) twvts aterm vars wrld))) (value-cmp (prog2$-call (fargn x1 2) arg2)))) (t (er-cmp 'cmp-do-body-1 "Implementation error: unexpected term, ~x0. ~ Please contact the ACL2 implementors." x))))) (ersatz-prog2 (cmp-do-body-1 (fcons-term* 'ersatz-prog2 (fargn x1 1) (fcons-term* 'ersatz-prog2 (fargn x1 2) x2)) twvts aterm vars wrld)) (ersatz-loop-finish (value-cmp (cmp-do-body-exit :loop-finish *nil* aterm))) (ersatz-return (value-cmp (cmp-do-body-exit :return (fargn x1 1) aterm))) (ersatz-setq (er-let*-cmp ((arg2 (cmp-do-body-1 x2 twvts aterm vars wrld))) (value-cmp (cmp-do-body-setq x1 twvts arg2)))) (ersatz-mv-setq (er-let*-cmp ((arg2 (cmp-do-body-1 x2 twvts aterm vars wrld))) (value-cmp (cmp-do-body-mv-setq x1 vars twvts arg2)))) (otherwise (er-let*-cmp ((arg2 (cmp-do-body-1 x2 twvts aterm vars wrld))) (value-cmp (prog2$-call x1 arg2))))))))) (otherwise (value-cmp (prog2$-call x (cmp-do-body-exit nil *nil* aterm))))))))
cmp-do-bodyfunction
(defun cmp-do-body (x twvts vars wrld) (mv-let (erp val) (cmp-do-body-1 x twvts (cmp-do-body-alist vars) vars wrld) (cond (erp (cons :fail val)) (t val))))
collect-twvts-type-predsfunction
(defun collect-twvts-type-preds (twvts) (cond ((endp twvts) nil) ((equal (caddr (car twvts)) *t*) (collect-twvts-type-preds (cdr twvts))) (t (cons (caddr (car twvts)) (collect-twvts-type-preds (cdr twvts))))))
var-to-cdr-assoc-var-substitutionfunction
(defun var-to-cdr-assoc-var-substitution (vars) (cond ((endp vars) nil) (t (let ((var (car vars))) (cons (cons var `(cdr (assoc-eq-safe ',VAR alist))) (var-to-cdr-assoc-var-substitution (cdr vars)))))))
make-do-body-lambda$function
(defun make-do-body-lambda$ (type-preds guard sigma all-stobj-names body-term) (let ((types-and-guard-lst (sublis-var-lst sigma (append type-preds (set-difference-equal (flatten-ands-in-lit guard) type-preds))))) `(lambda$ (alist) (declare (xargs :guard (do-body-guard-wrapper ,(IF (ENDP TYPES-AND-GUARD-LST) '(ALISTP ALIST) `(AND (ALISTP ALIST) ,@TYPES-AND-GUARD-LST)) ',ALL-STOBJ-NAMES))) (let ,(PAIRLIS$ (STRIP-CARS SIGMA) (PAIRLIS-X2 (STRIP-CDRS SIGMA) NIL)) (declare (ignorable ,@(STRIP-CARS SIGMA))) ,BODY-TERM))))
make-initial-do-body-alistfunction
(defun make-initial-do-body-alist (twvts vars alist) (cond ((endp twvts) (cond ((endp vars) *nil*) (t `(cons (cons ',(CAR VARS) ,(CAR VARS)) ,(MAKE-INITIAL-DO-BODY-ALIST NIL (CDR VARS) ALIST))))) (t (let ((rhs (sublis-var alist (cadddr (car twvts))))) `(cons (cons ',(CAR (CAR TWVTS)) ,RHS) ,(MAKE-INITIAL-DO-BODY-ALIST (CDR TWVTS) (IF (MEMBER-EQ (CAR (CAR TWVTS)) VARS) (REMOVE1-EQ (CAR (CAR TWVTS)) VARS) VARS) (CONS (CONS (CAR (CAR TWVTS)) RHS) ALIST)))))))
ev-w-lstfunction
(defun ev-w-lst (lst alist w user-stobj-alist safe-mode gc-off hard-error-returns-nilp aok) (declare (xargs :guard (and (plist-worldp w) (term-listp lst w) (symbol-alistp alist)))) (mv-let (erp val latches) (ev-rec-lst lst alist w user-stobj-alist (big-n) safe-mode gc-off nil hard-error-returns-nilp aok) (declare (ignore latches)) (mv erp val)))
silent-errorfunction
(defun silent-error (state) (mv t nil state))
warning1-cwfunction
(defun warning1-cw (ctx summary str alist wrld state-vars) (declare (xargs :guard (and (or (null summary) (let ((summary (if (consp summary) (car summary) summary))) (stringp summary))) (alistp alist) (plist-worldp wrld) (string-alistp (table-alist 'inhibit-warnings-table wrld)) (weak-state-vars-p state-vars)))) (warning1-form t))
warning$-cw1macro
(defmacro warning$-cw1 (ctx summary str+ &rest fmt-args) (list 'warning1-cw ctx (if (consp summary) (kwote summary) summary) str+ (make-fmt-bindings *base-10-chars* fmt-args) 'wrld 'state-vars))
warning$-cw0macro
(defmacro warning$-cw0 (ctx summary state-vars &rest args) `(let ((state-vars ,STATE-VARS) (wrld nil)) (warning$-cw1 ,CTX ,SUMMARY ,@ARGS)))
chk-length-and-keysfunction
(defun chk-length-and-keys (actuals form wrld) (declare (xargs :guard (and (true-listp actuals) (true-listp form) (symbolp (car form)) (plist-worldp wrld)) :measure (acl2-count actuals))) (cond ((endp actuals) (value-cmp nil)) ((null (cdr actuals)) (er-cmp *macro-expansion-ctx* "A non-even key/value arglist was encountered while macro ~ expanding ~x0. The argument list for ~x1 is ~%~F2." form (car form) (macro-args (car form) wrld))) ((keywordp (car actuals)) (chk-length-and-keys (cddr actuals) form wrld)) (t (er-cmp *macro-expansion-ctx* "A non-keyword was encountered while macro expanding ~x0 ~ where a keyword was expected. The formal parameters list ~ for ~x1 is ~%~F2." form (car form) (macro-args (car form) wrld)))))
other
(set-table-guard duplicate-keys-action-table (and (symbolp key) (member val '(:error :warning nil))) :topic set-duplicate-keys-action)
set-duplicate-keys-action!macro
(defmacro set-duplicate-keys-action! (key action) `(with-output :off (event summary) (progn (table duplicate-keys-action-table ',KEY ',ACTION) (value-triple ',ACTION))))
set-duplicate-keys-actionmacro
(defmacro set-duplicate-keys-action (key action) `(local (set-duplicate-keys-action! ,KEY ,ACTION)))
duplicate-keys-actionfunction
(defun duplicate-keys-action (key wrld) (declare (xargs :guard (and (plist-worldp wrld) (symbol-alistp (table-alist 'duplicate-keys-action-table wrld))))) (let ((pair (assoc-eq key (table-alist 'duplicate-keys-action-table wrld)))) (cond (pair (cdr pair)) (t :error))))
legal-initpfunction
(defun legal-initp (x) (and (consp x) (true-listp x) (equal 2 (length x)) (eq (car x) 'quote)))
macro-arglist-keyspfunction
(defun macro-arglist-keysp (args keys-passed) (declare (xargs :guard (and (true-listp args) (true-listp keys-passed)))) (cond ((endp args) t) ((eq (car args) '&allow-other-keys) (null (cdr args))) ((atom (car args)) (cond ((symbolp (car args)) (let ((new (intern (symbol-name (car args)) "KEYWORD"))) (and (not (member new keys-passed)) (macro-arglist-keysp (cdr args) (cons new keys-passed))))) (t nil))) ((or (not (true-listp (car args))) (> (length (car args)) 3)) nil) (t (and (or (symbolp (caar args)) (and (true-listp (caar args)) (equal (length (caar args)) 2) (keywordp (car (caar args))) (symbolp (cadr (caar args))))) (implies (> (length (car args)) 1) (legal-initp (cadr (car args)))) (implies (> (length (car args)) 2) (symbolp (caddr (car args)))) (let ((new (cond ((symbolp (caar args)) (intern (symbol-name (caar args)) "KEYWORD")) (t (car (caar args)))))) (and (not (member new keys-passed)) (macro-arglist-keysp (cdr args) (cons new keys-passed))))))))
macro-arglist-after-restpfunction
(defun macro-arglist-after-restp (args) (declare (xargs :guard (true-listp args))) (cond ((endp args) t) ((eq (car args) '&key) (macro-arglist-keysp (cdr args) nil)) (t nil)))
macro-arglist-optionalpfunction
(defun macro-arglist-optionalp (args) (declare (xargs :guard (true-listp args))) (cond ((endp args) t) ((member (car args) '(&rest &body)) (cond ((and (cdr args) (symbolp (cadr args)) (not (lambda-keywordp (cadr args)))) (macro-arglist-after-restp (cddr args))) (t nil))) ((eq (car args) '&key) (macro-arglist-keysp (cdr args) nil)) ((symbolp (car args)) (macro-arglist-optionalp (cdr args))) ((or (atom (car args)) (not (true-listp (car args))) (not (< (length (car args)) 4))) nil) ((not (symbolp (car (car args)))) nil) ((and (> (length (car args)) 1) (not (legal-initp (cadr (car args))))) nil) ((and (equal (length (car args)) 3) (not (symbolp (caddr (car args))))) nil) (t (macro-arglist-optionalp (cdr args)))))
macro-arglist1pfunction
(defun macro-arglist1p (args) (declare (xargs :guard (true-listp args))) (cond ((endp args) t) ((not (symbolp (car args))) nil) ((member (car args) '(&rest &body)) (cond ((and (cdr args) (symbolp (cadr args)) (not (lambda-keywordp (cadr args)))) (macro-arglist-after-restp (cddr args))) (t nil))) ((eq (car args) '&optional) (macro-arglist-optionalp (cdr args))) ((eq (car args) '&key) (macro-arglist-keysp (cdr args) nil)) (t (macro-arglist1p (cdr args)))))
subsequencepfunction
(defun subsequencep (lst1 lst2) (declare (xargs :guard (and (eqlable-listp lst1) (true-listp lst2)))) (cond ((endp lst1) t) (t (let ((tl (member (car lst1) lst2))) (cond ((endp tl) nil) (t (subsequencep (cdr lst1) (cdr tl))))))))
collect-lambda-keywordpsfunction
(defun collect-lambda-keywordps (lst) (declare (xargs :guard (true-listp lst))) (cond ((endp lst) nil) ((lambda-keywordp (car lst)) (cons (car lst) (collect-lambda-keywordps (cdr lst)))) (t (collect-lambda-keywordps (cdr lst)))))
macro-args-structurepfunction
(defun macro-args-structurep (args) (declare (xargs :guard t)) (and (true-listp args) (let ((lambda-keywords (collect-lambda-keywordps args))) (and (or (subsequencep lambda-keywords '(&whole &optional &rest &key &allow-other-keys)) (subsequencep lambda-keywords '(&whole &optional &body &key &allow-other-keys))) (and (not (member-eq '&whole (cdr args))) (implies (member-eq '&allow-other-keys args) (member-eq '&allow-other-keys (member-eq '&key args))) (implies (eq (car args) '&whole) (and (consp (cdr args)) (symbolp (cadr args)) (not (lambda-keywordp (cadr args))) (macro-arglist1p (cddr args)))) (macro-arglist1p args))))))
bind-macro-args-keys1function
(defun bind-macro-args-keys1 (args actuals allow-flg alist form wrld state-vars) (declare (xargs :guard (and (true-listp args) (macro-arglist-keysp args nil) (keyword-value-listp actuals) (symbol-alistp alist) (true-listp form) (symbolp (car form)) (plist-worldp wrld) (symbol-alistp (table-alist 'duplicate-keys-action-table wrld)) (string-alistp (table-alist 'inhibit-warnings-table wrld)) (weak-state-vars-p state-vars)))) (cond ((endp args) (cond ((or (null actuals) allow-flg) (value-cmp alist)) (t (er-cmp *macro-expansion-ctx* "Illegal key/value args ~x0 in macro expansion of ~ ~x1. The argument list for ~x2 is ~%~F3." actuals form (car form) (macro-args (car form) wrld))))) ((eq (car args) '&allow-other-keys) (value-cmp alist)) (t (let* ((formal (cond ((atom (car args)) (car args)) ((atom (caar args)) (caar args)) (t (cadr (caar args))))) (key (cond ((atom (car args)) (intern (symbol-name (car args)) "KEYWORD")) ((atom (car (car args))) (intern (symbol-name (caar args)) "KEYWORD")) (t (caaar args)))) (tl (assoc-keyword key actuals)) (alist (cond ((and (consp (car args)) (= 3 (length (car args)))) (cons (cons (caddr (car args)) (not (null tl))) alist)) (t alist))) (name (car form)) (duplicate-keys-action (and (assoc-keyword key (cddr tl)) (duplicate-keys-action name wrld))) (er-or-warn-string "The keyword argument ~x0 occurs twice in ~x1. This ~ situation is explicitly allowed in Common Lisp (see ~ CLTL2, page 80) but it often suggests a mistake was ~ made.~@2 See :DOC set-duplicate-keys-action.")) (prog2$ (and (eq duplicate-keys-action :warning) (warning$-cw1 *macro-expansion-ctx* "Duplicate-Keys" er-or-warn-string key form " The leftmost value for ~x0 is used.")) (cond ((eq duplicate-keys-action :error) (er-cmp *macro-expansion-ctx* er-or-warn-string key form "")) (t (bind-macro-args-keys1 (cdr args) (remove-keyword key actuals) allow-flg (cons (cons formal (cond (tl (cadr tl)) ((atom (car args)) nil) ((> (length (car args)) 1) (cadr (cadr (car args)))) (t nil))) alist) form wrld state-vars))))))))
bind-macro-args-keysfunction
(defun bind-macro-args-keys (args actuals alist form wrld state-vars) (declare (xargs :guard (and (true-listp args) (macro-arglist-keysp args nil) (true-listp actuals) (symbol-alistp alist) (true-listp form) (symbolp (car form)) (plist-worldp wrld) (symbol-alistp (table-alist 'duplicate-keys-action-table wrld)) (string-alistp (table-alist 'inhibit-warnings-table wrld)) (weak-state-vars-p state-vars)))) (er-progn-cmp (chk-length-and-keys actuals form wrld) (let ((tl (assoc-keyword :allow-other-keys actuals))) (er-progn-cmp (cond ((assoc-keyword :allow-other-keys (cddr tl)) (er-cmp *macro-expansion-ctx* "ACL2 prohibits multiple :allow-other-keys because ~ implementations differ significantly concerning which ~ value to take.")) (t (value-cmp nil))) (bind-macro-args-keys1 args actuals (and tl (cadr tl)) alist form wrld state-vars)))))
bind-macro-args-after-restfunction
(defun bind-macro-args-after-rest (args actuals alist form wrld state-vars) (declare (xargs :guard (and (true-listp args) (macro-arglist-after-restp args) (true-listp actuals) (symbol-alistp alist) (true-listp form) (symbolp (car form)) (plist-worldp wrld) (symbol-alistp (table-alist 'duplicate-keys-action-table wrld)) (string-alistp (table-alist 'inhibit-warnings-table wrld)) (weak-state-vars-p state-vars)))) (cond ((endp args) (value-cmp alist)) ((eq (car args) '&key) (bind-macro-args-keys (cdr args) actuals alist form wrld state-vars)) (t (er-cmp *macro-expansion-ctx* "Only keywords and values may follow &rest or &body; error in ~ macro expansion of ~x0." form))))
bind-macro-args-optionalfunction
(defun bind-macro-args-optional (args actuals alist form wrld state-vars) (declare (xargs :guard (and (true-listp args) (macro-arglist-optionalp args) (true-listp actuals) (symbol-alistp alist) (true-listp form) (symbolp (car form)) (plist-worldp wrld) (symbol-alistp (table-alist 'duplicate-keys-action-table wrld)) (string-alistp (table-alist 'inhibit-warnings-table wrld)) (weak-state-vars-p state-vars)))) (cond ((endp args) (cond ((null actuals) (value-cmp alist)) (t (er-cmp *macro-expansion-ctx* "Wrong number of args in macro expansion of ~x0." form)))) ((eq (car args) '&key) (bind-macro-args-keys (cdr args) actuals alist form wrld state-vars)) ((member (car args) '(&rest &body)) (bind-macro-args-after-rest (cddr args) actuals (cons (cons (cadr args) actuals) alist) form wrld state-vars)) ((symbolp (car args)) (bind-macro-args-optional (cdr args) (cdr actuals) (cons (cons (car args) (car actuals)) alist) form wrld state-vars)) (t (let ((alist (cond ((equal (length (car args)) 3) (cons (cons (caddr (car args)) (not (null actuals))) alist)) (t alist)))) (bind-macro-args-optional (cdr args) (cdr actuals) (cons (cons (car (car args)) (cond (actuals (car actuals)) ((>= (length (car args)) 2) (cadr (cadr (car args)))) (t nil))) alist) form wrld state-vars)))))
macro-args-er-cmpfunction
(defun macro-args-er-cmp (form) (declare (xargs :guard t)) (er-cmp *macro-expansion-ctx* "Wrong number of args in macro expansion of ~x0." form))
bind-macro-args1function
(defun bind-macro-args1 (args actuals alist form wrld state-vars) (declare (xargs :guard (and (true-listp args) (macro-arglist1p args) (true-listp actuals) (true-listp form) (symbolp (car form)) (symbol-alistp alist) (plist-worldp wrld) (symbol-alistp (table-alist 'duplicate-keys-action-table wrld)) (string-alistp (table-alist 'inhibit-warnings-table wrld)) (weak-state-vars-p state-vars)))) (cond ((endp args) (cond ((null actuals) (value-cmp alist)) (t (macro-args-er-cmp form)))) ((member-eq (car args) '(&rest &body)) (bind-macro-args-after-rest (cddr args) actuals (cons (cons (cadr args) actuals) alist) form wrld state-vars)) ((eq (car args) '&optional) (bind-macro-args-optional (cdr args) actuals alist form wrld state-vars)) ((eq (car args) '&key) (bind-macro-args-keys (cdr args) actuals alist form wrld state-vars)) ((null actuals) (macro-args-er-cmp form)) (t (bind-macro-args1 (cdr args) (cdr actuals) (cons (cons (car args) (car actuals)) alist) form wrld state-vars))))
bind-macro-argsfunction
(defun bind-macro-args (args form wrld state-vars) (declare (xargs :guard (and (macro-args-structurep args) (true-listp form) (symbolp (car form)) (plist-worldp wrld) (symbol-alistp (table-alist 'duplicate-keys-action-table wrld)) (string-alistp (table-alist 'inhibit-warnings-table wrld)) (weak-state-vars-p state-vars)))) (cond ((and (consp args) (eq (car args) '&whole)) (bind-macro-args1 (cddr args) (cdr form) (list (cons (cadr args) form)) form wrld state-vars)) (t (bind-macro-args1 args (cdr form) nil form wrld state-vars))))
macro-guard-er-msgfunction
(defun macro-guard-er-msg (x ctx wrld) (let* ((name (car x)) (args (cdr x)) (form (cdr (assoc-eq name (table-alist 'guard-msg-table wrld))))) (mv-let (erp msg) (cond (form (ev-w form (list (cons 'world wrld) (cons 'args args) (cons 'coda (msg "(Note: The custom guard message for ~ ~x0 references the variable ~x1, ~ which is essentially ignored for ~ macros. Consider modifying the ~ entry for ~x0 in ~x2.)" name 'coda 'guard-msg-table))) wrld nil nil t t t)) (t (mv nil nil))) (cond (erp (er-cmp ctx "~|~%Note: Evaluation has resulted in an error for the form ~ associated with ~x0 in the table, ~x1, to obtain a custom ~ guard error message. Consider modifying that table entry; ~ see :doc set-guard-msg." name 'guard-msg-table)) (msg (er-cmp ctx "~@0" msg)) (t (er-cmp ctx "In the attempt to macroexpand the form ~x0 the guard, ~x1, ~ for ~x2 failed." x (guard name nil wrld) name))))))
macroexpand1-cmpfunction
(defun macroexpand1-cmp (x ctx wrld state-vars) (case (car x) (and (value-cmp (and-macro (cdr x)))) (or (value-cmp (or-macro (cdr x)))) (with-output (value-cmp (with-output!-fn (cdr x)))) (value (if (and (consp (cdr x)) (null (cddr x))) (value-cmp `(mv nil ,(CADR X) state)) (macro-args-er-cmp x))) (f-get-global (if (and (consp (cdr x)) (consp (cddr x)) (null (cdddr x))) (value-cmp (list 'get-global (cadr x) (caddr x))) (macro-args-er-cmp x))) (cond (if (cond-clausesp (cdr x)) (value-cmp (cond-macro (cdr x))) (macro-guard-er-msg x ctx wrld))) (table (if (consp (cdr x)) (value-cmp (list 'table-fn (list 'quote (cadr x)) (list 'quote (cddr x)) 'state (list 'quote x))) (macro-args-er-cmp x))) (progn (value-cmp (list 'progn-fn (list 'quote (cdr x)) 'state))) (cadr (if (and (consp (cdr x)) (null (cddr x))) (value-cmp (list 'car (list 'cdr (cadr x)))) (macro-args-er-cmp x))) (cddr (if (and (consp (cdr x)) (null (cddr x))) (value-cmp (list 'cdr (list 'cdr (cadr x)))) (macro-args-er-cmp x))) (list (value-cmp (list-macro (cdr x)))) (otherwise (let ((gc-off (gc-off1 (access state-vars state-vars :guard-checking-on)))) (er-let*-cmp ((alist (bind-macro-args (macro-args (car x) wrld) x wrld state-vars))) (mv-let (erp guard-val) (let ((guard (guard (car x) nil wrld))) (cond ((equal guard *t*) (mv nil t)) (t (ev-w (guard (car x) nil wrld) alist wrld nil t gc-off nil nil)))) (cond (erp (er-cmp ctx "In the attempt to macroexpand the form ~x0 ~ evaluation of the guard for ~x2 caused the error ~ below.~|~%~@1" x guard-val (car x))) ((null guard-val) (macro-guard-er-msg x ctx wrld)) (t (mv-let (erp expansion) (ev-w (getpropc (car x) 'macro-body '(:error "Apparently macroexpand1 was called ~ where there was no macro-body.") wrld) alist wrld nil (not (access state-vars state-vars :boot-strap-flg)) gc-off nil nil) (cond (erp (er-cmp ctx "In the attempt to macroexpand the ~ form ~x0, evaluation of the macro ~ body caused the error below.~|~%~@1" x expansion)) (t (value-cmp expansion))))))))))))
macroexpand1function
(defun macroexpand1 (x ctx state) (cmp-to-error-triple (macroexpand1-cmp x ctx (w state) (default-state-vars t))))
chk-declarefunction
(defun chk-declare (form ctx) (let ((msg "An expression has occurred where we expect a form whose car is ~ DECLARE; yet, that expression is ~x0. This problem generally is ~ caused by (a) a parenthesis mistake, (b) the use of an ``implicit ~ PROGN'' so that a term that you intended to be part of the body was ~ taken as a declaration, or (c) the incorrect belief that ~ macroexpansion is applied to declarations. See :DOC declare.")) (cond ((or (not (consp form)) (not (symbolp (car form)))) (er-cmp ctx msg form)) ((eq (car form) 'declare) (cond ((not (true-listp form)) (er-cmp ctx "A declaration must be a true-list but ~x0 is not. ~ See :DOC declare." form)) (t (value-cmp form)))) (t (er-cmp ctx msg form)))))
collect-dclsfunction
(defun collect-dcls (l ctx) (cond ((null l) (value-cmp nil)) (t (er-let*-cmp ((expansion (chk-declare (car l) ctx)) (rst (collect-dcls (cdr l) ctx))) (value-cmp (append (cdr expansion) rst))))))
tag-loop$function
(defun tag-loop$ (loop$-stmt meaning) `(return-last 'progn ',LOOP$-STMT ,MEANING))
*acceptable-dcls-alist*constant
(defconst *acceptable-dcls-alist* `((let ignore ignorable type) (mv-let ignore ignorable type) (flet ignore ignorable type) (macrolet ignore ignorable type) (defmacro ignore ignorable type xargs) (defuns ignore ignorable irrelevant type optimize xargs) (lambda ignore ignorable type xargs) (lambda$ type xargs)))
*documentation-strings-permitted*constant
(defconst *documentation-strings-permitted* '(defmacro defuns))
*dcl-explanation-alist*constant
(defconst *dcl-explanation-alist* '((ignore "(IGNORE v1 ... vn), where the vi are introduced in the ~ immediately superior lexical environment") (ignorable "(IGNORABLE v1 ... vn), where the vi are introduced in the ~ immediately superior lexical environment") (ignore-and-ignorable "(IGNORE v1 ... vn) and (IGNORABLE v1 ... vn), ~ where the vi are introduced in the immediately ~ superior lexical environment") (irrelevant "(IRRELEVANT v1 ... vn)") (type "(TYPE type v1 ... vn), as described on pg 158 of CLTL") (xargs "(XARGS :key1 val1 ... :keyn valn), where each :keyi is a ~ keyword (e.g., :GUARD or :SPLIT-TYPES)")))
tilde-*-conjunction-phrase1function
(defun tilde-*-conjunction-phrase1 (syms alist) (cond ((null syms) nil) (t (let ((temp (assoc-eq (car syms) alist))) (cons (cond (temp (cdr temp)) (t (coerce (cons #\( (append (explode-atom (car syms) 10) (coerce " ...)" 'list))) 'string))) (tilde-*-conjunction-phrase1 (cdr syms) alist))))))
tilde-*-conjunction-phrasefunction
(defun tilde-*-conjunction-phrase (syms alist) (let ((syms (if (and (member-eq 'ignore syms) (member-eq 'ignorable syms)) (cons 'ignore-and-ignorable (remove1-eq 'ignore (remove1-eq 'ignorable syms))) syms))) (list "" "~@*" "~@* and " "~@*, " (tilde-*-conjunction-phrase1 syms alist))))
collect-non-legal-variablepsfunction
(defun collect-non-legal-variableps (lst) (cond ((null lst) nil) ((legal-variablep (car lst)) (collect-non-legal-variableps (cdr lst))) (t (cons (car lst) (collect-non-legal-variableps (cdr lst))))))
optimize-alistpfunction
(defun optimize-alistp (lst) (cond ((atom lst) (null lst)) ((consp (car lst)) (and (consp (cdar lst)) (null (cddar lst)) (symbolp (caar lst)) (integerp (cadar lst)) (<= 0 (cadar lst)) (<= (cadar lst) 3) (optimize-alistp (cdr lst)))) (t (and (symbolp (car lst)) (optimize-alistp (cdr lst))))))
chk-dcl-lstfunction
(defun chk-dcl-lst (l vars binder ctx wrld) (cond ((null l) (value-cmp nil)) (t (er-progn-cmp (let ((entry (car l))) (cond ((not (consp entry)) (er-cmp ctx "Each element of a declaration must be a cons, but ~x0 is ~ not. See :DOC declare." entry)) (t (let ((dcl (car entry)) (temp (cdr (assoc-eq binder *acceptable-dcls-alist*)))) (cond ((not (member-eq dcl temp)) (let ((matching-sym (and (symbolp dcl) (car (member-symbol-name (symbol-name dcl) temp))))) (er-cmp ctx "The only acceptable declaration~#0~[~/s~] at the ~ top-level of ~#1~[an FLET binding~/a MACROLET ~ binding~/a ~x2 form~] ~#0~[is~/are~] ~*3. The ~ declaration ~x4 is thus unacceptable here.~#5~[~/ ~ It is never necessary to make IGNORE or IGNORABLE ~ declarations in lambda$ expressions because ~ lambda$ automatically adds an IGNORABLE ~ declaration for all of the formals.~]~#6~[~/ ~ Note: You used the symbol ~x7 in your declaration ~ but you probably intended to use the symbol ~ ACL2::~s8.~] See :DOC declare." temp (cond ((eq binder 'flet) 0) ((eq binder 'macrolet) 1) (t 2)) binder (tilde-*-conjunction-phrase temp *dcl-explanation-alist*) entry (cond ((and (eq binder 'lambda$) (or (eq dcl 'ignore) (eq dcl 'ignorable))) 1) (t 0)) (if matching-sym 1 0) dcl (and matching-sym (symbol-name matching-sym))))) ((not (true-listp entry)) (er-cmp ctx "Each element of a declaration must end in NIL but ~ ~x0 does not. See :DOC declare." entry)) (t (case dcl (optimize (cond ((optimize-alistp (cdr entry)) (value-cmp nil)) (t (er-cmp ctx "Each element in the list following an ~ OPTIMIZE declaration must be either a ~ symbol or a pair of the form (quality ~ value), where quality is a symbol and ~ value is an integer between 0 and 3. ~ Your OPTIMIZE declaration, ~x0, does not ~ meet this requirement." entry)))) ((ignore ignorable irrelevant) (cond ((subsetp (cdr entry) vars) (value-cmp nil)) (t (er-cmp ctx "The variables of an ~x0 declaration must ~ be introduced in the ~#1~[immediately ~ superior lexical ~ environment~/surrounding DEFUN form~]; ~ but ~&2, which ~#2~[is~/are~] said to be ~ ~#3~[ignored~/ignorable~/irrelevant~] in ~ ~x4, ~#2~[is~/are~] not. See :DOC ~ declare." dcl (if (eq dcl 'irrelevant) 1 0) (set-difference-equal (cdr entry) vars) (if (eq dcl 'ignore) 0 (if (eq dcl 'ignorable) 1 2)) entry)))) (type (cond ((not (>= (length entry) 3)) (er-cmp ctx "The length of a type declaration must be at ~ least 3, but ~x0 does not satisfy this ~ condition. See :DOC declare." entry)) ((collect-non-legal-variableps (cddr entry)) (er-cmp ctx "Only the types of variables can be declared by ~ TYPE declarations such as ~x0. But ~&1 ~#1~[is ~ not a legal ACL2 variable symbol~/are not legal ~ ACL2 variable symbols~]. See :DOC declare." entry (collect-non-legal-variableps (cddr entry)))) ((not (subsetp (cddr entry) vars)) (er-cmp ctx "The variables declared in a type declaration, ~ such as ~x0, must be bound immediately above, ~ but ~&1 ~#1~[is~/are~] not bound. See :DOC ~ declare." entry (set-difference-equal (cddr entry) vars))) ((not (translate-declaration-to-guard (cadr entry) 'var wrld)) (cond ((and (true-listp (cadr entry)) (int= (length (cadr entry)) 3) (eq (car (cadr entry)) 'or) (eq (cadr (cadr entry)) t)) (er-cmp ctx "~x0 fails to be a legal type-spec. See :DOC ~ type-spec." (caddr (cadr entry)))) ((weak-satisfies-type-spec-p (cadr entry)) (er-cmp ctx "In the declaration ~x0, ~x1 fails to be a ~ legal type-spec because the symbol ~x2 is not ~ a known function symbol~@3. See :DOC ~ type-spec." entry (cadr entry) (cadr (cadr entry)) (if (eq (getpropc (cadr (cadr entry)) 'macro-args t wrld) t) "" "; rather, it is the name of a macro"))) (t (er-cmp ctx "In the declaration ~x0, ~x1 fails to be a ~ legal type-spec. See :DOC type-spec." entry (cadr entry))))) (t (value-cmp nil)))) (xargs (cond ((not (keyword-value-listp (cdr entry))) (er-cmp ctx "The proper form of the ACL2 declaration is ~ (XARGS :key1 val1 ... :keyn valn), where each ~ :keyi is a keyword and no key occurs twice. ~ Your ACL2 declaration, ~x0, is not of this ~ form. See :DOC xargs." entry)) ((not (no-duplicatesp-equal (evens (cdr entry)))) (er-cmp ctx "Even though Common Lisp permits duplicate ~ occurrences of keywords in keyword/actual ~ lists, all but the left-most occurrence are ~ ignored. You have duplicate occurrences of the ~ keyword~#0~[~/s~] ~&0 in your declaration ~x1. ~ This suggests a mistake has been made." (duplicates (evens (cdr entry))) entry)) ((and (eq binder 'defmacro) (or (assoc-keyword :stobjs (cdr entry)) (assoc-keyword :dfs (cdr entry)))) (er-cmp ctx "The use of the ~x0 keyword is prohibited ~ for an xargs declaration in a call of defmacro." (if (assoc-keyword :stobjs (cdr entry)) :stobjs :dfs))) (t (value-cmp nil)))) (otherwise (mv t (er hard! 'chk-dcl-lst "Implementation error: A declaration, ~x0, is ~ mentioned in *acceptable-dcls-alist* but not in ~ chk-dcl-lst." dcl)))))))))) (chk-dcl-lst (cdr l) vars binder ctx wrld)))))
collect-declarations-cmpfunction
(defun collect-declarations-cmp (lst vars binder ctx wrld) (cond ((> (number-of-strings lst) (if (member-eq binder *documentation-strings-permitted*) 1 0)) (cond ((member-eq binder *documentation-strings-permitted*) (er-cmp ctx "At most one documentation string is permitted at the ~ top-level of ~x0 but you have provided ~n1." binder (number-of-strings lst))) (t (er-cmp ctx "Documentation strings are not permitted in ~x0 forms." binder)))) (t (er-let*-cmp ((dcls (collect-dcls (remove-strings lst) ctx))) (er-progn-cmp (chk-dcl-lst dcls vars binder ctx wrld) (value-cmp (append (get-string lst) dcls)))))))
collect-declarationsfunction
(defun collect-declarations (lst vars binder state ctx) (cmp-to-error-triple (collect-declarations-cmp lst vars binder ctx (w state))))
listifyfunction
(defun listify (l) (cond ((null l) *nil*) (t (list 'cons (car l) (listify (cdr l))))))
translate-dcl-lstfunction
(defun translate-dcl-lst (edcls wrld) (cond ((null edcls) nil) ((eq (caar edcls) 'type) (append (translate-declaration-to-guard-var-lst (cadr (car edcls)) (cddr (car edcls)) wrld) (translate-dcl-lst (cdr edcls) wrld))) (t (translate-dcl-lst (cdr edcls) wrld))))
*oneify-primitives*constant
(defconst *oneify-primitives* '(if equal cons not consp atom acl2-numberp characterp integerp rationalp stringp symbolp fmt-to-comment-window fmt-to-comment-window! throw-raw-ev-fncall makunbound-global trans-eval ev ev-lst ev-fncall sys-call-status untranslate untranslate-lst trace$-fn-general untrace$-fn-general untrace$-fn1 maybe-untrace$-fn set-w acl2-unwind-protect mv-list))
*ec-call-bad-ops*constant
(defconst *ec-call-bad-ops* (assert$ (subsetp-equal '(if return-last) *stobjs-out-invalid*) (union-equal (cons 'wormhole-eval *stobjs-out-invalid*) *oneify-primitives*)))
return-last-callmacro
(defmacro return-last-call (fn &rest args) `(fcons-term* 'return-last ',FN ,@ARGS))
dcl-guardianfunction
(defun dcl-guardian (term-lst) (cond ((or (null term-lst) (let ((term (car term-lst))) (and (ffn-symb-p term 'if) (equal (fargn term 1) *t*) (equal (fargn term 2) *t*)))) *t*) ((null (cdr term-lst)) (fcons-term* 'check-dcl-guardian (car term-lst) (kwote (car term-lst)))) (t (prog2$-call (fcons-term* 'check-dcl-guardian (car term-lst) (kwote (car term-lst))) (dcl-guardian (cdr term-lst))))))
ignore-varsfunction
(defun ignore-vars (dcls) (cond ((null dcls) nil) ((eq (caar dcls) 'ignore) (append (cdar dcls) (ignore-vars (cdr dcls)))) (t (ignore-vars (cdr dcls)))))
ignorable-varsfunction
(defun ignorable-vars (dcls) (cond ((null dcls) nil) ((eq (caar dcls) 'ignorable) (append (cdar dcls) (ignorable-vars (cdr dcls)))) (t (ignorable-vars (cdr dcls)))))
mv-nth-listfunction
(defun mv-nth-list (var i maximum) (cond ((= i maximum) nil) (t (cons (fcons-term* 'mv-nth (list 'quote i) var) (mv-nth-list var (1+ i) maximum)))))
translate-bindmacro
(defmacro translate-bind (x val bindings) `(cons (cons ,X ,VAL) ,BINDINGS))
translate-dereffunction
(defun translate-deref (x bindings) (cond ((eq x t) t) ((consp x) x) (t (let ((p (assoc-eq x bindings))) (cond (p (cond ((eq x (cdr p)) x) (t (translate-deref (cdr p) bindings)))) (t nil))))))
translate-unboundfunction
(defun translate-unbound (x bindings) (and (not (eq x t)) (atom (translate-deref x bindings))))
listlisfunction
(defun listlis (l1 l2) (declare (xargs :guard (and (true-listp l1) (<= (length l1) (len l2))))) (cond ((endp l1) nil) (t (cons (list (car l1) (car l2)) (listlis (cdr l1) (cdr l2))))))
find-first-varmutual-recursion
(mutual-recursion (defun find-first-var (term) (cond ((variablep term) term) ((fquotep term) nil) ((find-first-var-lst (fargs term))) ((flambdap (ffn-symb term)) (car (lambda-formals (ffn-symb term)))) (t nil))) (defun find-first-var-lst (lst) (cond ((null lst) nil) (t (or (find-first-var (car lst)) (find-first-var-lst (cdr lst)))))))
find-first-fnsymbmutual-recursion
(mutual-recursion (defun find-first-fnsymb (term) (cond ((variablep term) nil) ((fquotep term) nil) ((flambdap (ffn-symb term)) (or (find-first-fnsymb-lst (fargs term)) (find-first-fnsymb (lambda-body (ffn-symb term))))) (t (ffn-symb term)))) (defun find-first-fnsymb-lst (lst) (cond ((null lst) nil) (t (or (find-first-fnsymb (car lst)) (find-first-fnsymb-lst (cdr lst)))))))
find-pkg-witnessfunction
(defun find-pkg-witness (term) (or (find-first-var term) (find-first-fnsymb term) 'find-pkg-witness))
trans-ermacro
(defmacro trans-er (&rest args) `(mv-let (ctx msg-or-val) (mv ,(CAR ARGS) (msg ,(CADR ARGS) ,@(CDDR ARGS))) (mv ctx msg-or-val bindings)))
trans-er+macro
(defmacro trans-er+ (form ctx str &rest args) `(mv-let (ctx msg-or-val) (mv ,CTX (msg "~@0 Note: this error occurred in the context ~x1." (msg ,STR ,@ARGS) ,FORM)) (mv ctx msg-or-val bindings)))
trans-er+?macro
(defmacro trans-er+? (cform x ctx str &rest args) (declare (xargs :guard (and (symbolp cform) (symbolp x)))) `(cond ((equal ,X ,CFORM) (trans-er ,CTX ,STR ,@ARGS)) (t (trans-er+ ,CFORM ,CTX ,STR ,@ARGS))))
trans-valuemacro
(defmacro trans-value (x &optional (bindings 'bindings)) `(mv nil ,X ,BINDINGS))
trans-er-let*macro
(defmacro trans-er-let* (alist body) (declare (xargs :guard (alistp alist))) (cond ((null alist) (list 'check-vars-not-free '(er-let-star-use-nowhere-else) body)) (t (list 'mv-let (list 'er-let-star-use-nowhere-else (caar alist) 'bindings) (cadar alist) (list 'cond (list 'er-let-star-use-nowhere-else (list 'mv 'er-let-star-use-nowhere-else (caar alist) 'bindings)) (list t (list 'trans-er-let* (cdr alist) body)))))))
hide-ignored-actualsfunction
(defun hide-ignored-actuals (ignore-vars bound-vars value-forms) (cond ((null ignore-vars) value-forms) ((null bound-vars) nil) ((and (member-eq (car bound-vars) ignore-vars) (let ((form (car value-forms))) (and (or (variablep form) (fquotep form) (not (eq (ffn-symb form) 'hide))) (cons (fcons-term* 'hide form) (hide-ignored-actuals ignore-vars (cdr bound-vars) (cdr value-forms))))))) (t (cons (car value-forms) (hide-ignored-actuals ignore-vars (cdr bound-vars) (cdr value-forms))))))
augment-ignore-varsfunction
(defun augment-ignore-vars (bound-vars value-forms acc) (cond ((endp bound-vars) acc) ((let ((form (car value-forms))) (or (variablep form) (fquotep form) (not (eq (ffn-symb form) 'hide)))) (augment-ignore-vars (cdr bound-vars) (cdr value-forms) acc)) (t (augment-ignore-vars (cdr bound-vars) (cdr value-forms) (cons (car bound-vars) acc)))))
compute-stobj-flagsfunction
(defun compute-stobj-flags (lst known-stobjs known-dfs w) (cond ((endp lst) nil) ((member-eq (car lst) known-dfs) (cons :df (compute-stobj-flags (cdr lst) known-stobjs known-dfs w))) ((stobjp (car lst) known-stobjs w) (cons (car lst) (compute-stobj-flags (cdr lst) known-stobjs known-dfs w))) (t (cons nil (compute-stobj-flags (cdr lst) known-stobjs known-dfs w)))))
prettyify-stobj-flagsfunction
(defun prettyify-stobj-flags (lst) (cond ((endp lst) nil) (t (cons (or (car lst) '*) (prettyify-stobj-flags (cdr lst))))))
prettyify-stobjs-outfunction
(defun prettyify-stobjs-out (stobjs-out) (if (cdr stobjs-out) (cons 'mv (prettyify-stobj-flags stobjs-out)) (car (prettyify-stobj-flags stobjs-out))))
defstobj-supporterpfunction
(defun defstobj-supporterp (name wrld) (cond ((getpropc name 'stobj nil wrld) name) ((getpropc name 'stobj-function nil wrld)) ((getpropc name 'stobj-constant nil wrld)) (t (getpropc name 'stobj-live-var nil wrld))))
stobj-creatorpfunction
(defun stobj-creatorp (name wrld) (and (symbolp name) (null (getpropc name 'formals t wrld)) (getpropc name 'stobj-function nil wrld)))
ffnnamepmutual-recursion
(mutual-recursion (defun ffnnamep (fn term) (declare (xargs :guard (pseudo-termp term))) (cond ((variablep term) nil) ((fquotep term) nil) ((flambda-applicationp term) (or (equal fn (ffn-symb term)) (ffnnamep fn (lambda-body (ffn-symb term))) (ffnnamep-lst fn (fargs term)))) ((eq (ffn-symb term) fn) t) (t (ffnnamep-lst fn (fargs term))))) (defun ffnnamep-lst (fn l) (declare (xargs :guard (pseudo-term-listp l))) (if (endp l) nil (or (ffnnamep fn (car l)) (ffnnamep-lst fn (cdr l))))))
unknown-binding-msgfunction
(defun unknown-binding-msg (stobjs-bound str1 str2 str3) (msg "The single-threaded object~#0~[ ~&0 has~/s ~&0 have~] been bound in ~@1. ~ It is a requirement that ~#0~[this object~/these objects~] be among the ~ outputs of ~@2. But, at the time at which we process ~@2, we are unable ~ to determine what the outputs are and so cannot allow it. This situation ~ arises when the output of ~@2 is a recursive call of the function being ~ admitted and the call is encountered before we have encountered the first ~ base case of the function (which would tell us what single-threaded ~ objects are being returned). In the case of the admission of a clique of ~ mutually-recursive functions, the situation can additionally arise when ~ the output of ~@2 is a call of a function in the clique and that function ~ appears in the clique after the definition in question. This situation ~ can be eliminated by rearranging the order of the branches of an IF ~ and/or rearranging the order of the presentation of a clique of mutually ~ recursive functions." stobjs-bound str1 str2 str3))
*macros-for-nonexpansion-in-raw-lisp*constant
(defconst *macros-for-nonexpansion-in-raw-lisp* '(mv list* or and list with-live-state swap-stobjs))
chk-no-duplicate-defuns-cmpfunction
(defun chk-no-duplicate-defuns-cmp (lst ctx) (declare (xargs :guard (true-listp lst))) (cond ((no-duplicatesp lst) (value-cmp nil)) (t (er-cmp ctx "We do not permit duplications among the list of symbols ~ being defined. However, the symbol~#0~[ ~&0 is~/s ~&0 ~ are each~] defined more than once." (duplicates lst)))))
chk-no-duplicate-defunsfunction
(defun chk-no-duplicate-defuns (lst ctx state) (cmp-to-error-triple (chk-no-duplicate-defuns-cmp lst ctx)))
chk-state-ok-msgfunction
(defun chk-state-ok-msg (wrld) (cond ((not (cdr (assoc-eq :state-ok (table-alist 'acl2-defaults-table wrld)))) (msg "The variable symbol STATE should not be used as a formal ~ parameter of a defined function unless you are aware of its ~ unusual status and the restrictions enforced on its use. See ~ :DOC set-state-ok.")) (t nil)))
chk-state-okfunction
(defun chk-state-ok (ctx wrld state) (let ((msg (chk-state-ok-msg wrld))) (cond (msg (er soft ctx "~@0" msg)) (t (value nil)))))
chk-arglist-msgfunction
(defun chk-arglist-msg (args chk-state wrld) (cond ((arglistp args) (if (and chk-state (member-eq 'state args)) (chk-state-ok-msg wrld) nil)) ((not (true-listp args)) (msg "The argument list to a function or macro must be a true list ~ but ~x0 is not." args)) (t (mv-let (culprit explan) (find-first-bad-arg args) (msg "The argument list to a function or macro must be a ~ true list of distinct, legal variable names. ~x0 is ~ not such a list. The element ~x1 violates the rules ~ because it ~@2." args culprit explan)))))
msg-to-cmpfunction
(defun msg-to-cmp (ctx msg) (assert$ ctx (cond (msg (mv ctx msg)) (t (mv nil nil)))))
chk-arglist-cmpfunction
(defun chk-arglist-cmp (args chk-state ctx wrld) (msg-to-cmp ctx (chk-arglist-msg args chk-state wrld)))
other
(defun@par chk-arglist (args chk-state ctx wrld state) (let ((msg (chk-arglist-msg args chk-state wrld))) (cond (msg (er@par soft ctx "~@0" msg)) (t (value@par nil)))))
logical-name-typefunction
(defun logical-name-type (name wrld quietp) (declare (xargs :guard (and (or (stringp name) (symbolp name)) (plist-worldp wrld)))) (cond ((stringp name) 'package) ((function-symbolp name wrld) 'function) ((getpropc name 'macro-body nil wrld) 'macro) ((getpropc name 'const nil wrld) 'const) ((getpropc name 'theorem nil wrld) 'theorem) ((not (eq (getpropc name 'theory t wrld) t)) 'theory) ((getpropc name 'label nil wrld) 'label) ((getpropc name 'stobj nil wrld) 'stobj) ((getpropc name 'stobj-live-var nil wrld) 'stobj-live-var) (quietp nil) (t (er hard? 'logical-name-type "Implementation error: ~x0 was called on the name ~x1, which ~ suggests that this name is expected to be a logical name; yet ~ its type cannot be determined." 'logical-name-type name))))
chk-all-but-new-name-cmpfunction
(defun chk-all-but-new-name-cmp (name ctx new-type w) (declare (xargs :guard (plist-worldp w))) (cond ((not (symbolp name)) (er-cmp ctx "Names must be symbols and ~x0 is not." name)) ((keywordp name) (er-cmp ctx "Keywords, such as ~x0, may not be defined or constrained." name)) ((and (member-eq new-type '(function const stobj macro constrained-function)) (equal *main-lisp-package-name* (symbol-package-name name)) (or (not (eq new-type 'function)) (not (eq (logical-name-type name w t) 'function))) (not (global-val 'boot-strap-flg w))) (er-cmp ctx "Symbols in the main Lisp package, such as ~x0, may not be ~ defined or constrained." name)) (t (value-cmp nil))))
chk-all-but-new-namefunction
(defun chk-all-but-new-name (name ctx new-type w state) (cmp-to-error-triple (chk-all-but-new-name-cmp name ctx new-type w)))
chk-defuns-tuples-cmpfunction
(defun chk-defuns-tuples-cmp (lst local-p ctx wrld) (cond ((atom lst) (cond ((eq lst nil) (value-cmp nil)) (t (er-cmp ctx "A list of definitions must be a true list.")))) ((not (true-listp (car lst))) (er-cmp ctx "Each~#0~[ local~/~] definition must be a true list and ~x1 ~ is not." (if local-p 0 1) (if local-p (car lst) (cons 'defun (car lst))))) ((not (>= (length (car lst)) 3)) (er-cmp ctx "A definition must be given three or more arguments, but ~x0 ~ has length only ~x1." (car lst) (length (car lst)))) (t (er-progn-cmp (chk-all-but-new-name-cmp (caar lst) ctx 'function wrld) (chk-arglist-cmp (cadar lst) nil ctx wrld) (er-let*-cmp ((edcls (collect-declarations-cmp (butlast (cddar lst) 1) (cadar lst) (if local-p 'flet 'defuns) ctx wrld)) (rst (chk-defuns-tuples-cmp (cdr lst) local-p ctx wrld))) (value-cmp (cons (list* (caar lst) (cadar lst) (if (stringp (car edcls)) (car edcls) nil) (if (stringp (car edcls)) (cdr edcls) edcls) (last (car lst))) rst)))))))
chk-defuns-tuplesfunction
(defun chk-defuns-tuples (lst local-p ctx wrld state) (cmp-to-error-triple (chk-defuns-tuples-cmp lst local-p ctx wrld)))
name-dropperfunction
(defun name-dropper (lst) (cond ((endp lst) *nil*) (t (let ((temp (if (eq (car lst) 'state) '(state-p state) (car lst)))) (cond ((endp (cdr lst)) temp) (t (prog2$-call temp (name-dropper (cdr lst)))))))))
first-assoc-eqfunction
(defun first-assoc-eq (keys alist) (declare (xargs :guard (and (alistp alist) (symbol-listp keys)))) (cond ((endp keys) nil) (t (or (assoc-eq (car keys) alist) (first-assoc-eq (cdr keys) alist)))))
context-for-encapsulate-pass-2function
(defun context-for-encapsulate-pass-2 (wrld in-local-flg) (let ((ee-entries (non-trivial-encapsulate-ee-entries (global-val 'embedded-event-lst wrld)))) (and ee-entries (cond ((or (cddr (car ee-entries)) (null in-local-flg)) 'illegal) (t 'maybe)))))
*protected-system-wormhole-names*constant
(defconst *protected-system-wormhole-names* '(brr accumulated-persistence fc-wormhole ev-fncall-guard-er-wormhole hons-copy-lambda-object-wormhole brr-data))
unknown-binding-msg-erfunction
(defun unknown-binding-msg-er (x ctx stobjs-bound str1 str2 str3) (mv-let (erp msg bindings) (let ((bindings nil)) (trans-er+ x ctx "~@0" (msg "The single-threaded object~#0~[ ~&0 has~/s ~&0 have~] been bound ~ in ~@1. It is a requirement that ~#0~[this object~/these ~ objects~] be among the outputs of ~@2. But, at the time at which ~ we process ~@2, we are unable to determine what the outputs are ~ and so cannot allow it. In the case of the admission of a clique ~ of mutually-recursive functions, this situation can arise when ~ the output of ~@2 is a call of a function defined in the clique ~ after the definition containing ~@2, in which case the problem ~ might be eliminated by rearranging the order of the definitions." stobjs-bound str1 str2 str3))) (declare (ignore bindings)) (mv erp msg :unknown-bindings)))
congruent-stobjspfunction
(defun congruent-stobjsp (st1 st2 wrld) (declare (xargs :guard (and (symbolp st1) (symbolp st2) wrld (plist-worldp wrld)))) (eq (congruent-stobj-rep st1 wrld) (congruent-stobj-rep st2 wrld)))
some-congruent-pfunction
(defun some-congruent-p (s lst wrld) (cond ((endp lst) nil) ((congruent-stobjsp s (car lst) wrld) t) (t (some-congruent-p s (cdr lst) wrld))))
stobjs-in-out1function
(defun stobjs-in-out1 (stobjs-in args stobjs-out wrld alist new-stobjs-in-rev) (cond ((endp stobjs-in) (mv nil alist (reverse new-stobjs-in-rev))) ((or (null (car stobjs-in)) (eq (car stobjs-in) :df)) (stobjs-in-out1 (cdr stobjs-in) (cdr args) stobjs-out wrld alist (cons (car stobjs-in) new-stobjs-in-rev))) (t (let ((s (if (or (eq (car stobjs-in) (car args)) (and (car args) (symbolp (car args)) (congruent-stobjsp (car stobjs-in) (car args) wrld))) (car args) (car stobjs-in)))) (cond ((and (member-eq s new-stobjs-in-rev) (or (symbolp stobjs-out) (some-congruent-p s stobjs-out wrld))) (mv s nil nil)) (t (stobjs-in-out1 (cdr stobjs-in) (cdr args) stobjs-out wrld (if (eq (car stobjs-in) s) alist (acons (car stobjs-in) s alist)) (cons s new-stobjs-in-rev))))))))
stobjs-in-matchpfunction
(defun stobjs-in-matchp (stobjs-in args) (cond ((endp stobjs-in) (null args)) ((endp args) nil) ((or (null (car stobjs-in)) (eq (car stobjs-in) :df) (eq (car stobjs-in) (car args))) (stobjs-in-matchp (cdr stobjs-in) (cdr args))) (t nil)))
stobjs-in-outfunction
(defun stobjs-in-out (fn args stobjs-out known-stobjs wrld) (let ((stobjs-in (cond ((consp fn) (compute-stobj-flags (lambda-formals fn) known-stobjs nil wrld)) (t (stobjs-in fn wrld))))) (cond ((stobjs-in-matchp stobjs-in args) (mv nil stobjs-in stobjs-out)) (t (mv-let (failp alist new-stobjs-in) (stobjs-in-out1 stobjs-in args stobjs-out wrld nil nil) (cond (failp (mv nil stobjs-in stobjs-out)) (t (mv alist new-stobjs-in (cond ((symbolp stobjs-out) stobjs-out) ((null alist) stobjs-out) (t (apply-symbol-alist alist stobjs-out nil)))))))))))
non-trivial-stobj-bindingfunction
(defun non-trivial-stobj-binding (stobj-flags bindings) (declare (xargs :guard (and (symbol-listp stobj-flags) (not (member-eq :df stobj-flags)) (symbol-doublet-listp bindings) (eql (length stobj-flags) (length bindings))))) (cond ((endp stobj-flags) nil) ((or (null (car stobj-flags)) (assert$ (eq (car stobj-flags) (caar bindings)) (eq (car stobj-flags) (cadar bindings)))) (non-trivial-stobj-binding (cdr stobj-flags) (cdr bindings))) (t (car stobj-flags))))
formalized-varlistpfunction
(defun formalized-varlistp (varlist formal-lst) (declare (xargs :guard (and (symbol-listp varlist) (pseudo-termp formal-lst)))) (cond ((endp varlist) (equal formal-lst *nil*)) ((variablep formal-lst) nil) (t (and (eq (ffn-symb formal-lst) 'cons) (eq (car varlist) (fargn formal-lst 1)) (formalized-varlistp (cdr varlist) (fargn formal-lst 2))))))
throw-nonexec-error-p1function
(defun throw-nonexec-error-p1 (targ1 targ2 name formals) (declare (xargs :guard (and (pseudo-termp targ1) (pseudo-termp targ2) (symbolp name) (symbol-listp formals)))) (and (quotep targ1) (eq (unquote targ1) 'progn) (ffn-symb-p targ2 'throw-nonexec-error) (or (null name) (let ((qname (fargn targ2 1))) (and (quotep qname) (if (eq name :non-exec) (eq (unquote qname) :non-exec) (and (eq (unquote qname) name) (formalized-varlistp formals (fargn targ2 2)))))))))
throw-nonexec-error-pfunction
(defun throw-nonexec-error-p (body name formals) (declare (xargs :guard (and (pseudo-termp body) (symbolp name) (symbol-listp formals)))) (and (ffn-symb-p body 'return-last) (throw-nonexec-error-p1 (fargn body 1) (fargn body 2) name formals)))
chk-local-def-declarationsfunction
(defun chk-local-def-declarations (fletp names decls declare-form ctx) (cond ((null decls) (value-cmp nil)) ((atom decls) (er-cmp ctx "The DECLARE form for ~@0 expression must be a ~ true-list. The form ~x1 is thus illegal. See :DOC ~@2." (if fletp "an FLET" "a MACROLET") declare-form (if fletp "flet" "macrolet"))) (t (let ((decl (car decls))) (cond ((and (consp decl) (member-eq (car decl) '(inline notinline)) (true-listp (cdr decl)) (subsetp-eq (cdr decl) names)) (chk-local-def-declarations fletp names (cdr decls) declare-form ctx)) (t (er-cmp ctx "Each declaration in a DECLARE form of ~@0 ~ expression must be of the form (INLINE . fns) ~ or (NOTINLINE . fns), where fns is a true-list ~ of names that are all defined by the ~x1 ~ expression. The declare form ~x2 is thus ~ illegal because of its declaration, ~x3. See ~ :DOC ~@4." (if fletp "an FLET" "a MACROLET") (if fletp "FLET" "MACROLET") declare-form decl (if fletp "flet" "macrolet"))))))))
chk-local-def-declare-formfunction
(defun chk-local-def-declare-form (fletp names declare-form ctx) (cond ((null declare-form) (value-cmp nil)) (t (case-match declare-form (('declare . decls) (chk-local-def-declarations fletp names decls declare-form ctx)) (& (er-cmp ctx "The optional DECLARE forms for ~@0 expression must each ~ be of the form (DECLARE DCL1 DCL2 ... DCLk), where each ~ DCLi is an INLINE or NOTINLINE declaration. The form ~x1 ~ is thus not a legal DECLARE form. See :DOC ~@2." (if fletp "an FLET" "a MACROLET") declare-form (if fletp "flet" "macrolet")))))))
chk-local-def-declare-form-listfunction
(defun chk-local-def-declare-form-list (fletp names declare-form-list ctx) (cond ((endp declare-form-list) (value-cmp nil)) (t (er-progn-cmp (chk-local-def-declare-form fletp names (car declare-form-list) ctx) (chk-local-def-declare-form-list fletp names (cdr declare-form-list) ctx)))))
stobj-updater-guess-from-accessorfunction
(defun stobj-updater-guess-from-accessor (accessor) (declare (xargs :guard (symbolp accessor))) (or (let* ((name (symbol-name accessor)) (len (length name))) (and (< 4 len) (equal (subseq name (- len 4) len) "-GET") (intern-in-package-of-symbol (concatenate 'string (subseq name 0 (- len 3)) "PUT") accessor))) (packn-pos (list "UPDATE-" accessor) accessor)))
parse-stobj-let-actualfunction
(defun parse-stobj-let-actual (actual) (case-match actual ((st-get ('quote s2) parent (s2-creator)) (mv st-get parent s2 s2-creator)) (& (mv nil nil nil nil))))
unquoted-symbolfunction
(defun unquoted-symbol (x) (case-match x (('quote y) (and (symbolp y) y)) (& nil)))
parse-stobj-let1function
(defun parse-stobj-let1 (bindings producer-vars bound-vars actuals creators stobj updaters) (declare (xargs :guard (and (true-listp bindings) (true-listp producer-vars) (true-listp bound-vars) (true-listp actuals) (true-listp creators) (true-listp updaters)))) (cond ((endp bindings) (mv nil (reverse bound-vars) (reverse actuals) (reverse creators) stobj (reverse updaters))) (t (let ((binding (car bindings))) (case-match binding ((s act . rest) (cond ((not (and (symbolp s) (or (null rest) (and (consp rest) (null (cdr rest)) (symbolp (car rest)))))) (mv binding (msg "That binding is not of the form (var expression) or (var ~ expression updater).") nil nil nil nil)) (t (mv-let (st-get stobj0 s2 s2-creator) (parse-stobj-let-actual act) (cond (s2-creator (cond ((not (and (symbolp s2-creator) s2-creator (symbolp st-get) st-get (symbolp s2) s2 (symbolp stobj0) stobj0)) (let ((msg (mv-let (str sym) (cond ((not (and (symbolp s2-creator) s2-creator)) (mv "ST-CREATOR" s2-creator)) ((not (and (symbolp st-get) st-get)) (mv "STOBJ-TBL-GET" st-get)) ((not (and (symbolp s2) s2)) (mv "ST" s2)) (t (mv "TOP-ST" stobj0))) (msg "For a binding of the form~|(STOBJ-TBL-GET ST ~ TOP-ST ST-CREATOR)), ~a0 must be a non-nil ~ symbol, but ~x1 is not." str sym)))) (mv binding msg nil nil nil nil))) ((and stobj (not (eq stobj0 stobj))) (mv binding (msg "The stobj accessed in a stobj-let binding must be ~ the same as the stobj accessed in preceding ~ bindings of that stobj-let, but ~x0 does not agree ~ with the earlier ~x1." stobj0 stobj) nil nil nil nil)) (t (parse-stobj-let1 (cdr bindings) producer-vars (cons s bound-vars) (cons act actuals) (cons s2-creator creators) stobj0 (if (member-eq s producer-vars) (cons (list (or (car rest) (stobj-updater-guess-from-accessor st-get)) (kwote s) s (caddr act)) updaters) updaters))))) (t (cond ((not (and (true-listp act) (member (length act) '(2 3)) (symbolp (car act)) (symbolp (car (last act))))) (mv binding (msg "The stobj-let binding of ~x0 is to ~x1, which is ~ not an expression of length 2 or 3 that starts and ~ ends with a symbol, and is also not a valid ~ stobj-table access." s act) nil nil nil nil)) (t (let ((indexp (eql (length act) 3))) (cond ((and indexp (let ((index (cadr act))) (not (or (and (symbolp index) (not (member-eq index producer-vars))) (natp index) (and (consp index) (consp (cdr index)) (null (cddr index)) (eq (car index) 'quote)))))) (mv binding (msg "The index expression, ~x0, used for array or ~ hash-table access in the stobj-let binding ~ of variable ~x1, is illegal because ~@2." (cadr act) s (cond ((member-eq (cadr act) producer-vars) (msg "~x0 is also a producer variable" (cadr act))) (t "that index expression is not a ~ symbol, a natural number, or a ~ quoted constant"))) nil nil nil nil)) (t (let ((accessor (car act)) (stobj0 (car (last act))) (update-fn (car rest))) (cond ((or (null stobj0) (eq stobj0 'state) (and stobj (not (eq stobj0 stobj)))) (mv binding (msg "In the stobj-let binding of variable ~ ~x0, the expression ~x1 ends with ~x2, ~ which ~@3." s act stobj0 (cond ((null stobj0) (msg "is ~x0" nil)) ((eq stobj0 'state) (msg "is ~x0" 'state)) (t (msg "fails to agree with the stobj ~ name indicated in the first ~ expression, ~x0" stobj)))) nil nil nil nil)) ((member-eq s producer-vars) (parse-stobj-let1 (cdr bindings) producer-vars (cons s bound-vars) (cons act actuals) (cons nil creators) stobj0 (cons (cons (or update-fn (stobj-updater-guess-from-accessor accessor)) (if indexp (list* (cadr act) s (cddr act)) (cons s (cdr act)))) updaters))) (t (parse-stobj-let1 (cdr bindings) producer-vars (cons s bound-vars) (cons act actuals) (cons nil creators) stobj0 updaters))))))))))))))) (& (mv binding (msg "The stobj-let binding ~x0 fails to be a null-terminated ~ list of length at least 2." binding) nil nil nil nil)))))))
illegal-stobj-let-msgfunction
(defun illegal-stobj-let-msg (msg form) (msg "~@0 The form ~x1 is thus illegal. See :DOC stobj-let." msg form))
parse-stobj-letfunction
(defun parse-stobj-let (x) (declare (xargs :guard t)) (case-match x (('stobj-let bindings producer-vars producer consumer) (cond ((not (and bindings (true-listp bindings))) (mv (illegal-stobj-let-msg "The bindings of a STOBJ-LET form must be a non-empty true-list." x) nil nil nil nil nil nil nil nil nil)) ((not (and producer-vars (arglistp producer-vars))) (mv (illegal-stobj-let-msg "The producer-variables of a STOBJ-LET form must be a non-empty ~ list of legal variable names without duplicates." x) nil nil nil nil nil nil nil nil nil)) (t (mv-let (bad-binding bound-vars-or-msg actuals creators stobj updaters) (parse-stobj-let1 bindings producer-vars nil nil nil nil nil) (cond (bad-binding (mv (illegal-stobj-let-msg bound-vars-or-msg x) nil nil nil nil nil nil nil nil nil)) (t (mv nil bound-vars-or-msg actuals creators stobj producer-vars producer updaters bindings consumer))))))) (& (mv (illegal-stobj-let-msg "The proper form of a stobj-let is (STOBJ-LET <bindings> ~ <producer-variables> <producer> <consumer>)." x) nil nil nil nil nil nil nil nil nil))))
split-values-by-keysfunction
(defun split-values-by-keys (keys alist lst1 lst2) (declare (xargs :guard (and (true-listp keys) (symbol-alistp alist)))) (cond ((endp alist) (mv lst1 lst2)) ((member-eq (caar alist) keys) (split-values-by-keys keys (cdr alist) (cons (cdar alist) lst1) lst2)) (t (split-values-by-keys keys (cdr alist) lst1 (cons (cdar alist) lst2)))))
no-duplicate-indices-checks-for-stobj-let-actuals/alistfunction
(defun no-duplicate-indices-checks-for-stobj-let-actuals/alist (alist producer-vars) (cond ((endp alist) nil) (t (let ((pairs (cdar alist))) (cond ((or (null (cdr pairs)) (let ((indices (strip-cdrs pairs))) (and (nat-listp indices) (no-duplicatesp indices)))) (no-duplicate-indices-checks-for-stobj-let-actuals/alist (cdr alist) producer-vars)) (t (mv-let (producer-indices other-indices) (split-values-by-keys producer-vars pairs nil nil) (cond ((null producer-indices) (no-duplicate-indices-checks-for-stobj-let-actuals/alist (cdr alist) producer-vars)) (t (cons `(with-guard-checking t (chk-no-stobj-index-aliasing (list ,@PRODUCER-INDICES) (list ,@OTHER-INDICES))) (no-duplicate-indices-checks-for-stobj-let-actuals/alist (cdr alist) producer-vars)))))))))))
concrete-accessorfunction
(defun concrete-accessor (accessor tuples-lst) (cond ((endp tuples-lst) accessor) (t (let* ((tuples (car tuples-lst)) (accessor$c (caddr (assoc-eq accessor tuples)))) (assert$ accessor$c (concrete-accessor accessor$c (cdr tuples-lst)))))))
no-duplicate-indices-checks-for-stobj-let-actuals-1function
(defun no-duplicate-indices-checks-for-stobj-let-actuals-1 (bound-vars exprs creators producer-vars tuples-lst alist) (cond ((endp exprs) (let ((lst (no-duplicate-indices-checks-for-stobj-let-actuals/alist alist producer-vars))) (if (cdr lst) (cons 'progn$ lst) (car lst)))) (t (no-duplicate-indices-checks-for-stobj-let-actuals-1 (cdr bound-vars) (cdr exprs) (cdr creators) producer-vars tuples-lst (cond ((car creators) alist) (t (let ((bound-var (car bound-vars)) (expr (car exprs))) (cond ((eql (length expr) 3) (let* ((name (car expr)) (index (cadr expr)) (index (if (consp index) (assert$ (and (eq (car index) 'quote) (natp (cadr index))) (cadr index)) index)) (fld$c (concrete-accessor name tuples-lst)) (entry (assoc-eq fld$c alist))) (put-assoc-eq fld$c (cons (cons bound-var index) (cdr entry)) alist))) (t alist)))))))))
absstobj-tuples-lstfunction
(defun absstobj-tuples-lst (st wrld) (let ((abs-info (getpropc st 'absstobj-info nil wrld))) (cond ((null abs-info) nil) (t (cons (access absstobj-info abs-info :absstobj-tuples) (absstobj-tuples-lst (access absstobj-info abs-info :st$c) wrld))))))
no-duplicate-indices-checks-for-stobj-let-actualsfunction
(defun no-duplicate-indices-checks-for-stobj-let-actuals (bound-vars exprs creators producer-vars st wrld) (let ((tuples-lst (absstobj-tuples-lst st wrld))) (no-duplicate-indices-checks-for-stobj-let-actuals-1 bound-vars exprs creators producer-vars tuples-lst nil)))
stobj-let-fnfunction
(defun stobj-let-fn (x) (mv-let (msg bound-vars actuals creators stobj producer-vars producer updaters bindings consumer) (parse-stobj-let x) (declare (ignore bindings creators)) (cond (msg (er hard 'stobj-let "~@0" msg)) (t (let* ((guarded-producer (if (intersectp-eq bound-vars producer-vars) `(check-vars-not-free (,STOBJ) ,PRODUCER) producer)) (guarded-consumer `(check-vars-not-free ,BOUND-VARS ,CONSUMER)) (updated-guarded-consumer `(let* ,(PAIRLIS-X1 STOBJ (PAIRLIS$ UPDATERS NIL)) ,GUARDED-CONSUMER))) `(let (,@(PAIRLIS$ BOUND-VARS (PAIRLIS$ ACTUALS NIL))) (declare (ignorable ,@BOUND-VARS)) ,(COND ((CDR PRODUCER-VARS) `(MV-LET ,PRODUCER-VARS ,GUARDED-PRODUCER ,UPDATED-GUARDED-CONSUMER)) (T `(LET ((,(CAR PRODUCER-VARS) ,GUARDED-PRODUCER)) ,UPDATED-GUARDED-CONSUMER)))))))))
stobj-let-fn-raw-let-bindingsfunction
(defun stobj-let-fn-raw-let-bindings (vars actuals creators) (cond ((endp vars) nil) (t (let ((act (car actuals)) (cre (car creators))) (cons (list (car vars) (cond (cre (case-match act ((st-get ('quote st) parent (!cre)) `(or (,ST-GET ',ST ,PARENT nil) (,CRE))) (& (er hard 'stobj-let-fn-raw-bindings "Implementation error: unexpected stobj-let ~ actual, ~x0. Please contact the ACL2 ~ implementors." act)))) (t act))) (stobj-let-fn-raw-let-bindings (cdr vars) (cdr actuals) (cdr creators)))))))
stobj-field-accessor-pfunction
(defun stobj-field-accessor-p (fn stobj wrld) (and (eq (getpropc fn 'stobj-function nil wrld) stobj) (member-eq fn (access stobj-property (getpropc stobj 'stobj nil wrld) :names)) (let ((abs-info (getpropc stobj 'absstobj-info nil wrld))) (cond (abs-info (cdddr (assoc-eq fn (access absstobj-info abs-info :absstobj-tuples)))) (t (and (function-symbolp fn wrld) (not (eq (car (stobjs-out fn wrld)) stobj))))))))
*stobj-table-stobj*constant
(defconst *stobj-table-stobj* :stobj-table-stobj)
chk-stobj-let/bindingsfunction
(defun chk-stobj-let/bindings (stobj acc-stobj first-acc bound-vars actuals wrld) (cond ((endp bound-vars) nil) (t (let ((actual (car actuals)) (var (car bound-vars))) (mv-let (st-get parent s2 s2-creator) (parse-stobj-let-actual actual) (mv-let (msg parent accessor stobj-out) (cond (s2-creator (let ((stobjs-out (stobjs-out st-get wrld)) (prelude "The variable ~x0 is bound in a stobj-let form to ~ the expression ~x1, which has the form of a ~ stobj-table access.~|") (postlude " See :DOC stobj-table.")) (cond ((not (eq (car stobjs-out) *stobj-table-stobj*)) (mv (msg "~@0However, the function symbol of that access, ~ ~x1, is not a stobj-table accessor.~@2" (msg prelude var actual) st-get postlude) nil nil nil)) ((not (stobjp s2 t wrld)) (mv (msg "~@0However, that alleged stobj-table access is ~ illegal because ~x1 is not the name of a stobj.~@2" (msg prelude var actual) s2 postlude) nil nil nil)) ((not (eq (access stobj-property (getpropc s2 'stobj nil wrld) :creator) s2-creator)) (mv (msg "~@0However, the stobj creator for ~x1 is ~x2, not ~ ~x3.~@4" (msg prelude var actual) s2 (access stobj-property (getpropc s2 'stobj nil wrld) :creator) s2-creator postlude) nil nil nil)) (t (mv nil parent st-get s2))))) (t (let ((stobj-out (car (stobjs-out (car actual) wrld)))) (cond ((eq stobj-out *stobj-table-stobj*) (mv (msg "The stobj-let binding of variable ~x0 to ~ expression ~x1 is illegal. Apparently a ~ stobj-table access was intended. In that case ~ the stobj creator for ~x0 should be called as ~ a third argument of that expression; see :DOC ~ stobj-table." var actual) nil nil nil)) (t (mv nil (car (last actual)) (car actual) stobj-out)))))) (cond (msg) (t (assert$ (eq parent stobj) (cond ((not (stobj-field-accessor-p accessor acc-stobj wrld)) (msg "The name ~x0 is not the name of a field accessor for the ~ stobj ~x1.~@2~@3" accessor acc-stobj (if (eq acc-stobj stobj) "" (msg " (The first accessor used in a stobj-let, in ~ this case ~x0, determines the stobj with which ~ all other accessors must be associated, namely ~ ~x1.)" first-acc acc-stobj)) (let* ((abs-info (getpropc parent 'absstobj-info nil wrld)) (tuples (and abs-info (access absstobj-info abs-info :absstobj-tuples)))) (cond ((assoc-eq accessor tuples) (msg " Note that even though ~x0 is an abstract ~ stobj primitive (for ~x1), it is not an ~ accessor because it is not associated with an ~ :UPDATER." accessor parent)) (t ""))))) ((not (stobjp var t wrld)) (msg "The stobj-let bound variable ~x0 is not the name of a ~ known single-threaded object in the current ACL2 world." var)) ((not (eq (congruent-stobj-rep var wrld) (congruent-stobj-rep stobj-out wrld))) (msg "The stobj-let bound variable ~x0 is not the same as, or ~ even congruent to, the output ~x1 from applying accessor ~ ~x2 to stobj ~x3)." var stobj-out accessor stobj)) ((not (equal (length (formals accessor wrld)) (length (cdr actual)))) (msg "The function symbol ~x0 is called with ~n1 ~ argument~#2~[~/s~] in a stobj-let binding where ~n3 ~ argument~#4~[ is~/s are~] required." accessor (length (cdr actual)) (if (eql (length (cdr actual)) 1) 0 1) (length (formals accessor wrld)) (if (eql (length (formals accessor wrld)) 1) 0 1))) (t (chk-stobj-let/bindings stobj acc-stobj first-acc (cdr bound-vars) (cdr actuals) wrld))))))))))))
chk-stobj-let/updaters-1function
(defun chk-stobj-let/updaters-1 (bindings producer-vars lst) (cond ((endp bindings) nil) (t (let ((binding (car bindings))) (case-match binding ((var actual . updater?) (mv-let (st-get stobj0 s2 s2-creator) (parse-stobj-let-actual actual) (declare (ignore st-get s2 stobj0 s2-creator)) (let ((accessor (car actual))) (cond ((and (null updater?) (not (member-eq var producer-vars))) (chk-stobj-let/updaters-1 (cdr bindings) producer-vars lst)) (t (let* ((updater (if updater? (car updater?) (stobj-updater-guess-from-accessor accessor))) (accessor-tail (member-eq accessor lst)) (actual-updater (cadr accessor-tail))) (assert$ accessor-tail (cond ((eq updater actual-updater) (chk-stobj-let/updaters-1 (cdr bindings) producer-vars lst)) (t (msg "The stobj-let bindings have specified~@0 that ~ the stobj field updater corresponding to ~ accessor ~x1 is ~x2, but the actual ~ corresponding updater is ~x3.~@4" (if updater? "" " implicitly") accessor updater actual-updater (if (member-eq var producer-vars) "" (msg " (This error can be eliminated by ~ replacing the offending binding, ~x0, by ~ ~x1.)" binding (list (car binding) (cadr binding)))))))))))))) (& (msg "Implementation error: unexpected form of stobj-let binding for ~ ~x0." binding)))))))
chk-stobj-let/updatersfunction
(defun chk-stobj-let/updaters (bindings producer-vars stobj wrld) (chk-stobj-let/updaters-1 bindings producer-vars (access stobj-property (getpropc stobj 'stobj nil wrld) :names)))
alist-to-doubletsfunction
(defun alist-to-doublets (alist) (declare (xargs :guard (alistp alist))) (cond ((endp alist) nil) (t (cons (list (caar alist) (cdar alist)) (alist-to-doublets (cdr alist))))))
chk-stobj-let/accessors2function
(defun chk-stobj-let/accessors2 (alist producer-vars concretep wrld) (cond ((endp alist) nil) (t (let* ((msg1 (chk-stobj-let/accessors2 (cdr alist) producer-vars concretep wrld)) (key (caar alist)) (indexp (consp key)) (fn$c (if indexp (car key) key)) (pairs (and (cdr (cdar alist)) (reverse (cdar alist)))) (bad-pairs (restrict-alist producer-vars pairs)) (msg2 (and bad-pairs (msg "The stobj-let binding expressions ~x0 ~@1~@2 ~ read~@3 stobj ~x4 with accessor ~x5~@6. Since ~ variable~#7~[ ~&7 is~/s ~&7 are~] to be updated ~ (i.e., ~#7~[it is~/they are~] among the ~ stobj-let form's producer variables), this ~ aliasing is illegal." (strip-cdrs pairs) (if (cddr pairs) "all" "both") (if concretep "" " ultimately") (if concretep "" " concrete") (getpropc fn$c 'stobj-function nil wrld) fn$c (if indexp (if (unquoted-symbol (cdr key)) " using identical stobj keys" " using identical array indices") "") (strip-cars bad-pairs))))) (cond ((null msg1) msg2) ((null msg2) msg1) (t (msg "~@0~|Also: ~@1" msg2 msg1)))))))
chk-stobj-let/accessors1function
(defun chk-stobj-let/accessors1 (bound-vars actuals producer-vars tuples tuples-lst wrld alist) (cond ((endp bound-vars) (chk-stobj-let/accessors2 alist producer-vars (null tuples) wrld)) (t (let* ((var (car bound-vars)) (actual (car actuals)) (fn (car actual)) (fn$c (cond (tuples (let* ((tuple (assoc-eq fn tuples)) (fn$c0 (caddr tuple))) (concrete-accessor fn$c0 tuples-lst))) (t fn))) (index (and (not (= (length actual) 2)) (cadr actual))) (key (if index (cons fn$c index) fn$c)) (new (cons var actual)) (old (cdr (assoc-equal key alist)))) (chk-stobj-let/accessors1 (cdr bound-vars) (cdr actuals) producer-vars tuples tuples-lst wrld (put-assoc-equal key (cons new old) alist))))))
collect-some-triples-with-non-nil-cdddrsfunction
(defun collect-some-triples-with-non-nil-cdddrs (keys alist) (cond ((endp alist) nil) ((and (cdddr (car alist)) (member-eq (caar alist) keys)) (cons (car alist) (collect-some-triples-with-non-nil-cdddrs keys (cdr alist)))) (t (collect-some-triples-with-non-nil-cdddrs keys (cdr alist)))))
chk-stobj-let/accessorsfunction
(defun chk-stobj-let/accessors (st bound-vars actuals producer-vars wrld) (let ((abs-info (getpropc st 'absstobj-info nil wrld))) (cond (abs-info (let* ((tuples (access absstobj-info abs-info :absstobj-tuples)) (st$c (access absstobj-info abs-info :st$c)) (tuples-lst (absstobj-tuples-lst st$c wrld))) (assert$ tuples (chk-stobj-let/accessors1 bound-vars actuals producer-vars tuples tuples-lst wrld nil)))) (t (chk-stobj-let/accessors1 bound-vars actuals producer-vars nil nil wrld nil)))))
chk-stobj-letfunction
(defun chk-stobj-let (bound-vars actuals stobj producer-vars bindings known-stobjs wrld) (cond ((not (stobjp stobj known-stobjs wrld)) (msg "The name ~x0 is being used as a single-threaded object. But in the ~ current context, ~x0 is not a declared stobj name." stobj)) (t (let* ((first-accessor (car (car actuals))) (acc-stobj (getpropc first-accessor 'stobj-function nil wrld))) (cond ((not (eq (congruent-stobj-rep acc-stobj wrld) (congruent-stobj-rep stobj wrld))) (msg "The name ~x0 is not the name of a field accessor for the ~ stobj ~x1, or even one congruent to it." first-accessor stobj)) (t (or (chk-stobj-let/bindings stobj acc-stobj first-accessor bound-vars actuals wrld) (chk-stobj-let/updaters bindings producer-vars acc-stobj wrld) (chk-stobj-let/accessors acc-stobj bound-vars actuals producer-vars wrld))))))))
all-nils-or-dfs-or-xfunction
(defun all-nils-or-dfs-or-x (x lst) (declare (xargs :guard (and (symbolp x) (true-listp lst)))) (cond ((endp lst) t) ((or (eq (car lst) x) (null (car lst)) (eq (car lst) :df)) (all-nils-or-dfs-or-x x (cdr lst))) (t nil)))
absstobj-field-fn-of-stobj-type-pfunction
(defun absstobj-field-fn-of-stobj-type-p (fn tuples) (cond ((endp tuples) (er hard 'absstobj-field-fn-of-stobj-type-p "Implementation error: Failed to find ~x0 among the exports of an ~ (implicit) abstract stobj." fn)) (t (let* ((tuple (car tuples)) (updater (cdddr tuple))) (cond ((eq fn (car tuple)) (and updater t)) ((eq fn updater) t) (t (absstobj-field-fn-of-stobj-type-p fn (cdr tuples))))))))
stobj-field-fn-of-stobj-type-pfunction
(defun stobj-field-fn-of-stobj-type-p (fn wrld) (let ((st (getpropc fn 'stobj-function nil wrld))) (and st (let ((abs-info (getpropc st 'absstobj-info nil wrld))) (cond (abs-info (let ((prop (getpropc st 'stobj nil wrld))) (and (not (eq fn (access stobj-property prop :recognizer))) (not (eq fn (access stobj-property prop :creator))) (absstobj-field-fn-of-stobj-type-p fn (cddr (access absstobj-info abs-info :absstobj-tuples)))))) (t (or (not (all-nils-or-dfs-or-x st (stobjs-in fn wrld))) (not (all-nils-or-dfs-or-x st (stobjs-out fn wrld))))))))))
stobj-recognizer-pfunction
(defun stobj-recognizer-p (fn wrld) (let ((stobj (getpropc fn 'stobj-function nil wrld))) (and stobj (eq fn (get-stobj-recognizer stobj wrld)))))
trans-ormacro
(defmacro trans-or (form1 condition form2 extra-msg) `(let ((trans-or-extra-msg ,EXTRA-MSG)) (mv-let (trans-or-erp trans-or-val trans-or-bindings) ,FORM1 (cond ((and trans-or-erp (check-vars-not-free (trans-or-er trans-or-val trans-or-bindings trans-or-extra-msg) ,CONDITION)) (mv-let (erp val bindings) (check-vars-not-free (trans-or-er trans-or-val trans-or-bindings trans-or-extra-msg) ,FORM2) (cond (erp (mv trans-or-erp (msg "~@0~@1" trans-or-val trans-or-extra-msg) trans-or-bindings)) (t (mv nil val bindings))))) (t (mv trans-or-erp trans-or-val trans-or-bindings))))))
inside-defabsstobjfunction
(defun inside-defabsstobj (wrld) (eq (caar (global-val 'embedded-event-lst wrld)) 'defstobj))
missing-known-stobjsfunction
(defun missing-known-stobjs (stobjs-out stobjs-out2 known-stobjs acc) (cond ((and (endp stobjs-out) (endp stobjs-out2)) (reverse acc)) ((eq (car stobjs-out) (car stobjs-out2)) (missing-known-stobjs (cdr stobjs-out) (cdr stobjs-out2) known-stobjs acc)) ((and (null (car stobjs-out)) (not (or (eq known-stobjs t) (member-eq (car stobjs-out2) known-stobjs)))) (missing-known-stobjs (cdr stobjs-out) (cdr stobjs-out2) known-stobjs (cons (car stobjs-out2) acc))) (t nil)))
corresponding-inline-fnfunction
(defun corresponding-inline-fn (fn wrld) (let ((macro-body (getpropc fn 'macro-body t wrld))) (and (not (eq macro-body t)) (let* ((fn$inline (add-suffix fn *inline-suffix*)) (formals (getpropc fn$inline 'formals t wrld))) (and (not (eq formals t)) (equal (macro-args fn wrld) formals) (equal macro-body (fcons-term* 'cons (kwote fn$inline) (if formals (xxxjoin 'cons (append formals (list *nil*))) (list *nil*)))) fn$inline)))))
untouchable-fn-pmacro
(defmacro untouchable-fn-p (sym wrld temp-touchable-fns) `(let ((sym ,SYM) (untouchable-fns (getpropc 'untouchable-fns 'global-value nil ,WRLD))) (and (member-eq sym untouchable-fns) (let ((temp-touchable-fns (check-vars-not-free (sym untouchable-fns) ,TEMP-TOUCHABLE-FNS))) (and (not (eq temp-touchable-fns t)) (not (member-eq sym temp-touchable-fns)))))))
primitive-event-macrosfunction
(defun primitive-event-macros nil (declare (xargs :guard t :mode :logic)) '(add-custom-keyword-hint add-include-book-dir add-include-book-dir! add-match-free-override comp defabsstobj defattach defaxiom defchoose defconst deflabel defmacro defstobj deftheory defthm defun defuns delete-include-book-dir delete-include-book-dir! encapsulate in-arithmetic-theory in-theory include-book logic mutual-recursion progn progn! program push-untouchable regenerate-tau-database remove-untouchable reset-prehistory set-body set-override-hints-macro set-prover-step-limit set-ruler-extenders table theory-invariant value-triple verify-guards verify-termination-boot-strap))
*syms-not-callable-in-code-fal*constant
(defconst *syms-not-callable-in-code-fal* (make-fast-alist (pairlis$ (union-eq '(certify-book defpkg in-package local make-event with-guard-checking-event with-output with-prover-step-limit) (primitive-event-macros)) nil)))
macroexpand1*-cmpfunction
(defun macroexpand1*-cmp (x ctx wrld state-vars) (cond ((or (atom x) (eq (car x) 'quote) (not (true-listp (cdr x))) (not (symbolp (car x))) (not (getpropc (car x) 'macro-body nil wrld)) (cond ((member-eq (car x) '(ld loop$ mv mv-let pargs read-user-stobj-alist stobj-let swap-stobjs translate-and-test with-global-stobj with-local-stobj)) t) ((eq (car x) 'progn!) (not (ttag wrld))) ((eq (car x) 'the) (and (consp (cdr x)) (eq (cadr x) 'double-float) (consp (cddr x)) (null (cdddr x)))) ((member-eq (car x) '(pand por plet)) (eq (access state-vars state-vars :parallel-execution-enabled) t)) (t (and (not (eq (access state-vars state-vars :ld-skip-proofsp) 'include-book)) (hons-get (car x) *syms-not-callable-in-code-fal*))))) (value-cmp x)) (t (mv-let (erp expansion) (macroexpand1-cmp x ctx wrld state-vars) (cond (erp (mv erp expansion)) (t (macroexpand1*-cmp expansion ctx wrld state-vars)))))))
find-stobj-out-and-call-1function
(defun find-stobj-out-and-call-1 (uterm known-stobjs ctx wrld state-vars) (cond ((atom uterm) (and (stobjp uterm known-stobjs wrld) uterm)) ((consp (car uterm)) (case-match uterm ((('lambda & body) . &) (find-stobj-out-and-call-1 body known-stobjs ctx wrld state-vars)) (& nil))) ((member-eq (car uterm) '(let let*)) (find-stobj-out-and-call-1 (car (last uterm)) known-stobjs ctx wrld state-vars)) ((getpropc (car uterm) 'macro-body nil wrld) (mv-let (erp val) (macroexpand1-cmp uterm ctx wrld state-vars) (and (not erp) (find-stobj-out-and-call-1 val known-stobjs ctx wrld state-vars)))) ((member-eq (car uterm) *stobjs-out-invalid*) nil) (t (let ((stobjs-out (stobjs-out (car uterm) wrld))) (and (consp stobjs-out) (null (cdr stobjs-out)) (stobjp (car stobjs-out) known-stobjs wrld) (car stobjs-out))))))
find-stobj-out-and-callfunction
(defun find-stobj-out-and-call (lst known-stobjs ctx wrld state-vars) (cond ((endp lst) nil) (t (or (and (not (symbolp (car lst))) (let ((s (find-stobj-out-and-call-1 (car lst) known-stobjs ctx wrld state-vars))) (and s (cons s (car lst))))) (find-stobj-out-and-call (cdr lst) known-stobjs ctx wrld state-vars)))))
defined-symbolsfunction
(defun defined-symbols (sym-name pkg-name known-package-alist wrld acc) (cond ((endp known-package-alist) acc) (t (let* ((entry (car known-package-alist)) (pkg-entry-name (package-entry-name entry))) (cond ((or (equal pkg-name pkg-entry-name) (package-entry-hidden-p entry)) (defined-symbols sym-name pkg-name (cdr known-package-alist) wrld acc)) (t (let ((sym (intern$ sym-name pkg-entry-name))) (defined-symbols sym-name pkg-name (cdr known-package-alist) wrld (if (and (not (member-eq sym acc)) (or (function-symbolp sym wrld) (getpropc sym 'macro-body nil wrld))) (cons sym acc) acc)))))))))
macros-and-functions-in-other-packagesfunction
(defun macros-and-functions-in-other-packages (sym wrld) (let ((kpa (global-val 'known-package-alist wrld))) (defined-symbols (symbol-name sym) (symbol-package-name sym) kpa wrld nil)))
match-stobjsfunction
(defun match-stobjs (lst1 lst2 wrld acc) (cond ((endp lst1) (null lst2)) ((endp lst2) nil) ((not (eq (null (car lst1)) (null (car lst2)))) nil) ((or (null (car lst1)) (eq (car lst1) (car lst2))) (match-stobjs (cdr lst1) (cdr lst2) wrld acc)) ((not (congruent-stobjsp (car lst1) (car lst2) wrld)) nil) (t (let ((pair (assoc-eq (car lst1) acc))) (cond ((null pair) (match-stobjs (cdr lst1) (cdr lst2) wrld (acons (car lst1) (car lst2) acc))) (t (er hard! 'match-stobjs "Implementation error: expected no duplicate stobjs ~ in stobjs-out list!")))))))
all-unbadged-fnnamesmutual-recursion
(mutual-recursion (defun all-unbadged-fnnames (term wrld acc) (cond ((variablep term) acc) ((fquotep term) acc) (t (all-unbadged-fnnames-list (fargs term) wrld (cond ((flambda-applicationp term) (all-unbadged-fnnames (lambda-body (ffn-symb term)) wrld acc)) ((executable-badge (ffn-symb term) wrld) acc) (t (add-to-set-eq (ffn-symb term) acc))))))) (defun all-unbadged-fnnames-list (terms wrld acc) (cond ((endp terms) acc) (t (all-unbadged-fnnames-list (cdr terms) wrld (all-unbadged-fnnames (car terms) wrld acc))))))
*gratuitous-lambda-object-restriction-msg*constant
(defconst *gratuitous-lambda-object-restriction-msg* "See :DOC gratuitous-lambda-object-restrictions for a workaround if you ~ really mean to have an ill-formed LAMBDA-like constant in your code. You ~ may see this message without having explicitly typed a LAMBDA if you used ~ a loop$ statement. Loop$ statements are translated into calls of scions ~ that use LAMBDA objects generated from constituent expressions. If you ~ are defining a function that calls itself recursively from within a loop$ ~ you must include the xargs :LOOP$-RECURSION T and an explicit :MEASURE.")
edcls-from-lambda-object-dclsfunction
(defun edcls-from-lambda-object-dcls (dcls x bindings cform ctx wrld) (cond ((and (eq (car x) 'lambda) (< 1 (length dcls))) (trans-er+? cform x ctx "A lambda object must have no more than one DECLARE form and ~ ~x0 has ~x1. ~@2" x (length dcls) *gratuitous-lambda-object-restriction-msg*)) (t (mv-let (erp edcls) (collect-declarations-cmp dcls (cadr x) (car x) ctx wrld) (cond (erp (mv erp edcls bindings)) (t (let ((xargs (assoc-eq 'xargs edcls))) (cond ((null xargs) (trans-value edcls)) ((assoc-eq 'xargs (cdr (member xargs edcls))) (trans-er+? cform x ctx "Lambda objects and lambda$ expressions are allowed ~ to have at most one XARGS declaration. ~@0" *gratuitous-lambda-object-restriction-msg*)) ((not (and (true-listp xargs) (or (and (eql 3 (length xargs)) (eq (cadr xargs) :guard)) (and (eql 5 (length xargs)) (or (and (eq (cadr xargs) :guard) (eq (cadddr xargs) :split-types)) (and (eq (cadr xargs) :split-types) (eq (cadddr xargs) :guard))))) (member-eq (cadr (assoc-keyword :split-types (cdr xargs))) '(nil t)))) (trans-er+? cform x ctx "The XARGS of a lambda object or lambda$ ~ expression, when present, must specify a :GUARD, ~ may additionally specify :SPLIT-TYPES, and must ~ not specify any other keywords. For quoted ~ LAMBDAs the :SPLIT-TYPES keyword must be present, ~ must follow the :GUARD keyword and value, and must ~ be assigned T. For lambda$s, the keywords may ~ appear in either order and :SPLIT-TYPES, if ~ present, must be assigned NIL or T. ~x0 violates ~ this. ~@1" xargs *gratuitous-lambda-object-restriction-msg*)) ((eq (car x) 'lambda) (cond ((not (and (eq (cadr xargs) :guard) (eq (cadddr xargs) :split-types) (eq (car (cddddr xargs)) t))) (trans-er+? cform x ctx "The XARGS declaration of a lambda object, ~ when present, must have the form (XARGS ~ :GUARD term :SPLIT-TYPES T) -- the order of ~ the keys matters! -- and ~x0 does not have ~ this form. ~@1" xargs *gratuitous-lambda-object-restriction-msg*)) (t (trans-value edcls)))) (t (trans-value edcls))))))))))
edcls-from-lambda-object-dcls-short-cutfunction
(defun edcls-from-lambda-object-dcls-short-cut (tail) (cond ((endp (cdr tail)) nil) (t (append (cdr (car tail)) (edcls-from-lambda-object-dcls-short-cut (cdr tail))))))
make-plain-loop$-lambda-objectfunction
(defun make-plain-loop$-lambda-object (v spec carton) (cond ((eq spec t) (cond ((equal (excart :translated :guard carton) *t*) `(lambda$ (loop$-ivar) (let ((,V loop$-ivar)) (declare (ignorable ,V)) ,(EXCART :UNTRANSLATED :BODY CARTON)))) (t `(lambda$ (loop$-ivar) (declare (xargs :guard (let ((,V loop$-ivar)) (declare (ignorable ,V)) ,(EXCART :UNTRANSLATED :GUARD CARTON)))) (let ((,V loop$-ivar)) (declare (ignorable ,V)) ,(EXCART :UNTRANSLATED :BODY CARTON)))))) ((equal (excart :translated :guard carton) *t*) `(lambda$ (loop$-ivar) (declare (type ,SPEC loop$-ivar)) (let ((,V loop$-ivar)) (declare (ignorable ,V)) ,(EXCART :UNTRANSLATED :BODY CARTON)))) (t `(lambda$ (loop$-ivar) (declare (type ,SPEC loop$-ivar) (xargs :guard (let ((,V loop$-ivar)) ,(EXCART :UNTRANSLATED :GUARD CARTON)))) (let ((,V loop$-ivar)) (declare (ignorable ,V)) ,(EXCART :UNTRANSLATED :BODY CARTON))))))
translate-vstsfunction
(defun translate-vsts (vsts name bindings cform ctx wrld) (cond ((endp vsts) (trans-value nil)) (t (let* ((var (car (car vsts))) (spec (cadr (car vsts))) (guard (translate-declaration-to-guard spec `(car ,NAME) wrld)) (target (caddr (car vsts)))) (cond ((not (legal-variablep var)) (trans-er+? cform var ctx "~x0 is not a legal variable name." var)) ((assoc-eq var (cdr vsts)) (trans-er+? cform var ctx "~x0 is bound more than once." var)) ((null guard) (trans-er+? cform var ctx "~x0 is not a legal type specification." spec)) (t (trans-er-let* ((rest (translate-vsts (cdr vsts) `(cdr ,NAME) bindings cform ctx wrld))) (trans-value (cons (list var spec guard target) rest)))))))))
make-bindingsfunction
(defun make-bindings (vars var) (cond ((endp vars) nil) (t (cons `(,(CAR VARS) (car ,VAR)) (make-bindings (cdr vars) `(cdr ,VAR))))))
collect-tvsts-lifted-guardsfunction
(defun collect-tvsts-lifted-guards (tvsts) (cond ((endp tvsts) nil) ((not (eq (cadr (car tvsts)) t)) (cons (caddr (car tvsts)) (collect-tvsts-lifted-guards (cdr tvsts)))) (t (collect-tvsts-lifted-guards (cdr tvsts)))))
make-fancy-loop$-type-specsfunction
(defun make-fancy-loop$-type-specs (tvsts) (cond ((endp tvsts) nil) ((not (eq (cadr (car tvsts)) t)) (cons `(type ,(CADR (CAR TVSTS)) ,(CAR (CAR TVSTS))) (make-fancy-loop$-type-specs (cdr tvsts)))) (t (make-fancy-loop$-type-specs (cdr tvsts)))))
lift-fancy-loop$-carton-guardfunction
(defun lift-fancy-loop$-carton-guard (global-bindings local-bindings carton) (let ((temp (flatten-ands-in-lit (sublis-var (append (pairlis$ (strip-cars global-bindings) (strip-cadrs global-bindings)) (pairlis$ (strip-cars local-bindings) (strip-cadrs local-bindings))) (excart :translated :guard carton))))) (cond ((null temp) t) ((null (cdr temp)) (car temp)) (t (cons 'and temp)))))
make-fancy-loop$-lambda-objectfunction
(defun make-fancy-loop$-lambda-object (tvsts carton free-vars) (let* ((global-bindings (make-bindings free-vars 'loop$-gvars)) (local-bindings (make-bindings (strip-cars tvsts) 'loop$-ivars)) (guard `(and (true-listp loop$-gvars) (equal (len loop$-gvars) ,(LEN FREE-VARS)) (true-listp loop$-ivars) (equal (len loop$-ivars) ,(LEN TVSTS)) ,@(COLLECT-TVSTS-LIFTED-GUARDS TVSTS) ,@(IF (EQUAL (EXCART :TRANSLATED :GUARD CARTON) *T*) NIL (LIST (LIFT-FANCY-LOOP$-CARTON-GUARD GLOBAL-BINDINGS LOCAL-BINDINGS CARTON))))) (type-specs (make-fancy-loop$-type-specs tvsts)) (ignorables (append (strip-cars global-bindings) (strip-cars local-bindings)))) `(lambda$ (loop$-gvars loop$-ivars) (declare (xargs :guard ,GUARD)) (let (,@GLOBAL-BINDINGS ,@LOCAL-BINDINGS) ,@`((DECLARE ,@TYPE-SPECS (IGNORABLE ,@IGNORABLES))) ,(EXCART :UNTRANSLATED :BODY CARTON)))))
make-basic-loop$-targetfunction
(defun make-basic-loop$-target (spec target) (case (car target) (in (cadr target)) (on `(tails ,(IF (EQ SPEC T) (CADR TARGET) `(LET ((LOOP$-ON ,(CADR TARGET))) (PROG2$ (LET ((LOOP$-LAST-CDR (LAST-CDR LOOP$-ON))) (DECLARE (TYPE ,SPEC LOOP$-LAST-CDR)) LOOP$-LAST-CDR) LOOP$-ON))))) (from-to-by (if (eq spec t) target `(let ((loop$-lo ,(CADR TARGET)) (loop$-hi ,(CADDR TARGET)) (loop$-by ,(CADDDR TARGET))) (declare (type ,SPEC loop$-lo loop$-hi loop$-by)) (prog2$ (let ((loop$-final (+ loop$-lo loop$-by (* loop$-by (floor (- loop$-hi loop$-lo) loop$-by))))) (declare (type ,SPEC loop$-final)) loop$-final) (from-to-by loop$-lo loop$-hi loop$-by))))) (otherwise target)))
make-plain-loop$function
(defun make-plain-loop$ (v spec target untilc whenc op lobodyc) (let* ((target1 (make-basic-loop$-target spec target)) (target2 (if untilc `(until$ ,(MAKE-PLAIN-LOOP$-LAMBDA-OBJECT V SPEC UNTILC) ,TARGET1) target1)) (target3 (if whenc `(when$ ,(MAKE-PLAIN-LOOP$-LAMBDA-OBJECT V SPEC WHENC) ,TARGET2) target2)) (scion (cadr (assoc-eq op *for-loop$-keyword-info*)))) `(,SCION ,(MAKE-PLAIN-LOOP$-LAMBDA-OBJECT V SPEC LOBODYC) ,TARGET3)))
make-fancy-loop$-targetfunction
(defun make-fancy-loop$-target (tvsts) (cond ((endp tvsts) nil) (t (cons (make-basic-loop$-target (cadr (car tvsts)) (cadddr (car tvsts))) (make-fancy-loop$-target (cdr tvsts))))))
make-fancy-loop$function
(defun make-fancy-loop$ (tvsts untilc until-free-vars whenc when-free-vars op lobodyc lobody-free-vars) (let* ((target1 `(loop$-as (list ,@(MAKE-FANCY-LOOP$-TARGET TVSTS)))) (target2 (if untilc `(until$+ ,(MAKE-FANCY-LOOP$-LAMBDA-OBJECT TVSTS UNTILC UNTIL-FREE-VARS) (list ,@UNTIL-FREE-VARS) ,TARGET1) target1)) (target3 (if whenc `(when$+ ,(MAKE-FANCY-LOOP$-LAMBDA-OBJECT TVSTS WHENC WHEN-FREE-VARS) (list ,@WHEN-FREE-VARS) ,TARGET2) target2)) (scion+ (caddr (assoc-eq op *for-loop$-keyword-info*)))) `(,SCION+ ,(MAKE-FANCY-LOOP$-LAMBDA-OBJECT TVSTS LOBODYC LOBODY-FREE-VARS) (list ,@LOBODY-FREE-VARS) ,TARGET3)))
remove-for-loop$-guardsfunction
(defun remove-for-loop$-guards (args) (cond ((endp args) nil) ((and (symbolp (car args)) (or (symbol-name-equal (car args) "UNTIL") (symbol-name-equal (car args) "WHEN") (assoc-symbol-name-equal (car args) *for-loop$-keyword-info*)) (eq (cadr args) :guard)) (cons (car args) (cons (cadddr args) (remove-for-loop$-guards (cddddr args))))) (t (cons (car args) (remove-for-loop$-guards (cdr args))))))
remove-do-loop$-guardsfunction
(defun remove-do-loop$-guards (args) (cond ((endp args) nil) ((symbolp (car args)) (cond ((and (eq (cadr args) :guard) (or (symbol-name-equal (car args) "DO") (symbol-name-equal (car args) "FINALLY"))) (remove-do-loop$-guards (cons (car args) (cdddr args)))) ((and (member-eq (cadr args) '(:measure :values)) (symbol-name-equal (car args) "DO")) (remove-do-loop$-guards (cons (car args) (cdddr args)))) (t (cons (car args) (remove-do-loop$-guards (cdr args)))))) (t (cons (car args) (remove-do-loop$-guards (cdr args))))))
remove-loop$-guardsfunction
(defun remove-loop$-guards (args) (cond ((and (symbolp (car args)) (symbol-name-equal (car args) "FOR")) (remove-for-loop$-guards args)) (t (remove-do-loop$-guards args))))
translate11-var-or-quote-exitfunction
(defun translate11-var-or-quote-exit (x term stobjs-out bindings known-stobjs known-dfs flet-alist cform ctx wrld state-vars) (declare (ignore flet-alist state-vars)) (cond ((eq stobjs-out t) (trans-value term)) ((consp stobjs-out) (cond ((cdr stobjs-out) (trans-er+? cform x ctx "One value, ~x0, is being returned where ~x1 values were ~ expected." x (length stobjs-out))) ((and (or (null (car stobjs-out)) (eq (car stobjs-out) :df)) (stobjp term known-stobjs wrld)) (trans-er+? cform x ctx "A single-threaded object, namely ~x0, is being used where ~ ~#1~[an ordinary object~/a df expression~] is expected." term (if (null (car stobjs-out)) 0 1))) ((and (car stobjs-out) (not (eq (car stobjs-out) :df)) (not (eq (car stobjs-out) term))) (cond ((stobjp term known-stobjs wrld) (trans-er+? cform x ctx "The single-threaded object ~x0 is being used where the ~ single-threaded object ~x1 was expected." term (car stobjs-out))) (t (trans-er+? cform x ctx "The ordinary object ~x0 is being used where the ~ single-threaded object ~x1 was expected." term (car stobjs-out))))) ((not (iff (eq (car stobjs-out) :df) (member-eq term known-dfs))) (trans-er+? cform x ctx "The form ~x0 represents ~#1~[an ordinary object~/a :DF~], ~ but it is being used where a form representing ~#1~[a ~ :DF~/an ordinary object~] was expected. See :DOC df." x (if (eq (car stobjs-out) :df) 0 1))) (t (trans-value term)))) (t (trans-value term (translate-bind stobjs-out (list (if (stobjp term known-stobjs wrld) term (if (and (variablep term) (member-eq term known-dfs)) :df nil))) bindings)))))
ilks-per-argument-slotfunction
(defun ilks-per-argument-slot (fn wrld) (declare (xargs :guard (and (symbolp fn) (ilks-plist-worldp wrld)))) (cond ((eq fn 'apply$) '(:fn? nil)) ((eq fn 'ev$) '(:expr nil)) (t (let ((bdg (get-badge fn wrld))) (cond ((null bdg) nil) (t (let ((ilks (access apply$-badge bdg :ilks))) (if (eq ilks t) nil ilks))))))))
quote-normal-form1mutual-recursion
(mutual-recursion (defun quote-normal-form1 (form) (declare (xargs :guard (pseudo-termp form))) (cond ((or (variablep form) (fquotep form) (eq (ffn-symb form) 'hide)) (mv nil form)) (t (mv-let (changedp lst) (quote-normal-form1-lst (fargs form)) (let ((fn (ffn-symb form))) (cond (changedp (mv t (cons-term fn lst))) ((and (symbolp fn) (quote-listp lst)) (cons-term1-mv2 fn lst form)) (t (mv nil form)))))))) (defun quote-normal-form1-lst (l) (declare (xargs :guard (pseudo-term-listp l))) (cond ((endp l) (mv nil l)) (t (mv-let (changedp1 term) (quote-normal-form1 (car l)) (mv-let (changedp2 lst) (quote-normal-form1-lst (cdr l)) (cond ((or changedp1 changedp2) (mv t (cons term lst))) (t (mv nil l)))))))))
quote-normal-formfunction
(defun quote-normal-form (form) (declare (xargs :guard (pseudo-termp form))) (mv-let (changedp val) (quote-normal-form1 form) (declare (ignore changedp)) val))
loop$-defaultfunction
(defun loop$-default (values) (declare (xargs :guard (and (consp values) (symbol-listp values)))) (cond ((cdr values) (make-true-list-cons-nest (substitute *nil* nil (substitute (fcons-term* 'to-df *0*) :df values)))) ((null (car values)) *nil*) ((eq (car values) :df) (fcons-term* 'to-df *0*)) (t (car values))))
parse-with-global-stobjfunction
(defun parse-with-global-stobj (x) (declare (xargs :guard (true-listp x))) (flet ((with-global-stobj-er (x m) (mv (msg "Illegal call of WITH-GLOBAL-STOBJ, ~x0: ~@1" (cons 'with-global-stobj x) m) nil nil nil))) (cond ((not (member (len x) '(2 3))) (with-global-stobj-er x (msg "The length must be 3 or 4, but it is ~x0." (1+ (len x))))) (t (mv-let (stobj sig body) (cond ((= (len x) 2) (mv (car x) nil (cadr x))) (t (mv (car x) (cadr x) (caddr x)))) (cond ((or (null stobj) (not (symbolp stobj))) (with-global-stobj-er x (msg "The first argument must be a stobj name, but that argument ~ is ~x0." stobj))) ((not (symbol-listp sig)) (with-global-stobj-er x "The signature (second) argument must be nil or a list of ~ symbols.")) ((and sig (not (member-eq stobj sig))) (with-global-stobj-er x (msg "The signature (second) argument fails to contain the bound ~ stobj, which in this case is ~x0." stobj))) ((and sig (duplicates (remove nil sig))) (with-global-stobj-er x (msg "The symbol~#0~[ ~&0 occurs~/s ~&0 occur~] more than once ~ in the signature (second) argument, where only nil is ~ allowed to occur more than once." (duplicates (remove nil sig))))) (t (mv nil stobj sig body))))))))
*with-global-stobj-prefix*constant
(defconst *with-global-stobj-prefix* "{WGS}")
*with-global-stobj-prefix-chars*constant
(defconst *with-global-stobj-prefix-chars* (coerce *with-global-stobj-prefix* 'list))
with-global-stobj-var-lstfunction
(defun with-global-stobj-var-lst (sig pkg-witness prefix-chars i avoid-lst) (declare (xargs :guard (and (true-listp sig) (symbol-listp avoid-lst) (natp i) (eq pkg-witness (pkg-witness "ACL2")) (equal prefix-chars *with-global-stobj-prefix-chars*)))) (cond ((endp sig) nil) ((null (car sig)) (let ((var (genvar1 pkg-witness prefix-chars avoid-lst i))) (cons var (with-global-stobj-var-lst (cdr sig) pkg-witness prefix-chars (1+ i) (cons var avoid-lst))))) (t (cons (car sig) (with-global-stobj-var-lst (cdr sig) pkg-witness prefix-chars i avoid-lst)))))
with-global-stobj-adjust-signature-or-varsfunction
(defun with-global-stobj-adjust-signature-or-vars (st sig) (declare (xargs :guard (and (symbol-listp sig) (symbolp st) (not (eq st 'state))))) (let ((vars (remove1 st sig :test 'eq))) (if (member 'state vars :test 'eq) vars (append vars '(state)))))
with-global-stobj-fn1function
(defun with-global-stobj-fn1 (st sig body rawp) (declare (xargs :guard (symbol-listp sig))) (cond ((null sig) body) (t (let ((wusa (if rawp 'write-user-stobj-alist-raw 'write-user-stobj-alist))) (cond ((null (cdr sig)) `(let ((,ST ,BODY)) (,WUSA ',ST ,ST state))) (t (let* ((vars0 (with-global-stobj-var-lst sig (pkg-witness "ACL2") *with-global-stobj-prefix-chars* 0 (add-to-set-eq 'state sig))) (vars (with-global-stobj-adjust-signature-or-vars st vars0))) `(mv-let ,VARS0 ,BODY (let ((state (,WUSA ',ST ,ST state))) (mv? ,@VARS))))))))))
*see-doc-with-global-stobj*constant
(defconst *see-doc-with-global-stobj* " See :DOC with-global-stobj.")
with-global-stobj-fnfunction
(defun with-global-stobj-fn (x rawp) (declare (xargs :guard (true-listp x))) (mv-let (msg st sig body) (parse-with-global-stobj x) (cond (msg (er hard? 'with-global-stobj "~@0~@1" msg *see-doc-with-global-stobj*)) (t `(let ((,ST (,(IF RAWP 'READ-USER-STOBJ-ALIST-RAW 'READ-USER-STOBJ-ALIST) ',ST state))) ,(WITH-GLOBAL-STOBJ-FN1 ST SIG BODY RAWP))))))
with-global-stobjmacro
(defmacro with-global-stobj (&rest args) (with-global-stobj-fn args nil))
collect-global-stobjsmutual-recursion
(mutual-recursion (defun collect-global-stobjs (term wrld reads writes fns-seen) (cond ((or (variablep term) (fquotep term)) (mv reads writes fns-seen)) ((flambda-applicationp term) (mv-let (reads writes fns-seen) (collect-global-stobjs (lambda-body (ffn-symb term)) wrld reads writes fns-seen) (collect-global-stobjs-lst (fargs term) wrld reads writes fns-seen))) (t (mv-let (reads writes fns-seen) (let ((fn (ffn-symb term))) (cond ((member-eq fn fns-seen) (mv reads writes fns-seen)) ((and (eq fn 'read-user-stobj-alist) (quotep (fargn term 1))) (mv (add-to-set-eq (unquote (fargn term 1)) reads) writes (cons 'read-user-stobj-alist fns-seen))) ((and (eq fn 'write-user-stobj-alist) (quotep (fargn term 1))) (mv reads (add-to-set-eq (unquote (fargn term 1)) writes) (cons 'read-user-stobj-alist fns-seen))) (t (let ((prop (getpropc fn 'global-stobjs nil wrld))) (mv (union-eq (car prop) reads) (union-eq (cdr prop) writes) (cons fn fns-seen)))))) (collect-global-stobjs-lst (fargs term) wrld reads writes fns-seen))))) (defun collect-global-stobjs-lst (terms wrld reads writes fns-seen) (cond ((endp terms) (mv reads writes fns-seen)) (t (mv-let (reads writes fns-seen) (collect-global-stobjs (car terms) wrld reads writes fns-seen) (collect-global-stobjs-lst (cdr terms) wrld reads writes fns-seen))))))
path-to-with-global-stobjfunction
(defun path-to-with-global-stobj (st fns upd wrld acc seen) (cond ((endp fns) acc) (t (let ((fn (car fns))) (cond ((member-eq fn seen) (path-to-with-global-stobj st (cdr fns) upd wrld acc seen)) ((member-eq fn acc) (cons :loop acc)) (t (let ((prop (getpropc fn 'global-stobjs nil wrld))) (cond ((and prop (or (member st (cdr prop)) (and (not upd) (member st (car prop))))) (let ((body (body fn nil wrld))) (cond ((null body) (cons fn acc)) (t (path-to-with-global-stobj st (all-fnnames1 nil body (all-fnnames (guard fn nil wrld))) upd wrld (cons fn acc) (let ((rec (getpropc fn 'recursivep nil wrld))) (if rec (append rec seen) (cons fn seen)))))))) (t (path-to-with-global-stobj st (cdr fns) upd wrld acc (let ((rec (getpropc fn 'recursivep nil wrld))) (if rec (append rec seen) (cons fn seen)))))))))))))
with-global-stobj-illegal-path-msgfunction
(defun with-global-stobj-illegal-path-msg (prefix suffix path st upd wrld) (mv-let (loop path) (cond ((eq (car path) :loop) (mv t (cdr path))) (t (mv nil path))) (msg "~@0 ~*1~@2" prefix (list "~@0" "~x*, which ~@0" "~x*, which calls " "~x*, which calls " (reverse path) (cons #\0 (msg "makes ~#0~[a~/an updating~] ~x1 call~@2 that binds ~ ~x3~@4." (if upd 1 0) 'with-global-stobj (if (or (null path) (body (car path) nil wrld)) "" " (as specified by the signature of the ~ constrained function, ~x*)") st suffix))) (if loop "~|~%NOTE: The path shown above indicates a loop, which should ~ be impossible unless redefinition was used." ""))))
chk-global-stobj-bodyfunction
(defun chk-global-stobj-body (form body wrld) (let ((st (cadr form))) (mv-let (reads writes fns-seen) (collect-global-stobjs body wrld nil nil nil) (declare (ignore fns-seen)) (cond ((or (member-eq st writes) (and (= (len form) 4) (member-eq st reads))) (let* ((upd (= (len form) 3)) (path (path-to-with-global-stobj st (all-fnnames body) upd wrld nil nil))) (msg "The form binding stobj ~x0,~|~%~x1,~|~%is illegal because ~ ~@2" st form (with-global-stobj-illegal-path-msg (msg "its body~@0" (if path " calls" "")) "" path st upd wrld)))) (t nil)))))
macro-vars-keyfunction
(defun macro-vars-key (args) (declare (xargs :guard (and (true-listp args) (macro-arglist-keysp args nil)))) (cond ((endp args) nil) ((eq (car args) '&allow-other-keys) (cond ((null (cdr args)) nil) (t (er hard nil "macro-vars-key")))) ((atom (car args)) (cons (car args) (macro-vars-key (cdr args)))) (t (let ((formal (cond ((atom (car (car args))) (car (car args))) (t (cadr (car (car args))))))) (cond ((int= (length (car args)) 3) (cons formal (cons (caddr (car args)) (macro-vars-key (cdr args))))) (t (cons formal (macro-vars-key (cdr args)))))))))
macro-vars-after-restfunction
(defun macro-vars-after-rest (args) (declare (xargs :guard (and (true-listp args) (macro-arglist-after-restp args)))) (cond ((endp args) nil) ((eq (car args) '&key) (macro-vars-key (cdr args))) (t (er hard nil "macro-vars-after-rest"))))
macro-vars-optionalfunction
(defun macro-vars-optional (args) (declare (xargs :guard (and (true-listp args) (macro-arglist-optionalp args)))) (cond ((endp args) nil) ((eq (car args) '&key) (macro-vars-key (cdr args))) ((member (car args) '(&rest &body)) (cons (cadr args) (macro-vars-after-rest (cddr args)))) ((symbolp (car args)) (cons (car args) (macro-vars-optional (cdr args)))) ((int= (length (car args)) 3) (cons (caar args) (cons (caddr (car args)) (macro-vars-optional (cdr args))))) (t (cons (caar args) (macro-vars-optional (cdr args))))))
macro-varsfunction
(defun macro-vars (args) (declare (xargs :guard (macro-args-structurep args) :guard-hints (("Goal" :in-theory (disable lambda-keywordp))))) (cond ((endp args) nil) ((eq (car args) '&whole) (cons (cadr args) (macro-vars (cddr args)))) ((member (car args) '(&rest &body)) (cons (cadr args) (macro-vars-after-rest (cddr args)))) ((eq (car args) '&optional) (macro-vars-optional (cdr args))) ((eq (car args) '&key) (macro-vars-key (cdr args))) ((or (not (symbolp (car args))) (lambda-keywordp (car args))) (er hard nil "macro-vars")) (t (cons (car args) (macro-vars (cdr args))))))
chk-legal-init-msgfunction
(defun chk-legal-init-msg (x) (cond ((and (consp x) (true-listp x) (int= 2 (length x)) (eq (car x) 'quote)) nil) (t (msg "Illegal initial value. In ACL2 we require that initial ~ values be quoted forms and you used ~x0.~#1~[ You should ~ just write '~x0 instead. Warren Teitelman once remarked ~ that it was really dumb of a Fortran compiler to say ~ ``missing comma!'' ``If it knows a comma is missing, why ~ not just put one in?'' Indeed.~/~] See :DOC macro-args." x (if (or (eq x nil) (eq x t) (acl2-numberp x) (stringp x) (characterp x)) 0 1)))))
chk-macro-arglist-keysfunction
(defun chk-macro-arglist-keys (args keys-passed) (cond ((null args) nil) ((eq (car args) '&allow-other-keys) (cond ((null (cdr args)) nil) (t (msg "&ALLOW-OTHER-KEYS may only occur as the last member ~ of an arglist so it is illegal to follow it with ~x0. ~ See :DOC macro-args." (cadr args))))) ((atom (car args)) (cond ((symbolp (car args)) (let ((new (intern (symbol-name (car args)) "KEYWORD"))) (cond ((member new keys-passed) (msg "The symbol-name of each keyword parameter ~ specifier must be distinct. But you have used ~ the symbol-name ~s0 twice. See :DOC ~ macro-args." (symbol-name (car args)))) (t (chk-macro-arglist-keys (cdr args) (cons new keys-passed)))))) (t (msg "Each keyword parameter specifier must be either a ~ symbol or a list. Thus, ~x0 is illegal. See :DOC ~ macro-args." (car args))))) ((or (not (true-listp (car args))) (> (length (car args)) 3)) (msg "Each keyword parameter specifier must be either a symbol or a ~ truelist of length 1, 2, or 3. Thus, ~x0 is illegal. See ~ :DOC macro-args." (car args))) (t (or (cond ((symbolp (caar args)) nil) (t (cond ((or (not (true-listp (caar args))) (not (equal (length (caar args)) 2)) (not (keywordp (car (caar args)))) (not (symbolp (cadr (caar args))))) (msg "Keyword parameter specifiers in which ~ the keyword is specified explicitly, ~ e.g., specifiers of the form ((:key var) ~ init svar), must begin with a truelist ~ of length 2 whose first element is a ~ keyword and whose second element is a ~ symbol. Thus, ~x0 is illegal. See :DOC ~ macro-args." (car args))) (t nil)))) (let ((new (cond ((symbolp (caar args)) (intern (symbol-name (caar args)) "KEYWORD")) (t (car (caar args)))))) (or (cond ((member new keys-passed) (msg "The symbol-name of each keyword parameter ~ specifier must be distinct. But you have used ~ the symbol-name ~s0 twice. See :DOC ~ macro-args." (symbol-name new))) (t nil)) (cond ((> (length (car args)) 1) (chk-legal-init-msg (cadr (car args)))) (t nil)) (cond ((> (length (car args)) 2) (cond ((symbolp (caddr (car args))) nil) (t (msg "~x0 is an illegal keyword parameter ~ specifier because the ``svar'' ~ specified, ~x1, is not a symbol. See ~ :DOC macro-args." (car args) (caddr (car args)))))) (t nil)) (chk-macro-arglist-keys (cdr args) (cons new keys-passed))))))))
chk-macro-arglist-after-restfunction
(defun chk-macro-arglist-after-rest (args) (cond ((null args) nil) ((eq (car args) '&key) (chk-macro-arglist-keys (cdr args) nil)) (t (msg "Only keyword specs may follow &REST or &BODY. See :DOC ~ macro-args."))))
chk-macro-arglist-optionalfunction
(defun chk-macro-arglist-optional (args) (cond ((null args) nil) ((member (car args) '(&rest &body)) (cond ((and (cdr args) (symbolp (cadr args)) (not (lambda-keywordp (cadr args)))) (chk-macro-arglist-after-rest (cddr args))) (t (msg "~x0 must be followed by a variable symbol. See :DOC ~ macro-args." (car args))))) ((eq (car args) '&key) (chk-macro-arglist-keys (cdr args) nil)) ((symbolp (car args)) (chk-macro-arglist-optional (cdr args))) ((or (atom (car args)) (not (true-listp (car args))) (not (< (length (car args)) 4))) (msg "Each optional parameter specifier must be either a symbol or a ~ true list of length 1, 2, or 3. ~x0 is thus illegal. See ~ :DOC macro-args." (car args))) ((not (symbolp (car (car args)))) (msg "~x0 is an illegal optional parameter specifier because the ~ ``variable symbol'' used is not a symbol. See :DOC macro-args." (car args))) ((and (> (length (car args)) 1) (chk-legal-init-msg (cadr (car args))))) ((and (int= (length (car args)) 3) (not (symbolp (caddr (car args))))) (msg "~x0 is an illegal optional parameter specifier because the ~ ``svar'' specified, ~x1, is not a symbol. See :DOC macro-args." (car args) (caddr (car args)))) (t (chk-macro-arglist-optional (cdr args)))))
chk-macro-arglist1function
(defun chk-macro-arglist1 (args) (cond ((null args) nil) ((not (symbolp (car args))) (msg "~x0 is illegal as the name of a required formal parameter. ~ See :DOC macro-args." (car args))) ((member (car args) '(&rest &body)) (cond ((and (cdr args) (symbolp (cadr args)) (not (lambda-keywordp (cadr args)))) (chk-macro-arglist-after-rest (cddr args))) (t (msg "~x0 must be followed by a variable symbol. See :DOC ~ macro-args." (car args))))) ((eq (car args) '&optional) (chk-macro-arglist-optional (cdr args))) ((eq (car args) '&key) (chk-macro-arglist-keys (cdr args) nil)) (t (chk-macro-arglist1 (cdr args)))))
chk-macro-arglist-msgfunction
(defun chk-macro-arglist-msg (args chk-state wrld) (or (and (not (true-listp args)) (msg "The arglist ~x0 is not a true list. See :DOC macro-args." args)) (let ((lambda-keywords (collect-lambda-keywordps args)) (err-string-for-&whole "When the &whole lambda-list keyword is used it must be the first ~ element of the lambda-list and it must be followed by a variable ~ symbol. This is not the case in ~x0. See :DOC macro-args.")) (cond ((or (subsequencep lambda-keywords '(&whole &optional &rest &key &allow-other-keys)) (subsequencep lambda-keywords '(&whole &optional &body &key &allow-other-keys))) (cond (args (cond ((member-eq '&whole (cdr args)) (msg err-string-for-&whole args)) ((and (member-eq '&allow-other-keys args) (not (member-eq '&allow-other-keys (member-eq '&key args)))) (msg "The use of ~x0 is only permitted when preceded by ~ ~x1. The argument list ~x2 is thus illegal." '&allow-other-keys '&key args)) ((eq (car args) '&whole) (cond ((and (consp (cdr args)) (symbolp (cadr args)) (not (lambda-keywordp (cadr args)))) (chk-macro-arglist1 (cddr args))) (t (msg err-string-for-&whole args)))) (t (chk-macro-arglist1 args)))) (t nil))) (t (msg "The lambda-list keywords allowed by ACL2 are &WHOLE, ~ &OPTIONAL, &REST, &BODY, &KEY, and &ALLOW-OTHER-KEYS. These ~ must occur (if at all) in that order, with no duplicate ~ occurrences and at most one of &REST and &BODY. The argument ~ list ~x0 is thus illegal." args)))) (chk-arglist-msg (macro-vars args) chk-state wrld)))
chk-macro-arglist-cmpfunction
(defun chk-macro-arglist-cmp (args chk-state ctx wrld) (let ((msg (chk-macro-arglist-msg args chk-state wrld))) (cond (msg (er-cmp ctx "~@0" msg)) (t (value-cmp nil)))))
chk-macro-arglistfunction
(defun chk-macro-arglist (args chk-state ctx state) (cmp-to-error-triple (chk-macro-arglist-cmp args chk-state ctx (w state))))
chk-defmacro-widthfunction
(defun chk-defmacro-width (rst) (cond ((or (not (true-listp rst)) (not (> (length rst) 2))) (mv "Defmacro requires at least 3 arguments. ~x0 is ~ ill-formed. See :DOC defmacro." (cons 'defmacro rst))) (t (let ((name (car rst)) (args (cadr rst)) (value (car (last rst))) (dcls-and-docs (butlast (cddr rst) 1))) (mv nil (list name args dcls-and-docs value))))))
chk-defmacro-untouchable-cmpfunction
(defun chk-defmacro-untouchable-cmp (name ctx wrld state-vars) (cond ((untouchable-fn-p name wrld (access state-vars state-vars :temp-touchable-fns)) (er-cmp ctx "The name ~x0 has been declared to be an untouchable ~ function. It is thus illegal to define this name as a ~ macro. See :DOC defmacro and see :DOC push-untouchable." name)) (t (value-cmp nil))))
chk-defmacro-untouchablefunction
(defun chk-defmacro-untouchable (name ctx wrld state) (cmp-to-error-triple (chk-defmacro-untouchable-cmp name ctx wrld (default-state-vars t))))
chk-acceptable-defmacro-cmpfunction
(defun chk-acceptable-defmacro-cmp (mdef local-p ctx wrld state-vars) (mv-let (err-string four) (chk-defmacro-width mdef) (cond (err-string (er-cmp ctx err-string four)) (t (let ((name (car four)) (args (cadr four)) (dcls (caddr four)) (body (cadddr four))) (er-progn-cmp (chk-defmacro-untouchable-cmp name ctx wrld state-vars) (chk-all-but-new-name-cmp name ctx 'macro wrld) (chk-macro-arglist-cmp args nil ctx wrld) (er-let*-cmp ((edcls (collect-declarations-cmp dcls (macro-vars args) (if local-p 'macrolet 'defmacro) ctx wrld))) (let* ((edcls (if (stringp (car edcls)) (cdr edcls) edcls)) (guard (and (not local-p) (conjoin-untranslated-terms (get-guards1 edcls '(guards types) nil name wrld))))) (value-cmp (list* name args edcls body guard))))))))))
chk-acceptable-defmacrofunction
(defun chk-acceptable-defmacro (mdef local-p ctx wrld state) (cmp-to-error-triple (chk-acceptable-defmacro-cmp mdef local-p ctx wrld (default-state-vars t))))
collect-non-apply$-primps2function
(defun collect-non-apply$-primps2 (fns acc badge-prim-falist) (cond ((endp fns) acc) ((hons-get (car fns) badge-prim-falist) (collect-non-apply$-primps2 (cdr fns) acc badge-prim-falist)) (t (collect-non-apply$-primps2 (cdr fns) (add-to-set-eq (car fns) acc) badge-prim-falist))))
collect-non-apply$-primps1mutual-recursion
(mutual-recursion (defun collect-non-apply$-primps1 (term ilk badge-prim-falist wrld acc) (cond ((variablep term) acc) ((fquotep term) (cond ((or (eq ilk :fn) (eq ilk :fn?)) (let ((fn (unquote term))) (cond ((symbolp fn) (if (hons-get fn badge-prim-falist) acc (add-to-set-eq fn acc))) ((well-formed-lambda-objectp fn wrld) (let ((fns (all-fnnames1 nil (lambda-object-guard fn) (all-fnnames1 nil (lambda-object-body fn) nil)))) (collect-non-apply$-primps2 fns acc badge-prim-falist))) (t (add-to-set-equal fn acc))))) (t acc))) ((flambdap (ffn-symb term)) (collect-non-apply$-primps1 (lambda-body (ffn-symb term)) nil badge-prim-falist wrld (collect-non-apply$-primps1-lst (fargs term) nil badge-prim-falist wrld acc))) (t (collect-non-apply$-primps1-lst (fargs term) (ilks-per-argument-slot (ffn-symb term) wrld) badge-prim-falist wrld acc)))) (defun collect-non-apply$-primps1-lst (terms ilks badge-prim-falist wrld acc) (cond ((endp terms) acc) (t (collect-non-apply$-primps1 (car terms) (car ilks) badge-prim-falist wrld (collect-non-apply$-primps1-lst (cdr terms) (cdr ilks) badge-prim-falist wrld acc))))))
collect-non-apply$-primpsfunction
(defun collect-non-apply$-primps (term wrld) (cond ((global-val 'boot-strap-flg wrld) nil) (t (collect-non-apply$-primps1 term nil (unquote (getpropc '*badge-prim-falist* 'const nil wrld)) wrld nil))))
lambda-object-guard-lstfunction
(defun lambda-object-guard-lst (objs) (cond ((endp objs) nil) (t (let ((guard (lambda-object-guard (car objs)))) (if guard (cons guard (lambda-object-guard-lst (cdr objs))) (lambda-object-guard-lst (cdr objs)))))))
lambda-object-body-lstfunction
(defun lambda-object-body-lst (objs) (cond ((endp objs) nil) (t (cons (lambda-object-body (car objs)) (lambda-object-body-lst (cdr objs))))))
filter-lambda$-objectsfunction
(defun filter-lambda$-objects (lst) (cond ((endp lst) nil) ((lambda$-bodyp (lambda-object-body (car lst))) (cons (car lst) (filter-lambda$-objects (cdr lst)))) (t (filter-lambda$-objects (cdr lst)))))
collect-certain-lambda-objectsmutual-recursion
(mutual-recursion (defun collect-certain-lambda-objects (flg term wrld ans) (cond ((variablep term) ans) ((fquotep term) (let* ((evg (unquote term)) (lambda-objectp (and (consp evg) (eq (car evg) 'lambda))) (well-formedp (and lambda-objectp (well-formed-lambda-objectp evg wrld))) (collectp (case flg (:all lambda-objectp) (:well-formed well-formedp) (otherwise (and well-formedp (lambda$-bodyp (lambda-object-body evg)))))) (ans1 (if collectp (add-to-set-equal evg ans) ans))) (if well-formedp (let* ((guard (lambda-object-guard evg)) (body (lambda-object-body evg))) (collect-certain-lambda-objects flg guard wrld (collect-certain-lambda-objects flg body wrld ans1))) ans1))) ((throw-nonexec-error-p term :non-exec nil) ans) ((flambda-applicationp term) (collect-certain-lambda-objects flg (lambda-body (ffn-symb term)) wrld (collect-certain-lambda-objects-lst flg (fargs term) wrld ans))) (t (collect-certain-lambda-objects-lst flg (fargs term) wrld ans)))) (defun collect-certain-lambda-objects-lst (flg terms wrld ans) (cond ((endp terms) ans) (t (collect-certain-lambda-objects flg (car terms) wrld (collect-certain-lambda-objects-lst flg (cdr terms) wrld ans))))))
ancestral-lambda$s-by-caller1mutual-recursion
(mutual-recursion (defun ancestral-lambda$s-by-caller1 (caller guard body wrld alist) (cond ((or (global-val 'boot-strap-flg wrld) (hons-get caller (unquote (getpropc '*badge-prim-falist* 'const nil wrld))) (eq caller 'apply$) (eq caller 'ev$) (assoc-eq caller alist)) alist) (t (let* ((guard (or guard (getpropc caller 'guard *t* wrld))) (body (or body (getpropc caller 'unnormalized-body *nil* wrld))) (objs (collect-certain-lambda-objects :well-formed body wrld (collect-certain-lambda-objects :well-formed guard wrld nil))) (fns (all-fnnames1 nil guard (all-fnnames1 nil body (all-fnnames1 t (lambda-object-body-lst objs) (all-fnnames1 t (lambda-object-guard-lst objs) nil)))))) (ancestral-lambda$s-by-caller1-lst fns wrld (cons (cons caller (filter-lambda$-objects objs)) alist)))))) (defun ancestral-lambda$s-by-caller1-lst (callers wrld alist) (cond ((endp callers) alist) (t (ancestral-lambda$s-by-caller1-lst (cdr callers) wrld (ancestral-lambda$s-by-caller1 (car callers) nil nil wrld alist))))))
collect-non-empty-pairsfunction
(defun collect-non-empty-pairs (alist) (cond ((endp alist) nil) ((cdr (car alist)) (cons (car alist) (collect-non-empty-pairs (cdr alist)))) (t (collect-non-empty-pairs (cdr alist)))))
ancestral-lambda$s-by-callerfunction
(defun ancestral-lambda$s-by-caller (caller term wrld) (let ((alist (ancestral-lambda$s-by-caller1 caller *t* term wrld nil))) (collect-non-empty-pairs alist)))
strings-and-othersfunction
(defun strings-and-others (alist strings others) (cond ((endp alist) (mv strings others)) ((stringp (car (car alist))) (strings-and-others (cdr alist) (cons (car (car alist)) strings) others)) (t (strings-and-others (cdr alist) strings (cons (car (car alist)) others)))))
prohibition-of-loop$-and-lambda$-msgfunction
(defun prohibition-of-loop$-and-lambda$-msg (alist) (mv-let (strings others) (strings-and-others alist nil nil) (let ((i (cond ((null strings) (if (null (cdr others)) 0 1)) ((null others) 2) ((null (cdr others)) 3) (t 4)))) (msg "We prohibit certain events, including DEFCONST, DEFPKG, and ~ DEFMACRO, from being ancestrally dependent on loop$ and lambda$ ~ expressions. But at least one of these prohibited expressions ~ occurs in ~#0~[~&2 which is ancestral here~/each of ~&2 which are ~ ancestral here~/~*1~/~*1 and in ~&2 which is ancestral here~/~*1 ~ and in each of ~&2 which are ancestral here~]. See :DOC ~ prohibition-of-loop$-and-lambda$." i (list "" "~s*" "~s* and " "~s*, " strings) others))))
chk-macro-ancestors-cmpfunction
(defun chk-macro-ancestors-cmp (name tguard tbody local-p ctx wrld) (let ((non-apply$-primps-in-guard (collect-non-apply$-primps tguard wrld)) (non-apply$-primps-in-body (collect-non-apply$-primps tbody wrld)) (ancestral-lambda$s-in-guard (and (not (quotep tguard)) (ancestral-lambda$s-by-caller (if local-p "the guard of this event" "the guard of this locally defined macro") tguard wrld))) (ancestral-lambda$s-in-body (and (not (quotep tbody)) (ancestral-lambda$s-by-caller (if local-p "the body of this event" "the body of this locally defined macro") tbody wrld)))) (cond ((or non-apply$-primps-in-guard non-apply$-primps-in-body) (er-cmp ctx "All quoted function objects in :FN slots in the :guard and in ~ the body of a macro definition, such as in ~@0 for ~x1, must ~ be apply$ primitives. Apply$ cannot run user-defined ~ functions or ill-formed or untame lambda objects while ~ expanding macros. Because of logical considerations, ~ attachments (including DOPPELGANGER-APPLY$-USERFN) must not be ~ called in this context. See :DOC ignored-attachment. Thus it ~ is illegal to use the quoted function object~#2~[~/s~] ~ ~#3~[~&4 in the guard~/~&5 in the body~/~&4 in the guard and ~ ~&5 in the body~] of ~x1." (if local-p "the MACROLET binding" "the DEFMACRO event") name (union-equal non-apply$-primps-in-guard non-apply$-primps-in-body) (cond ((and non-apply$-primps-in-guard non-apply$-primps-in-body) 2) (non-apply$-primps-in-body 1) (t 0)) non-apply$-primps-in-guard non-apply$-primps-in-body)) ((or ancestral-lambda$s-in-guard ancestral-lambda$s-in-body) (er-cmp ctx "~@0" (prohibition-of-loop$-and-lambda$-msg (union-equal ancestral-lambda$s-in-guard ancestral-lambda$s-in-body)))) (t (value-cmp nil)))))
chk-macro-ancestorsfunction
(defun chk-macro-ancestors (name tguard tbody ctx wrld state) (cmp-to-error-triple (chk-macro-ancestors-cmp name tguard tbody nil ctx wrld)))
macrolet-expandfunction
(defun macrolet-expand (x lam ctx wrld state-vars) (let ((args (assert$ (and (true-listp lam) (= (length lam) 3) (eq (car lam) 'lambda)) (cadr lam))) (body (caddr lam))) (er-let*-cmp ((alist (bind-macro-args args x wrld state-vars))) (mv-let (erp expansion) (ev-w body alist wrld nil t nil nil nil) (cond (erp (er-cmp ctx "In the attempt to macroexpand the call ~x0 of a ~ macrolet-bound symbol, evaluation of the macro ~ body caused the error below.~|~%~@1" x expansion)) (t (value-cmp expansion)))))))
chk-local-def-return-last-tablefunction
(defun chk-local-def-return-last-table (names fletp wrld ctx) (cond ((first-assoc-eq names (table-alist 'return-last-table wrld)) (er-cmp ctx "It is illegal for ~@0 to bind a symbol that is given special ~ handling by ~x1. The ~@0-binding~#2~[ is~/s are~] thus illegal ~ for ~&2. See :DOC return-last-table." (if fletp "FLET" "MACROLET") 'return-last (intersection-eq names (strip-cars (table-alist 'return-last-table wrld))))) (t (value-cmp nil))))
fn-count-evg-max-valmacro
(defmacro fn-count-evg-max-val nil 200000)
cons-count-bounded-acfunction
(defun cons-count-bounded-ac (x i max) (declare (type (unsigned-byte 60) i max) (xargs :guard (<= i max) :measure (acl2-count x) :ruler-extenders :lambdas)) (the (unsigned-byte 60) (cond ((or (atom x) (>= i max)) i) (t (let ((i (cons-count-bounded-ac (car x) (1+f i) max))) (declare (type (unsigned-byte 60) i)) (cons-count-bounded-ac (cdr x) i max))))))
cons-count-boundedfunction
(defun cons-count-bounded (x) (the (unsigned-byte 60) (cons-count-bounded-ac x 0 (fn-count-evg-max-val))))
lambda-object-count-max-valmacro
(defmacro lambda-object-count-max-val nil 200000)
setq-hons-copy-lambda-object-culpritfunction
(defun setq-hons-copy-lambda-object-culprit (obj) (wormhole-eval 'hons-copy-lambda-object-wormhole '(lambda (whs) (set-wormhole-data whs obj)) nil))
hons-copy-lambda-object?function
(defun hons-copy-lambda-object? (obj) (let ((i (the (unsigned-byte 60) (cons-count-bounded-ac obj 0 (lambda-object-count-max-val))))) (cond ((>= i (lambda-object-count-max-val)) (prog2$ (setq-hons-copy-lambda-object-culprit obj) (mv t (msg "You have created an excessively large quoted lambda object, ~ namely~%~X01. See :DOC explain-giant-lambda-object." obj (evisc-tuple 6 10 nil nil))))) (t (mv nil (hons-copy obj))))))
read-hons-copy-lambda-object-culpritfunction
(defun read-hons-copy-lambda-object-culprit (state) (read-acl2-oracle state))
stobjs-out-sym-pairfunction
(defun stobjs-out-sym-pair (n) (or (cdr (assoc n '((0 :stobjs-out-0 . :stobjs-out-0) (1 :stobjs-out-1 . :stobjs-out-1) (2 :stobjs-out-2 . :stobjs-out-2) (3 :stobjs-out-3 . :stobjs-out-3) (4 :stobjs-out-4 . :stobjs-out-4) (5 :stobjs-out-5 . :stobjs-out-5) (6 :stobjs-out-6 . :stobjs-out-6) (7 :stobjs-out-7 . :stobjs-out-7) (8 :stobjs-out-8 . :stobjs-out-8) (9 :stobjs-out-9 . :stobjs-out-9)))) (let ((sym (packn-pos (list :stobjs-out- n) :keyword))) (cons sym sym))))
replace-cdrs-eqfunction
(defun replace-cdrs-eq (sym val alist) (declare (xargs :guard (and (symbolp sym) (alistp alist)))) (cond ((endp alist) nil) ((eq (cdar alist) sym) (acons (caar alist) val (replace-cdrs-eq sym val (cdr alist)))) (t (cons (car alist) (replace-cdrs-eq sym val (cdr alist))))))
remove-from-bindingfunction
(defun remove-from-binding (sym val bindings) (let ((bindings (remove-assoc-eq sym bindings))) (if (rassoc-eq sym bindings) (replace-cdrs-eq sym val bindings) bindings)))
top-level-bindings-pfunction
(defun top-level-bindings-p (bindings) (cond ((endp bindings) nil) ((eq (caar bindings) :stobjs-out) t) ((keywordp (caar bindings)) (top-level-bindings-p (cdr bindings))) (t nil)))
lambda-to-letfunction
(defun lambda-to-let (x) (declare (xargs :guard (and (consp x) (not (symbolp (car x)))))) (cond ((or (not (consp (car x))) (not (eq (caar x) 'lambda))) (mv (msg "Function (and macro) applications in ACL2 must begin with ~ a symbol or LAMBDA expression. ~x0 is not of this form." x) nil)) ((or (not (true-listp (car x))) (not (>= (length (car x)) 3)) (not (true-listp (cadr (car x))))) (mv (msg "Illegal LAMBDA expression: ~x0." x) nil)) ((not (= (length (cadr (car x))) (len (cdr x)))) (mv (msg "The LAMBDA expression ~x0 takes ~#1~[no arguments~/1 ~ argument~/~x2 arguments~] and is being passed ~#3~[no ~ arguments~/1 argument~/~x4 arguments~]. Note: this error ~ occurred in the context ~x5." (car x) (zero-one-or-more (length (cadr (car x)))) (length (cadr (car x))) (zero-one-or-more (len (cdr x))) (len (cdr x)) x) nil)) (t (mv nil (list* 'let (listlis (cadr (car x)) (cdr x)) (cddr (car x)))))))
df-type-pmutual-recursion
(mutual-recursion (defun df-type-p (typ) (declare (xargs :guard t :measure (acl2-count typ))) (cond ((consp typ) (case (car typ) (and (df-type-listp-and (cdr typ))) (or (and (consp (cdr typ)) (let ((val (df-type-p (cadr typ)))) (if (eq val :unknown) :unknown (df-type-listp-or (cddr typ) val))))) (double-float t) (real :unknown) (t nil))) ((eq typ 'double-float) t) ((eq typ 'real) :unknown) ((eq typ 'number) :unknown) (t nil))) (defun df-type-listp-and (lst) (declare (xargs :guard t :measure (acl2-count lst))) (cond ((atom lst) :unknown) (t (let ((x (df-type-p (car lst)))) (cond ((eq x t) t) ((eq x nil) nil) (t (df-type-listp-and (cdr lst)))))))) (defun df-type-listp-or (lst val) (declare (xargs :guard t :measure (acl2-count lst))) (cond ((atom lst) val) ((eq (df-type-p (car lst)) val) (df-type-listp-or (cdr lst) val)) (t :unknown))))
union-eq-safefunction
(defun union-eq-safe (x lst) (declare (xargs :guard (true-listp lst))) (cond ((atom x) lst) (t (union-eq-safe (cdr x) (if (and (symbolp (car x)) (not (member-eq (car x) lst))) (cons (car x) lst) lst)))))
extend-known-dfs-with-declared-df-typesfunction
(defun extend-known-dfs-with-declared-df-types (edcls known-dfs) (declare (xargs :guard (and (symbol-listp known-dfs) (true-list-listp edcls)))) (cond ((endp edcls) known-dfs) ((and (eq (car (car edcls)) 'type) (eq (df-type-p (cadr (car edcls))) t)) (extend-known-dfs-with-declared-df-types (cdr edcls) (union-eq-safe (cddr (car edcls)) known-dfs))) (t (extend-known-dfs-with-declared-df-types (cdr edcls) known-dfs))))
returns-df?mutual-recursion
(mutual-recursion (defun returns-df? (form known-stobjs known-dfs wrld) (declare (xargs :guard (and (symbol-listp known-stobjs) (symbol-listp known-dfs) (plist-worldp wrld)))) (cond ((or (keywordp form) (eq (legal-variable-or-constant-namep form) 'constant)) nil) ((symbolp form) (cond ((eq known-dfs '?) (if (stobjp form known-stobjs wrld) nil :unknown)) ((member-eq form known-dfs) t) (t nil))) ((atom form) nil) ((not (symbolp (car form))) (mv-let (msg val) (lambda-to-let form) (cond (msg :unknown) (t (returns-df? val known-stobjs known-dfs wrld))))) ((eq (car form) 'quote) nil) ((not (true-listp form)) :unknown) ((eq (car form) 'the) (let ((b (df-type-p (cadr form)))) (cond ((eq b t) '(:df)) ((eq b nil) '(nil)) (t (returns-df? (caddr form) known-stobjs known-dfs wrld))))) ((eq (car form) 'return-last) (returns-df? (car (last form)) known-stobjs known-dfs wrld)) ((eq (car form) 'if) (let ((r (returns-df? (caddr form) known-stobjs known-dfs wrld))) (cond ((eq r :unknown) (returns-df? (cadddr form) known-stobjs known-dfs wrld)) (t r)))) ((eq (car form) 'let) (cond ((and (<= 3 (length form)) (doublet-listp (cadr form))) (let ((vars (strip-cars (cadr form)))) (cond ((symbol-listp vars) (let* ((dcls (butlast (cddr form) 1)) (df-vars (and (true-list-listp dcls) (extend-known-dfs-with-declared-df-types dcls (set-difference-eq known-dfs vars)))) (new-known-dfs (bindings-known-dfs (cadr form) known-stobjs known-dfs wrld df-vars))) (cond ((eq new-known-dfs :unknown) :unknown) (t (returns-df? (car (last form)) known-stobjs new-known-dfs wrld))))) (t :unknown)))) (t :unknown))) ((eq (car form) 'let*) (mv-let (erp val) (macroexpand1-cmp form 'any-ctx wrld (default-state-vars nil)) (if erp :unknown (returns-df? val known-stobjs known-dfs wrld)))) ((and (getpropc (car form) 'macro-body nil wrld) (not (global-val 'boot-strap-flg wrld))) (mv-let (erp val) (macroexpand1*-cmp form 'any-ctx wrld (default-state-vars nil)) (if (or erp (equal form val)) :unknown (returns-df? val known-stobjs known-dfs wrld)))) (t (let ((stobjs-out (and (not (member-eq (car form) *stobjs-out-invalid*)) (getpropc (car form) 'stobjs-out nil wrld)))) (cond ((and (consp stobjs-out) (null (cdr stobjs-out))) (cond ((eq (car stobjs-out) :df) t) ((eq (car stobjs-out) nil) nil) ((stobjp (car stobjs-out) known-stobjs wrld) nil) (t :unknown))) (t :unknown)))))) (defun bindings-known-dfs (bindings known-stobjs known-dfs wrld df-vars) (declare (xargs :guard (and (doublet-listp bindings) (symbol-listp known-stobjs) (symbol-listp known-dfs) (plist-worldp wrld) (symbol-listp df-vars)))) (cond ((endp bindings) df-vars) (t (cond ((member-eq (caar bindings) df-vars) (bindings-known-dfs (cdr bindings) known-stobjs known-dfs wrld df-vars)) (t (let ((x (returns-df? (cadar bindings) known-stobjs known-dfs wrld))) (cond ((eq x :unknown) :unknown) (t (let ((rec (bindings-known-dfs (cdr bindings) known-stobjs known-dfs wrld df-vars))) (cond ((eq rec :unknown) :unknown) ((eq x :df) (cons (caar bindings) rec)) (t rec))))))))))))
compute-stobj-flags-df?function
(defun compute-stobj-flags-df? (lst known-stobjs known-dfs w) (cond ((endp lst) nil) ((stobjp (car lst) known-stobjs w) (cons (car lst) (compute-stobj-flags-df? (cdr lst) known-stobjs known-dfs w))) (t (let ((r (returns-df? (car lst) known-stobjs known-dfs w))) (cons (cond ((eq r t) :df) ((eq r nil) nil) (t :df?)) (compute-stobj-flags-df? (cdr lst) known-stobjs known-dfs w))))))
compute-stobj-flags-df?-doubletsfunction
(defun compute-stobj-flags-df?-doublets (doublets declared-known-dfs known-stobjs known-dfs w) (declare (xargs :guard (and (doublet-listp doublets) (symbol-listp declared-known-dfs) (symbol-listp known-stobjs) (symbol-listp known-dfs) (plist-worldp w)))) (cond ((endp doublets) nil) ((member-eq (caar doublets) declared-known-dfs) (cons :df (compute-stobj-flags-df?-doublets (cdr doublets) declared-known-dfs known-stobjs known-dfs w))) ((stobjp (caar doublets) known-stobjs w) (cons (caar doublets) (compute-stobj-flags-df?-doublets (cdr doublets) declared-known-dfs known-stobjs known-dfs w))) (t (let ((r (returns-df? (cadar doublets) known-stobjs known-dfs w))) (cons (cond ((eq r t) :df) ((eq r nil) nil) (t :df?)) (compute-stobj-flags-df?-doublets (cdr doublets) declared-known-dfs known-stobjs known-dfs w))))))
set-difference-assoc-eqfunction
(defun set-difference-assoc-eq (lst alist) (declare (xargs :guard (and (true-listp lst) (alistp alist) (or (symbol-listp lst) (symbol-alistp alist))))) (cond ((endp lst) nil) ((assoc-eq (car lst) alist) (set-difference-assoc-eq (cdr lst) alist)) (t (cons (car lst) (set-difference-assoc-eq (cdr lst) alist)))))
ec-call-boolean-listp-checkfunction
(defun ec-call-boolean-listp-check (stobjs lst) (declare (xargs :guard (true-listp stobjs))) (cond ((endp stobjs) (null lst)) ((atom lst) nil) (t (and (eq (eq :df (car stobjs)) (car lst)) (ec-call-boolean-listp-check (cdr stobjs) (cdr lst))))))
plausible-actual-stobjs-out-pfunction
(defun plausible-actual-stobjs-out-p (stobjs-out lst known-stobjs wrld) (declare (xargs :guard (and (symbol-listp stobjs-out) (true-listp lst) (true-listp known-stobjs) wrld (plist-worldp wrld)))) (cond ((endp stobjs-out) (null lst)) ((endp lst) nil) ((or (eq (car stobjs-out) (car lst)) (eq (car lst) nil) (eq (car lst) :df) (and (car stobjs-out) (not (eq (car stobjs-out) :df)) (stobjp (car lst) known-stobjs wrld) (congruent-stobjsp (car stobjs-out) (car lst) wrld))) (plausible-actual-stobjs-out-p (cdr stobjs-out) (cdr lst) known-stobjs wrld)) (t nil)))
remove-df?-elementsfunction
(defun remove-df?-elements (lst stobjs-out) (declare (xargs :guard (and (symbol-listp lst) (symbol-listp stobjs-out)))) (cond ((endp lst) nil) (t (cons (if (eq (car lst) :df?) (if (eq (car stobjs-out) :df) :df nil) (car lst)) (remove-df?-elements (cdr lst) (cdr stobjs-out))))))
stobjs-out-for-formfunction
(defun stobjs-out-for-form (form known-stobjs known-dfs wrld state-vars stobjs-out) (cond ((or (keywordp form) (eq (legal-variable-or-constant-namep form) 'constant)) '(nil)) ((symbolp form) (cond ((member-eq form known-dfs) '(:df)) ((stobjp form known-stobjs wrld) (list form)) (t '(nil)))) ((atom form) '(nil)) ((not (symbolp (car form))) (mv-let (msg val) (lambda-to-let form) (if (null msg) (stobjs-out-for-form val known-stobjs known-dfs wrld state-vars stobjs-out) stobjs-out))) ((eq (car form) 'quote) '(nil)) ((not (true-listp form)) stobjs-out) ((eq (car form) 'the) (let ((b (df-type-p (cadr form)))) (cond ((eq b t) '(:df)) ((eq b nil) '(nil)) (t (stobjs-out-for-form (caddr form) known-stobjs known-dfs wrld state-vars stobjs-out))))) ((eq (car form) 'return-last) (stobjs-out-for-form (car (last form)) known-stobjs known-dfs wrld state-vars stobjs-out)) ((eq (car form) 'if) (or (stobjs-out-for-form (caddr form) known-stobjs known-dfs wrld state-vars nil) (stobjs-out-for-form (cadddr form) known-stobjs known-dfs wrld state-vars stobjs-out))) ((eq (car form) 'let) (or (and (<= 3 (length form)) (doublet-listp (cadr form)) (let ((vars (strip-cars (cadr form)))) (and (symbol-listp vars) (let* ((dcls (butlast (cddr form) 1)) (df-vars (and (true-list-listp dcls) (extend-known-dfs-with-declared-df-types dcls (set-difference-eq known-dfs vars)))) (new-known-dfs (bindings-known-dfs (cadr form) known-stobjs known-dfs wrld df-vars))) (cond ((eq new-known-dfs :unknown) nil) (t (stobjs-out-for-form (car (last form)) known-stobjs new-known-dfs wrld state-vars stobjs-out))))))) stobjs-out)) ((eq (car form) 'let*) (mv-let (erp val) (macroexpand1-cmp form 'stobjs-out-for-form wrld state-vars) (if erp stobjs-out (stobjs-out-for-form val known-stobjs known-dfs wrld state-vars stobjs-out)))) ((eq (car form) 'mv) (let ((lst (compute-stobj-flags-df? (cdr form) known-stobjs known-dfs wrld))) (if (member-eq :df? lst) (remove-df?-elements lst stobjs-out) lst))) ((eq (car form) 'mv-let) (or (let ((vars (and (consp (cdr form)) (cadr form)))) (and vars (symbol-listp vars) (let ((stobjs-out-expr (stobjs-out-for-form (caddr form) known-stobjs known-dfs wrld state-vars nil))) (and stobjs-out-expr (= (length vars) (length stobjs-out-expr)) (let* ((dcls (butlast (cdddr form) 1)) (df-vars (and (true-list-listp dcls) (extend-known-dfs-with-declared-df-types dcls (append (collect-by-position '(:df) stobjs-out-expr vars) (set-difference-eq known-dfs vars)))))) (stobjs-out-for-form (car (last form)) known-stobjs df-vars wrld state-vars stobjs-out)))))) stobjs-out)) ((or (eq (car form) 'non-exec) (eq (getpropc (car form) 'non-executablep nil wrld) t)) stobjs-out) ((getpropc (car form) 'macro-body nil wrld) (mv-let (msg val) (macroexpand1-cmp form 'stobjs-out-for-form wrld state-vars) (cond (msg stobjs-out) (t (stobjs-out-for-form val known-stobjs known-dfs wrld state-vars stobjs-out))))) (t (or (let ((stobjs-out (and (not (member-eq (car form) *stobjs-out-invalid*)) (actual-stobjs-out (car form) (cdr form) wrld)))) (and (or (eq known-stobjs t) (subsetp-eq (collect-non-nil-df stobjs-out) known-stobjs)) (no-duplicatesp-eq stobjs-out) (plausible-actual-stobjs-out-p (getpropc (car form) 'stobjs-out nil wrld) stobjs-out known-stobjs wrld) stobjs-out)) stobjs-out))))
compatible-stobjs-out-pfunction
(defun compatible-stobjs-out-p (stobjs-out bound-vars known-stobjs bound-known-dfs wrld) (cond ((endp bound-vars) (null stobjs-out)) ((endp stobjs-out) nil) ((and (member-eq (car bound-vars) bound-known-dfs) (not (eq (car stobjs-out) :df))) nil) ((or (eq (car stobjs-out) (car bound-vars)) (and (not (and (car stobjs-out) (not (eq (car stobjs-out) :df)))) (not (stobjp (car bound-vars) known-stobjs wrld)))) (compatible-stobjs-out-p (cdr stobjs-out) (cdr bound-vars) known-stobjs bound-known-dfs wrld)) (t nil)))
adjust-known-dfs-for-var-tuplesfunction
(defun adjust-known-dfs-for-var-tuples (twvts known-dfs) (cond ((endp twvts) known-dfs) (t (adjust-known-dfs-for-var-tuples (cdr twvts) (let* ((tuple (car twvts)) (var (car tuple))) (cond ((eq (cadr tuple) 'double-float) (add-to-set-eq var known-dfs)) ((member-eq var known-dfs) (remove1-eq var known-dfs)) (t known-dfs)))))))
bad-dfs-in-outfunction
(defun bad-dfs-in-out (arg2 arg3 wrld) (let* ((fn (if (function-symbolp (car arg3) wrld) (car arg3) (corresponding-inline-fn (car arg3) wrld))) (dfs-in (cadr (cadr arg2))) (dfs-out (cadr (caddr arg2))) (stobjs-in (stobjs-in fn wrld)) (stobjs-out (stobjs-out fn wrld)) (bad-in (if (null dfs-in) (member-eq :df stobjs-in) (not (ec-call-boolean-listp-check stobjs-in dfs-in)))) (bad-out (if (null dfs-out) (member-eq :df stobjs-out) (not (ec-call-boolean-listp-check stobjs-out dfs-out))))) (and (or bad-in bad-out) (cons bad-in bad-out))))
remove-double-float-types-1function
(defun remove-double-float-types-1 (edcls) (declare (xargs :guard (true-list-listp edcls))) (cond ((endp edcls) nil) (t (let ((rest (remove-double-float-types-1 (cdr edcls)))) (cond ((eq (car (car edcls)) 'type) (let ((tmp (df-type-p (cadr (car edcls))))) (cond ((eq tmp nil) (cons-with-hint (car edcls) rest edcls)) (t rest)))) (t (cons-with-hint (car edcls) rest edcls)))))))
remove-double-float-typesfunction
(defun remove-double-float-types (edcls) (declare (xargs :guard (true-list-listp edcls))) (remove-double-float-types-1 edcls))
double-float-types-pfunction
(defun double-float-types-p (dcl) (not (equal (remove-double-float-types (cdr dcl)) (cdr dcl))))
translate11-local-defmutual-recursion
(mutual-recursion (defun translate11-local-def (form name bound-vars args edcls body new-stobjs-out stobjs-out bindings known-stobjs flet-alist ctx wrld state-vars) (let* ((fletp (eq (car form) 'flet)) (typ (if fletp "FLET" "MACROLET")) (a-typ (if fletp "an FLET" "a MACROLET")) (cap-a-typ (if fletp "An FLET" "A MACROLET"))) (cond ((member-eq name '(flet macrolet with-local-stobj with-global-stobj throw-raw-ev-fncall untrace$-fn-general)) (trans-er+ form ctx "~@0 form has attempted to bind ~x1. However, this ~ symbol must not be ~@2-bound." cap-a-typ name typ)) ((getpropc name 'predefined nil wrld) (trans-er+ form ctx "~@0 form has attempted to bind ~x1, which is predefined ~ in ACL2 hence may not be ~@2-bound." cap-a-typ name typ)) (t (trans-er-let* ((tdcls (translate11-lst (translate-dcl-lst edcls wrld) nil nil bindings known-stobjs nil (if fletp "in a DECLARE form in an FLET binding" "in a DECLARE form in a MACROLET binding") flet-alist form ctx wrld state-vars)) (tbody (translate11 body nil new-stobjs-out (if (or (not fletp) (eq stobjs-out t)) bindings (translate-bind new-stobjs-out new-stobjs-out bindings)) (if fletp known-stobjs nil) nil flet-alist form ctx wrld state-vars))) (let ((used-vars (union-eq (all-vars tbody) (all-vars1-lst tdcls nil))) (ignore-vars (ignore-vars edcls)) (ignorable-vars (ignorable-vars edcls)) (stobjs-out (translate-deref new-stobjs-out bindings))) (cond ((and (not (eq stobjs-out t)) (not (consp stobjs-out))) (trans-er+ form ctx "We are unable to determine the output signature for an ~ FLET-binding of ~x0. You may be able to remedy the ~ situation by rearranging the order of the branches of ~ an IF and/or rearranging the order of the presentation ~ of a clique of mutually recursive functions. If you ~ believe you have found an example on which you believe ~ ACL2 should be able to complete this translation, ~ please send such an example to the ACL2 implementors." name)) ((intersectp-eq used-vars ignore-vars) (trans-er+ form ctx "Contrary to the declaration that ~#0~[it is~/they ~ are~] IGNOREd, the variable~#0~[ ~&0 is~/s ~&0 are~] ~ used in the body of ~@1-binding of ~x2, whose formal ~ parameter list includes ~&3." (intersection-eq used-vars ignore-vars) a-typ name bound-vars)) (t (let* ((diff (set-difference-eq bound-vars (union-eq used-vars (union-eq ignorable-vars ignore-vars)))) (ignore-ok (if (null diff) t (cdr (assoc-eq :ignore-ok (table-alist 'acl2-defaults-table wrld))))) (ignore-err-string "The variable~#0~[ ~&0 is~/s ~&0 are~] not used in the ~ body of ~@1-binding of ~x2 that binds ~&3. But ~&0 ~ ~#0~[is~/are~] not declared IGNOREd or IGNORABLE. See ~ :DOC set-ignore-ok.") (guardian (dcl-guardian tdcls))) (cond ((null ignore-ok) (trans-er+ form ctx ignore-err-string diff a-typ name bound-vars)) (t (prog2$ (cond ((eq ignore-ok :warn) (warning$-cw1 ctx "Ignored-variables" ignore-err-string diff a-typ name bound-vars)) (t nil)) (mv-let (erp val) (chk-macro-ancestors-cmp name guardian tbody t ctx wrld) (cond (erp (trans-er+ form ctx "~@0" val)) (t (let* ((tbody (cond (tdcls (cond ((equal guardian *t*) tbody) (t (prog2$-call guardian tbody)))) (t tbody))) (body-vars (all-vars tbody)) (extra-body-vars (set-difference-eq body-vars bound-vars))) (cond (extra-body-vars (trans-er+ form ctx "The variable~#0~[ ~&0 is~/s ~&0 are~] ~ used in the body of ~@1-binding of ~x2 ~ that only binds ~&3. In ACL2, every ~ variable occurring in the body of an FLET ~ or MACROLET binding, (sym vars body), ~ must be in vars, i.e., a formal parameter ~ of that binding." extra-body-vars a-typ name bound-vars)) (t (trans-value (list* name (make-lambda args tbody) (if fletp stobjs-out :macrolet)) (if (or (eq new-stobjs-out t) (not fletp)) bindings (remove-assoc-eq new-stobjs-out bindings))))))))))))))))))))) (defun translate11-flet-alist-rec (form fives stobjs-out bindings known-stobjs flet-alist ctx wrld state-vars) (cond ((endp fives) (trans-value flet-alist)) (t (trans-er-let* ((flet-entry (translate11-flet-alist1 form (car fives) stobjs-out bindings known-stobjs flet-alist ctx wrld state-vars)) (flet-entries (translate11-flet-alist-rec form (cdr fives) stobjs-out bindings known-stobjs flet-alist ctx wrld state-vars))) (trans-value (cons flet-entry flet-entries)))))) (defun translate11-flet-alist (form fives stobjs-out bindings known-stobjs flet-alist ctx wrld state-vars) (mv-let (altp state-vars1) (if (access state-vars state-vars :do-expressionp) (mv t (change state-vars state-vars :do-expressionp nil)) (mv nil state-vars)) (let ((bindings0 bindings)) (mv-let (erp1 flet-alist bindings) (translate11-flet-alist-rec form fives stobjs-out bindings known-stobjs flet-alist ctx wrld state-vars1) (cond ((and erp1 altp) (mv-let (erp2 flet-alist2 bindings2) (translate11-flet-alist-rec form fives t bindings0 known-stobjs flet-alist ctx wrld state-vars) (declare (ignore bindings2 flet-alist2)) (cond ((null erp2) (trans-er ctx "ACL2 has encountered the body of a definition bound ~ by ~x0 that is illegal, even though it would be ~ legal in a DO loop$ body rather than in a local ~ definition. Here is the resulting error message:~| ~ ~@1" 'flet flet-alist)) (t (mv erp1 flet-alist bindings))))) (t (mv erp1 flet-alist bindings))))))) (defun translate11-flet-alist1 (form five stobjs-out bindings known-stobjs flet-alist ctx wrld state-vars) (let* ((name (car five)) (bound-vars (cadr five)) (edcls (fourth five)) (body (fifth five)) (new-stobjs-out (if (eq stobjs-out t) t (genvar name (symbol-name name) nil (strip-cars bindings))))) (translate11-local-def form name bound-vars bound-vars edcls body new-stobjs-out stobjs-out bindings known-stobjs flet-alist ctx wrld state-vars))) (defun translate11-flet (x stobjs-out bindings known-stobjs flet-alist ctx wrld state-vars) (cond ((< (length x) 3) (trans-er ctx "An FLET form must have the form (flet bindings body) or (flet ~ bindings declare-form1 ... declare-formk body), but ~x0 does ~ not have this form. See :DOC flet." x)) (t (let ((defs (cadr x)) (declare-form-list (butlast (cddr x) 1)) (body (car (last x)))) (mv-let (erp fives) (chk-defuns-tuples-cmp defs t ctx wrld) (let ((names (and (not erp) (strip-cars fives)))) (mv-let (erp msg) (if erp (mv erp fives) (er-progn-cmp (chk-no-duplicate-defuns-cmp names ctx) (chk-local-def-declare-form-list t names declare-form-list ctx) (chk-local-def-return-last-table names t wrld ctx))) (cond (erp (trans-er ctx "~@0~|~%The above error indicates a problem with the ~ form ~x1." msg x)) (t (trans-er-let* ((flet-alist (translate11-flet-alist x fives stobjs-out bindings known-stobjs flet-alist ctx wrld state-vars))) (translate11 body nil stobjs-out bindings known-stobjs nil flet-alist x ctx wrld state-vars))))))))))) (defun translate11-macrolet-alist-rec (defs stobjs-out bindings known-stobjs flet-alist form ctx wrld state-vars) (cond ((endp defs) (trans-value flet-alist)) (t (trans-er-let* ((entry (translate11-macrolet-alist1 (car defs) stobjs-out bindings known-stobjs flet-alist form ctx wrld state-vars)) (entries (translate11-macrolet-alist-rec (cdr defs) stobjs-out bindings known-stobjs flet-alist form ctx wrld state-vars))) (trans-value (cons entry entries)))))) (defun translate11-macrolet-alist (defs stobjs-out bindings known-stobjs flet-alist form ctx wrld state-vars) (mv-let (altp state-vars1) (if (access state-vars state-vars :do-expressionp) (mv t (change state-vars state-vars :do-expressionp nil)) (mv nil state-vars)) (let ((bindings0 bindings)) (mv-let (erp1 flet-alist bindings) (translate11-macrolet-alist-rec defs stobjs-out bindings known-stobjs flet-alist form ctx wrld state-vars1) (cond ((and erp1 altp) (mv-let (erp2 flet-alist2 bindings2) (translate11-macrolet-alist-rec defs t bindings0 known-stobjs flet-alist form ctx wrld state-vars) (declare (ignore bindings2 flet-alist2)) (cond ((null erp2) (trans-er ctx "ACL2 has encountered the body of a definition bound ~ by ~x0 that is illegal, even though it would be ~ legal in a DO loop$ body rather than in a local ~ definition. Here is the resulting error message:~| ~ ~@1" 'macrolet flet-alist)) (t (mv erp1 flet-alist bindings))))) (t (mv erp1 flet-alist bindings))))))) (defun translate11-macrolet-alist1 (def stobjs-out bindings known-stobjs flet-alist form ctx wrld state-vars) (mv-let (erp val) (chk-acceptable-defmacro-cmp def t ctx wrld state-vars) (cond (erp (trans-er ctx "~@0" val)) (t (let ((name (car val)) (bound-vars (macro-vars (cadr val))) (edcls (caddr val)) (body (cadddr val))) (translate11-local-def form name bound-vars (cadr val) edcls body '(nil) stobjs-out bindings known-stobjs flet-alist ctx wrld (change state-vars state-vars :in-macrolet-def name))))))) (defun translate11-macrolet (x stobjs-out bindings known-stobjs flet-alist ctx wrld state-vars) (cond ((< (length x) 3) (trans-er ctx "A MACROLET form must have the form (macrolet bindings body) or ~ (macrolet bindings declare-form1 ... declare-formk body), but ~ ~x0 does not have this form. See :DOC flet." x)) ((not (symbol-alistp (cadr x))) (trans-er ctx "A MACROLET form must have the form (macrolet bindings ...) ~ where bindings is of the form ((m1 ...) ... (mk ...)) and each ~ mi is a symbol, but ~x0 does not have this form. See :DOC ~ flet." x)) (t (let* ((defs (cadr x)) (names (strip-cars defs)) (declare-form-list (butlast (cddr x) 1)) (body (car (last x)))) (mv-let (erp msg) (er-progn-cmp (chk-no-duplicate-defuns-cmp names ctx) (chk-local-def-declare-form-list nil names declare-form-list ctx) (chk-local-def-return-last-table names nil wrld ctx)) (cond (erp (trans-er ctx "~@0~|~%The above error indicates a problem with the ~ form ~x1." msg x)) (t (trans-er-let* ((flet-alist (translate11-macrolet-alist defs stobjs-out bindings known-stobjs flet-alist x ctx wrld state-vars))) (translate11 body nil stobjs-out bindings known-stobjs nil flet-alist x ctx wrld state-vars))))))))) (defun translate-stobj-calls (calls creators accp bindings known-stobjs known-dfs flet-alist cform ctx wrld state-vars) (cond ((endp calls) (trans-value nil)) (t (trans-er-let* ((rest (translate-stobj-calls (cdr calls) (cdr creators) accp bindings known-stobjs known-dfs flet-alist cform ctx wrld state-vars))) (let ((call (car calls))) (cond ((and accp (car creators)) (assert$ (and (= (length call) 4) (unquoted-symbol (cadr call))) (trans-value (cons call rest)))) ((= (length call) (if accp 3 4)) (trans-er-let* ((index (translate11 (cadr call) nil '(nil) bindings known-stobjs known-dfs flet-alist cform ctx wrld state-vars))) (trans-value (cons (list* (car call) index (cddr call)) rest)))) (t (trans-value (cons call rest))))))))) (defun translate11-let (x tbody0 targs stobjs-out bindings known-stobjs known-dfs flet-alist ctx wrld state-vars) (cond ((not (and (>= (length x) 3) (doublet-listp (cadr x)))) (trans-er ctx "The proper form of a let is (let bindings dcl ... dcl body), ~ where bindings has the form ((v1 term) ... (vn term)) and the ~ vi are distinct variables, not constants, and do not begin ~ with an asterisk, but ~x0 does not have this form." x)) ((not (arglistp (strip-cars (cadr x)))) (mv-let (culprit explan) (find-first-bad-arg (strip-cars (cadr x))) (trans-er ctx "The form ~x0 is an improper let expression because it ~ attempts to bind ~x1, which ~@2." x culprit explan))) (t (let* ((bound-vars (strip-cars (cadr x))) (multiple-bindings-p (consp (cdr bound-vars))) (stobj-flags (and (not (eq stobjs-out t)) (compute-stobj-flags bound-vars known-stobjs nil wrld))) (stobjs-bound (and stobj-flags (collect-non-x nil stobj-flags))) (do-expressionp (access state-vars state-vars :do-expressionp)) (with-vars (and do-expressionp (access do-expressionp do-expressionp :with-vars)))) (cond ((and stobj-flags multiple-bindings-p (null tbody0) (non-trivial-stobj-binding stobj-flags (cadr x))) (trans-er ctx "A single-threaded object name, such as ~x0, may be ~ LET-bound to other than itself only when it is the only ~ binding in the LET, but ~x1 binds more than one variable." (non-trivial-stobj-binding stobj-flags (cadr x)) x)) ((intersectp-eq bound-vars with-vars) (trans-er+ x ctx "In a DO loop$ expression, variables bound in WITH ~ clauses, such as ~&0, may not be LET-bound in the loop$ ~ body or FINALLY clause (except in certain places such as ~ the right-hand side of a SETQ or MV-SETQ call or the ~ argument of a RETURN call). See :DOC do-loop$." (intersection-eq bound-vars with-vars) (cons 'progn (strip-cars *cltl-to-ersatz-fns*)))) ((and stobjs-bound do-expressionp) (trans-er+ x ctx "Single-threaded object names, such as ~&0, may not be ~ LET-bound in a DO loop body or FINALLY clause. See :DOC ~ do-loop$." (collect-non-x nil stobj-flags))) (t (mv-let (erp edcls) (collect-declarations-cmp (butlast (cddr x) 1) bound-vars 'let ctx wrld) (cond (erp (mv erp edcls bindings)) (t (mv-let (erp value-forms bindings known-dfs-for-body) (let ((known-dfs-for-body0 (extend-known-dfs-with-declared-df-types edcls (set-difference-assoc-eq known-dfs (cadr x))))) (cond (targs (assert$ tbody0 (mv nil targs bindings known-dfs-for-body0))) ((and stobjs-bound (not multiple-bindings-p)) (mv-let (erp val bindings) (translate11 (cadr (car (cadr x))) nil (list (car bound-vars)) bindings known-stobjs known-dfs flet-alist x ctx wrld state-vars) (cond (erp (mv erp val bindings known-dfs-for-body0)) (t (mv nil (list val) bindings known-dfs-for-body0))))) ((eq stobjs-out t) (mv-let (erp value-forms bindings) (translate11-lst (strip-cadrs (cadr x)) nil t bindings known-stobjs known-dfs "in a LET binding (or LAMBDA ~ application)" flet-alist x ctx wrld state-vars) (mv erp value-forms bindings known-dfs-for-body0))) (t (let ((stobjs-out-df? (compute-stobj-flags-df?-doublets (cadr x) known-dfs-for-body0 known-stobjs known-dfs wrld))) (mv-let (erp args bindings returned-stobjs-out) (translate11-lst/stobjs-out (strip-cadrs (cadr x)) nil stobjs-out-df? bindings known-stobjs known-dfs "in a LET binding (or LAMBDA application)" flet-alist x ctx wrld state-vars) (cond (erp (mv erp args bindings known-dfs-for-body0)) (t (mv nil args bindings (union-eq (collect-by-position '(:df) returned-stobjs-out (strip-cars (cadr x))) known-dfs-for-body0))))))))) (cond (erp (mv erp value-forms bindings)) (t (trans-er-let* ((tbody (if tbody0 (trans-value tbody0) (translate11 (car (last x)) nil stobjs-out bindings known-stobjs known-dfs-for-body flet-alist x ctx wrld state-vars))) (tdcls (translate11-lst (translate-dcl-lst edcls wrld) nil (if (eq stobjs-out t) t nil) bindings known-stobjs known-dfs-for-body "in a DECLARE form in a LET (or LAMBDA)" flet-alist x ctx wrld state-vars))) (let ((used-vars (union-eq (all-vars tbody) (all-vars1-lst tdcls nil))) (ignore-vars (ignore-vars edcls)) (ignorable-vars (ignorable-vars edcls)) (stobjs-out (translate-deref stobjs-out bindings))) (cond ((and stobjs-bound (not (consp stobjs-out))) (unknown-binding-msg-er x ctx stobjs-bound "a LET" "the LET" "the LET")) ((and (null tbody0) stobjs-bound (not multiple-bindings-p) (not (eq (caar (cadr x)) (cadar (cadr x)))) (assert$ (null (cdr stobjs-bound)) (not (member-eq (car stobjs-bound) stobjs-out)))) (let ((stobjs-returned (collect-non-nil-df stobjs-out))) (trans-er+ x ctx "The single-threaded object ~x0 has been ~ bound in a LET. It is a requirement ~ that this object be among the outputs of ~ the LET, but it is not. The LET returns ~ ~#1~[no single-threaded objects~/the ~ single-threaded object ~&2~/the ~ single-threaded objects ~&2~]." (car stobjs-bound) (zero-one-or-more stobjs-returned) stobjs-returned))) ((intersectp-eq used-vars ignore-vars) (trans-er+ x ctx "Contrary to the declaration that ~#0~[it ~ is~/they are~] IGNOREd, the variable~#0~[ ~ ~&0 is~/s ~&0 are~] used in the body of ~ the LET expression that binds ~&1." (intersection-eq used-vars ignore-vars) bound-vars)) (t (let* ((ignore-vars (if (eq stobjs-out t) (augment-ignore-vars bound-vars value-forms ignore-vars) ignore-vars)) (diff (set-difference-eq bound-vars (union-eq used-vars (union-eq ignorable-vars ignore-vars)))) (ignore-ok (if (null diff) t (cdr (assoc-eq :ignore-ok (table-alist 'acl2-defaults-table wrld)))))) (cond ((null ignore-ok) (trans-er+ x ctx "The variable~#0~[ ~&0 is~/s ~&0 are~] ~ not used in the body of the LET ~ expression that binds ~&1. But ~&0 ~ ~#0~[is~/are~] not declared IGNOREd or ~ IGNORABLE. See :DOC set-ignore-ok." diff bound-vars)) (t (prog2$ (cond ((eq ignore-ok :warn) (warning$-cw1 ctx "Ignored-variables" "The variable~#0~[ ~&0 is~/s ~&0 ~ are~] not used in the body of ~ the LET expression that binds ~ ~&1. But ~&0 ~#0~[is~/are~] not ~ declared IGNOREd or IGNORABLE. ~ See :DOC set-ignore-ok." diff bound-vars)) (t nil)) (let* ((tbody (cond (tdcls (let ((guardian (dcl-guardian tdcls))) (cond ((equal guardian *t*) tbody) (t (prog2$-call guardian tbody))))) (t tbody)))) (trans-value (if (and (access state-vars state-vars :do-expressionp) (ersatz-symbols t tbody)) (make-lambda-term bound-vars (hide-ignored-actuals ignore-vars bound-vars value-forms) tbody) (make-lambda-term bound-vars (hide-ignored-actuals ignore-vars bound-vars value-forms) tbody)))))))))))))))))))))))) (defun translate11-let* (x tbody targs stobjs-out bindings known-stobjs known-dfs flet-alist ctx wrld state-vars) (cond ((endp targs) (trans-value tbody)) (t (case-match x (('let* (pair . pairs) y) (let ((body0 `(let* ,PAIRS ,Y))) (trans-er-let* ((tbody0 (translate11-let* body0 tbody (cdr targs) stobjs-out bindings known-stobjs known-dfs flet-alist ctx wrld state-vars))) (translate11-let `(let (,PAIR) ,BODY0) tbody0 (list (car targs)) stobjs-out bindings known-stobjs known-dfs flet-alist ctx wrld state-vars)))) (& (trans-er+ x ctx "Implementation error: Unexpected form for ~x0." 'translate11-let*)))))) (defun translate11-collecting-known-dfs (x bound-stobjs-out bound-known-dfs bindings known-stobjs top-known-dfs flet-alist cform ctx wrld state-vars bound-vars) (let* ((binding-count (access state-vars state-vars :binding-count)) (stobjs-out-sym-pair (stobjs-out-sym-pair binding-count)) (stobjs-out-sym (car stobjs-out-sym-pair))) (mv-let (erp val new-bindings) (translate11 x nil stobjs-out-sym (cons stobjs-out-sym-pair bindings) known-stobjs top-known-dfs flet-alist cform ctx wrld (change state-vars state-vars :binding-count (1+ binding-count))) (let ((stobjs-out-val (and (not erp) (translate-deref stobjs-out-sym new-bindings)))) (cond ((and erp (not (eq new-bindings :unknown-bindings))) (mv erp val new-bindings nil)) ((or erp (symbolp stobjs-out-val) (not (compatible-stobjs-out-p stobjs-out-val bound-vars known-stobjs bound-known-dfs wrld))) (let ((stobjs-out-for-form (stobjs-out-for-form x known-stobjs top-known-dfs wrld state-vars bound-stobjs-out)) (minimal-known-dfs (append? bound-known-dfs (set-difference-eq top-known-dfs bound-vars)))) (cond ((compatible-stobjs-out-p stobjs-out-for-form bound-vars known-stobjs bound-known-dfs wrld) (mv-let (erp val bindings) (translate11 x nil stobjs-out-for-form bindings known-stobjs minimal-known-dfs flet-alist cform ctx wrld state-vars) (mv erp val bindings (collect-by-position '(:df) stobjs-out-for-form bound-vars)))) (t (mv-let (erp val bindings) (trans-er+ cform ctx "The bound variable list ~x0 from an MV-LET ~ expression has been found not to be compatible ~ with the ``types'' (each a stobj name or an ~ indicator of a non-stobj object) computed for ~ them, ~x1.~@2" bound-vars stobjs-out-for-form (if (or (member-eq :df bound-known-dfs) (member-eq :df stobjs-out-for-form)) "~|If dfs are involved (see :DOC df), then ~ proper double-float type declarations may ~ help." "")) (mv erp val bindings nil)))))) (t (let ((new-known-dfs (append (collect-by-position '(:df) stobjs-out-val bound-vars) (set-difference-eq top-known-dfs bound-vars)))) (mv nil val (remove-from-binding stobjs-out-sym stobjs-out-val new-bindings) new-known-dfs)))))))) (defun translate11-mv-let (x tcall0 tbody0 stobjs-out bindings known-stobjs known-dfs local-stobj local-stobj-creator flet-alist ctx wrld state-vars) (cond ((not (and (true-listp (cadr x)) (> (length (cadr x)) 1))) (trans-er ctx "The first form in an MV-LET expression must be a true list of ~ length 2 or more. ~x0 does not meet these conditions." (cadr x))) ((not (arglistp (cadr x))) (mv-let (culprit explan) (find-first-bad-arg (cadr x)) (trans-er ctx "The first form in an MV-LET expression must be a list of ~ distinct variables of length 2 or more, but ~x0 does not ~ meet these conditions. The element ~x1 ~@2." x culprit explan))) ((not (>= (length x) 4)) (trans-er ctx "An MV-LET expression has the form (mv-let (var var var*) form ~ dcl* form) but ~x0 does not have sufficient length to meet ~ this condition." x)) (t (mv-let (erp edcls) (collect-declarations-cmp (butlast (cdddr x) 1) (cadr x) 'mv-let ctx wrld) (cond (erp (trans-er erp "~@0" edcls)) (t (let* ((bound-vars (cadr x)) (producer-known-stobjs (if (and local-stobj (not (eq known-stobjs t))) (add-to-set-eq local-stobj known-stobjs) known-stobjs)) (bound-known-dfs (extend-known-dfs-with-declared-df-types edcls nil)) (bound-stobjs-out (if (and (eq stobjs-out t) (not local-stobj)) t (compute-stobj-flags bound-vars producer-known-stobjs bound-known-dfs wrld))) (stobjs-bound0 (if (eq bound-stobjs-out t) nil (collect-non-nil-df bound-stobjs-out))) (stobjs-bound (if local-stobj (remove1-eq local-stobj stobjs-bound0) stobjs-bound0))) (mv-let (erp tcall bindings known-dfs) (cond (tcall0 (assert$ tbody0 (mv nil tcall0 bindings known-dfs))) ((eq bound-stobjs-out t) (mv-let (erp val bindings) (translate11 (caddr x) nil t bindings producer-known-stobjs known-dfs flet-alist x ctx wrld state-vars) (mv erp val bindings nil))) (t (translate11-collecting-known-dfs (caddr x) bound-stobjs-out bound-known-dfs bindings producer-known-stobjs known-dfs flet-alist x ctx wrld state-vars bound-vars))) (cond (erp (mv ctx tcall bindings)) (t (trans-er-let* ((tdcls (translate11-lst (translate-dcl-lst edcls wrld) nil (if (eq stobjs-out t) t nil) bindings known-stobjs known-dfs "in a DECLARE form in an MV-LET" flet-alist x ctx wrld state-vars)) (tbody (if tbody0 (trans-value tbody0) (translate11 (car (last x)) nil stobjs-out bindings known-stobjs known-dfs flet-alist x ctx wrld state-vars)))) (let ((used-vars (union-eq (all-vars tbody) (all-vars1-lst tdcls nil))) (ignore-vars (if local-stobj (cons local-stobj (ignore-vars edcls)) (ignore-vars edcls))) (ignorable-vars (ignorable-vars edcls)) (stobjs-out (translate-deref stobjs-out bindings))) (cond ((and local-stobj (not (member-eq local-stobj ignore-vars))) (trans-er+ x ctx "A local-stobj must be declared ignored, but ~ ~x0 is not. See :DOC with-local-stobj." local-stobj)) ((and stobjs-bound (not (consp stobjs-out))) (unknown-binding-msg-er x ctx stobjs-bound "an MV-LET" "the MV-LET" "the MV-LET")) ((and stobjs-bound (null tbody0) (not (subsetp stobjs-bound (collect-non-x nil stobjs-out)))) (let ((stobjs-returned (collect-non-nil-df stobjs-out))) (trans-er+ x ctx "The single-threaded object~#0~[ ~&0 has~/s ~ ~&0 have~] been bound in an MV-LET. It is a ~ requirement that ~#0~[this object~/these ~ objects~] be among the outputs of the ~ MV-LET, but ~#0~[it is~/they are~] not. The ~ MV-LET returns ~#1~[no single-threaded ~ objects~/the single-threaded object ~&2~/the ~ single-threaded objects ~&2~]." (set-difference-eq stobjs-bound stobjs-returned) (zero-one-or-more stobjs-returned) stobjs-returned))) ((intersectp-eq used-vars ignore-vars) (trans-er+ x ctx "Contrary to the declaration that ~#0~[it ~ is~/they are~] IGNOREd, the variable~#0~[ ~&0 ~ is~/s ~&0 are~] used in the MV-LET expression ~ that binds ~&1." (intersection-eq used-vars ignore-vars) bound-vars)) (t (let* ((diff (set-difference-eq bound-vars (union-eq used-vars (union-eq ignorable-vars ignore-vars)))) (ignore-ok (if (null diff) t (cdr (assoc-eq :ignore-ok (table-alist 'acl2-defaults-table wrld)))))) (cond ((null ignore-ok) (trans-er+ x ctx "The variable~#0~[ ~&0 is~/s ~&0 are~] not ~ used in the body of the MV-LET expression ~ that binds ~&1. But ~&0 ~#0~[is~/are~] ~ not declared IGNOREd or IGNORABLE. See ~ :DOC set-ignore-ok." diff bound-vars)) (t (prog2$ (cond ((eq ignore-ok :warn) (warning$-cw1 ctx "Ignored-variables" "The variable~#0~[ ~&0 is~/s ~&0 ~ are~] not used in the body of the ~ MV-LET expression that binds ~&1. ~ But ~&0 ~#0~[is~/are~] not declared ~ IGNOREd or IGNORABLE. See :DOC ~ set-ignore-ok." diff bound-vars)) (t nil)) (let* ((tbody (cond (tdcls (let ((guardian (dcl-guardian tdcls))) (cond ((equal guardian *t*) tbody) (t (prog2$-call guardian tbody))))) (t tbody))) (body-vars (all-vars tbody)) (extra-body-vars (set-difference-eq body-vars (cadr x))) (vars (all-vars1 tcall extra-body-vars)) (mv-var (genvar 'genvar "MV" nil vars))) (trans-value (list* (make-lambda (cons mv-var extra-body-vars) (cons (make-lambda (append (cadr x) extra-body-vars) tbody) (append (hide-ignored-actuals ignore-vars (cadr x) (mv-nth-list mv-var 0 (length (cadr x)))) extra-body-vars))) (if local-stobj (let ((tcall-vars (remove1-eq local-stobj (all-vars tcall)))) (cons (make-lambda (cons local-stobj tcall-vars) tcall) (cons (list local-stobj-creator) tcall-vars))) tcall) extra-body-vars))))))))))))))))))))) (defun translate11-wormhole-eval (x y z bindings flet-alist ctx wrld state-vars) (declare (ignore z)) (cond ((not (and (true-listp y) (equal (length y) 2) (equal (car y) 'quote))) (trans-er ctx "The second argument to wormhole-eval must be a QUOTE ~ expression containing a LAMBDA expression and ~x0 is not ~ quoted." y)) ((not (and (true-listp (cadr y)) (equal (length (cadr y)) 3) (equal (car (cadr y)) 'lambda) (true-listp (cadr (cadr y))) (<= (length (cadr (cadr y))) 1))) (trans-er ctx "The second argument to wormhole-eval must be a QUOTE ~ expression containing a LAMBDA expression with at most one ~ formal, e.g., the second argument must be either of the form ~ '(LAMBDA () body) or of the form (LAMBDA (v) body). But ~x0 ~ is of neither form." y)) (t (let ((lambda-formals (cadr (cadr y))) (lambda-body (caddr (cadr y)))) (cond ((not (arglistp lambda-formals)) (mv-let (culprit explan) (find-first-bad-arg lambda-formals) (trans-er ctx "The quoted lambda expression, ~x0, supplied to ~ wormhole-eval is improper because it binds ~x1, ~ which ~@2." y culprit explan))) (t (let ((whs (car lambda-formals))) (mv-let (body-erp tlambda-body body-bindings) (translate11 lambda-body nil '(nil) nil '(state) nil flet-alist x ctx wrld state-vars) (declare (ignore body-bindings)) (cond (body-erp (mv body-erp tlambda-body bindings)) ((and whs (not (member-eq whs (all-vars tlambda-body)))) (trans-er ctx "The form ~x0 is an improper quoted lambda ~ expression for wormhole-eval because it binds but ~ does not use ~x1, which is understood to be the ~ name you're giving to the current value of the ~ wormhole status for the wormhole in question." y whs)) (t (trans-value (fcons-term* 'wormhole-eval x (list 'quote (if whs `(lambda (,WHS) ,TLAMBDA-BODY) `(lambda nil ,TLAMBDA-BODY))) (name-dropper (if whs (remove1-eq whs (all-vars tlambda-body)) (all-vars tlambda-body))))))))))))))) (defun translate11-call-1 (form fn args bindings known-stobjs known-dfs msg flet-alist ctx wrld state-vars stobjs-in-call) (trans-er-let* ((targs (cond ((and (symbolp fn) (stobj-recognizer-p fn wrld)) (cond ((if (eq known-stobjs t) (stobjp (car args) known-stobjs wrld) (member-eq (car args) known-stobjs)) (mv-let (erp val bindings) (translate11-lst args (ilks-per-argument-slot fn wrld) stobjs-in-call bindings known-stobjs known-dfs msg flet-alist form ctx wrld state-vars) (cond (erp (trans-er ctx "~@0 Observe that while it is permitted to ~ apply ST4$CP to an ordinary object, this ~ stobj recognizer must not be applied to the ~ wrong stobj." val)) (t (trans-value val))))) (t (translate11-lst args (ilks-per-argument-slot fn wrld) '(nil) bindings known-stobjs known-dfs msg flet-alist form ctx wrld state-vars)))) ((eq fn 'dfp) (trans-or (translate11-lst args (ilks-per-argument-slot fn wrld) stobjs-in-call bindings known-stobjs known-dfs msg flet-alist form ctx wrld state-vars) t (translate11-lst args (ilks-per-argument-slot fn wrld) '(:df) bindings known-stobjs known-dfs msg flet-alist form ctx wrld state-vars) "")) (t (translate11-lst (if (eq fn 'wormhole-eval) (list (nth 0 args) *nil* (nth 2 args)) args) (ilks-per-argument-slot fn wrld) stobjs-in-call bindings known-stobjs known-dfs msg flet-alist form ctx wrld state-vars))))) (cond ((and (not (global-val 'boot-strap-flg wrld)) (member-eq fn '(wormhole-eval sync-ephemeral-whs-with-persistent-whs set-persistent-whs-and-ephemeral-whs)) (or (not (quotep (car targs))) (member-eq (unquote (car targs)) *protected-system-wormhole-names*))) (cond ((not (quotep (car targs))) (trans-er ctx "The first argument of ~x0 must be a quoted wormhole name, ~ thus ~X12 is illegal.~#3~[~/ This call of WORMHOLE-EVAL ~ might have been introduced by the macroexpansion of a call ~ of WORMHOLE on that wormhole name.~]" fn (cons fn args) (evisc-tuple 3 3 nil nil) (if (eq fn 'wormhole-eval) 1 0))) (t (trans-er ctx "It is illegal to call ~x0 on ~x1 because that is the name ~ of a protected ACL2 system wormhole.~#2~[~/ This call of ~ WORMHOLE-EVAL might have been introduced by the ~ macroexpansion of a call of WORMHOLE on that wormhole ~ name.~]" fn (unquote (car targs)) (if (eq fn 'wormhole-eval) 1 0))))) ((eq fn 'wormhole-eval) (translate11-wormhole-eval (car targs) (cadr args) (caddr targs) bindings flet-alist ctx wrld state-vars)) (t (trans-value (fcons-term fn targs)))))) (defun translate11-call (form fn args stobjs-out-x stobjs-out-fn bindings known-stobjs known-dfs msg flet-alist ctx wrld state-vars) (mv-let (alist-in-out stobjs-in-call stobjs-out-call) (stobjs-in-out fn args stobjs-out-fn known-stobjs wrld) (cond ((consp stobjs-out-x) (cond ((consp stobjs-out-call) (cond ((equal stobjs-out-x stobjs-out-call) (translate11-call-1 form fn args bindings known-stobjs known-dfs msg flet-alist ctx wrld state-vars stobjs-in-call)) (t (trans-er-let* ((tform (if (match-stobjs stobjs-out-x stobjs-out-fn wrld nil) (translate11-call-1 form fn args bindings known-stobjs known-dfs msg flet-alist ctx wrld state-vars stobjs-in-call) (mv nil nil nil)))) (trans-er+ form ctx "It is illegal to invoke ~@0 here because of a ~ signature mismatch. This function call returns a ~ result of shape ~X14~@2 where a result of shape ~X34 ~ is required." (if (consp fn) msg (msg "~x0" fn)) (prettyify-stobjs-out stobjs-out-call) (if alist-in-out " (after accounting for the replacement of some ~ input stobjs by congruent stobjs)" "") (prettyify-stobjs-out stobjs-out-x) nil))))) (t (let ((bindings (translate-bind stobjs-out-fn (if (consp alist-in-out) (apply-inverse-symbol-alist alist-in-out stobjs-out-x nil) stobjs-out-x) bindings))) (trans-er-let* ((args (translate11-lst args (ilks-per-argument-slot fn wrld) stobjs-in-call bindings known-stobjs known-dfs msg flet-alist form ctx wrld state-vars))) (trans-value (fcons-term fn args))))))) ((consp stobjs-out-call) (let ((bindings (translate-bind stobjs-out-x stobjs-out-call bindings))) (translate11-call-1 form fn args bindings known-stobjs known-dfs msg flet-alist ctx wrld state-vars stobjs-in-call))) (t (let ((bindings (if (consp alist-in-out) bindings (translate-bind stobjs-out-fn stobjs-out-x bindings)))) (trans-er-let* ((args (translate11-lst args (ilks-per-argument-slot fn wrld) stobjs-in-call bindings known-stobjs known-dfs msg flet-alist form ctx wrld state-vars))) (trans-value (fcons-term fn args)))))))) (defun translate11-do-clause (term type-preds tguard sigma all-stobj-names known-stobjs known-dfs flet-alist cform ctx wrld state-vars) (declare (ignore known-dfs)) (mv-let (erp val bindings) (translate11-lambda-object (make-do-body-lambda$ type-preds tguard sigma all-stobj-names term) t nil known-stobjs flet-alist cform ctx wrld state-vars nil) (cond (erp (trans-er ctx "~@0" val)) (t (trans-value val))))) (defun translate11-lambda-object (x stobjs-out bindings known-stobjs flet-alist cform ctx wrld state-vars allow-counterfeitsp) (cond ((and (eq stobjs-out t) (eq (car x) 'lambda)) (mv-let (erp val) (hons-copy-lambda-object? `',X) (cond (erp (trans-er+? cform x ctx "~@0" val)) (t (translate11-var-or-quote-exit x val stobjs-out bindings known-stobjs nil flet-alist cform ctx wrld state-vars))))) ((and (or (eq (car x) 'lambda) (eq (car x) 'lambda$)) (true-listp x) (<= 3 (length x))) (let* ((lambda-casep (eq (car x) 'lambda)) (vars (cadr x)) (dcls (butlast (cddr x) 1)) (body (car (last x))) (stobjs-out-simple (if (eq stobjs-out t) t '(nil)))) (cond ((not (arglistp vars)) (trans-er+? cform x ctx "The second element of a well-formed LAMBDA object or ~ lambda$ term must be a true list of distinct legal ~ variable symbols and ~x0 is not. ~@1" vars *gratuitous-lambda-object-restriction-msg*)) (t (trans-er-let* ((edcls (edcls-from-lambda-object-dcls dcls x bindings cform ctx wrld))) (let* ((bindings0 bindings) (fives (list (list :lambda vars nil edcls body))) (xargs (assoc-eq 'xargs edcls)) (split-types (or lambda-casep (cadr (assoc-keyword :split-types (cdr xargs))))) (guard1-tail (assoc-keyword :guard (cdr xargs))) (guard1 (cadr guard1-tail)) (guard2 (and (not lambda-casep) (car (get-guards fives (list split-types) nil wrld)))) (guard (if lambda-casep (if (null guard1-tail) *t* guard1) guard2)) (ignores (ignore-vars edcls)) (ignorables (ignorable-vars edcls)) (known-dfs (extend-known-dfs-with-declared-df-types edcls nil))) (trans-er-let* ((tguard (if lambda-casep (if (termp guard wrld) (trans-value guard) (trans-er+? cform x ctx "The guard of a LAMBDA object must be a fully ~ translated term and ~x0 is not. ~@1" guard *gratuitous-lambda-object-restriction-msg*)) (translate11 guard nil stobjs-out-simple nil nil known-dfs nil cform ctx wrld state-vars)))) (let* ((bindings bindings0) (type-exprs (if split-types (flatten-ands-in-lit-lst (get-guards2 edcls '(types) t wrld nil nil nil)) nil)) (guard-conjuncts (if split-types (flatten-ands-in-lit tguard) nil)) (missing-type-exprs (if split-types (set-difference-equal type-exprs guard-conjuncts) nil)) (free-vars-guard (set-difference-eq (all-vars tguard) vars))) (cond (free-vars-guard (trans-er+? cform x ctx "The guard of a LAMBDA object or lambda$ term may ~ contain no free variables. This is violated by ~ the guard ~x0, which uses the variable~#1~[~/s~] ~ ~&1 which ~#1~[is~/are~] not among the formals. ~ ~@2" (untranslate tguard t wrld) free-vars-guard *gratuitous-lambda-object-restriction-msg*)) (missing-type-exprs (trans-er+? cform x ctx "In a LAMBDA object or a lambda$ term with ~ :SPLIT-TYPES T, every TYPE expression derived ~ from the TYPE specifiers must be an explicit ~ conjunct in the :GUARD, and the guard ~x0 is ~ missing ~&1. ~@2" tguard missing-type-exprs *gratuitous-lambda-object-restriction-msg*)) (t (trans-er-let* ((tbody (if lambda-casep (if (termp body wrld) (if (and (not allow-counterfeitsp) (lambda$-bodyp body)) (if (let ((alleged-lambda$ (unquote (fargn body 2)))) (mv-let (erp val bindings) (translate11-lambda-object alleged-lambda$ t nil t nil nil 'translate11-lambda-object wrld state-vars nil) (declare (ignore bindings)) (and (null erp) (equal (lambda-object-body (unquote val)) body)))) (trans-value body) (trans-er+? cform x ctx "The body of a LAMBDA object may not be ~ of the form (RETURN-LAST 'PROGN ~ '(LAMBDA$ ...) ...) because that idiom ~ is used to flag LAMBDA objects generated ~ by translating lambda$ terms. But you ~ wrote a LAMBDA object with body ~x0. ~@1" body *gratuitous-lambda-object-restriction-msg*)) (trans-value body)) (trans-er+? cform x ctx "The body of a LAMBDA object must be in fully ~ translated form and ~x0 is not. ~@1" body *gratuitous-lambda-object-restriction-msg*)) (translate11 body nil stobjs-out-simple bindings nil known-dfs nil cform ctx wrld state-vars)))) (let* ((body-vars (all-vars tbody)) (free-vars-body (set-difference-eq body-vars vars)) (used-ignores (and lambda-casep (intersection-eq body-vars ignores))) (unused-not-ignorables (and lambda-casep (set-difference-eq (set-difference-eq (set-difference-eq vars body-vars) ignores) ignorables)))) (cond (free-vars-body (trans-er+? cform x ctx "The body of a LAMBDA object or lambda$ term ~ may contain no free variables. This is ~ violated by the body ~x0, which uses the ~ variable~#1~[~/s~] ~&1 which ~#1~[is~/are~] ~ not among the formals. ~@2" (untranslate tbody nil wrld) free-vars-body *gratuitous-lambda-object-restriction-msg*)) (used-ignores (trans-er+? cform x ctx "The body of a LAMBDA object may not use a ~ variable declared IGNOREd. This is ~ violated by the body ~x0, which uses the ~ variable~#1~[~/s~] ~&1 which ~#1~[is~/are~] ~ declare IGNOREd. ~@2" (untranslate tbody nil wrld) used-ignores *gratuitous-lambda-object-restriction-msg*)) (unused-not-ignorables (trans-er+? cform x ctx "Every formal variable that is unused in the ~ body of a LAMBDA object must be declared ~ IGNOREd or IGNORABLE. This is violated by ~ the body ~x0, which fails to use the ~ variable~#1~[~/s~] ~&1 which ~#1~[is~/are~] ~ not declared IGNOREd or IGNORABLE. ~@2" (untranslate tbody nil wrld) unused-not-ignorables *gratuitous-lambda-object-restriction-msg*)) (t (let ((bad-fns (all-unbadged-fnnames tbody wrld nil))) (cond (bad-fns (trans-er+ x ctx "The body of a LAMBDA object, lambda$ term, or ~ loop$ statement should be fully badged but ~&0 ~ ~#0~[is~/are~] used in ~x1 and ~#0~[has no ~ badge~/have no badges~]. ~@2" (reverse bad-fns) tbody *gratuitous-lambda-object-restriction-msg*)) ((not (executable-tamep tbody wrld)) (trans-er+? cform x ctx "The body of a LAMBDA object or lambda$ term ~ must be tame and ~x0 is not. ~@1" body *gratuitous-lambda-object-restriction-msg*)) (t (mv-let (erp val) (hons-copy-lambda-object? (if lambda-casep `',X (let ((edcls1 (if (equal tguard *t*) `((ignorable ,@VARS)) (put-assoc-eq 'ignorable vars (put-assoc-eq 'xargs `(:guard ,TGUARD :split-types t) edcls)))) (vars1 vars)) (let ((new-tbody (tag-translated-lambda$-body x tbody))) `'(lambda ,VARS1 (declare ,@EDCLS1) ,NEW-TBODY))))) (cond (erp (trans-er+? cform x ctx "~@0" val)) (t (translate11-var-or-quote-exit x val stobjs-out bindings known-stobjs nil flet-alist cform ctx wrld state-vars))))))))))))))))))))) (t (trans-er+? cform x ctx "Every LAMBDA object and lambda$ term must be a true list ~ of at least 3 elements, e.g., (LAMBDA vars ...dcls... ~ body) and ~x0 is not. ~@1" x *gratuitous-lambda-object-restriction-msg*)))) (defun translate-with-var-tuples (tuples stobjs-out bindings known-stobjs known-dfs cform ctx wrld state-vars) (cond ((endp tuples) (trans-value nil)) (t (let* ((var (car (car tuples))) (spec (cadr (car tuples))) (guard-form (translate-declaration-to-guard spec var wrld)) (init-form (if (caddr (car tuples)) (cadddr (car tuples)) *nil*)) (known-dfs (if (eq spec 'double-float) (cons var known-dfs) known-dfs)) (stobjs-out-simple (if (eq stobjs-out t) t (if (eq spec 'double-float) '(:df) '(nil))))) (cond ((not (legal-variablep var)) (trans-er+? cform var ctx "~x0 is not a legal variable name." var)) ((stobjp var known-stobjs wrld) (trans-er+? cform var ctx "~x0 is an illegal variable declared in a WITH clause ~ of a DO loop$ expression, because it is a known stobj ~ name in that context." var)) ((assoc-eq var (cdr tuples)) (trans-er+? cform var ctx "~x0 is bound more than once." var)) ((null guard-form) (trans-er+? cform var ctx "~x0 is not a legal type specification." spec)) (t (trans-er-let* ((init-term (translate11 init-form nil stobjs-out-simple nil known-stobjs known-dfs nil cform ctx wrld state-vars)) (guard-term (translate11 guard-form nil stobjs-out-simple nil known-stobjs known-dfs nil cform ctx wrld state-vars)) (rest (translate-with-var-tuples (cdr tuples) stobjs-out bindings known-stobjs known-dfs cform ctx wrld state-vars))) (trans-value (cons (list var spec guard-term init-term) rest))))))))) (defun translate11-do-finally (form stobjs-out known-stobjs known-dfs cform ctx wrld do-state-vars settable-vars) (mv-let (erp value bindings) (translate11 form nil stobjs-out nil known-stobjs known-dfs nil cform ctx wrld do-state-vars) (cond ((or (null erp) (eq stobjs-out t)) (mv erp value bindings)) (t (mv-let (erp2 value2 bindings2) (translate11 form nil t nil known-stobjs known-dfs nil cform ctx wrld do-state-vars) (declare (ignore bindings2)) (cond (erp2 (mv erp value bindings)) (t (mv-let (okp msg) (well-formed-do-body (access state-vars do-state-vars :do-expressionp) value2 settable-vars wrld) (cond (okp (mv erp value bindings)) (t (trans-er+? cform form ctx "Illegal FINALLY body: ~@0 ~ See :DOC do-loop$." msg))))))))))) (defun translate11-loop$ (x stobjs-out bindings known-stobjs known-dfs flet-alist cform ctx wrld state-vars) (let ((bindings0 bindings) (bindings nil) (stobjs-out (translate-deref stobjs-out bindings)) (stobjs-out-simple (if (eq stobjs-out t) t '(nil)))) (cond (flet-alist (trans-er+? cform x ctx "It is illegal for a LOOP$ expression to be in the scope of ~ function bindings of an FLET or MACROLET expression. The ~ occurrence of ~x0 in the context of the FLET/MACROLET ~ bindings of symbols~#1~[~/s~] ~&1 is thus illegal." x (strip-cars flet-alist))) (t (mv-let (erp parse) (parse-loop$ x) (cond (erp (trans-er+? cform x ctx "~@0" parse)) ((eq (car parse) 'for) (mv-let (vsts untilc whenc op lobodyc) (mv (nth 1 parse) (nth 2 parse) (nth 3 parse) (nth 4 parse) (nth 5 parse)) (cond ((and whenc (or (eq op 'always) (eq op 'thereis))) (trans-er+? cform x ctx "It is illegal in CLTL to have a WHEN clause with ~ an ALWAYS or THEREIS accumulator, so ~x0 is ~ illegal." x)) (t (trans-er-let* ((tvsts (translate-vsts vsts 'loop$-ivars nil cform ctx wrld)) (known-dfs (trans-value (adjust-known-dfs-for-var-tuples tvsts known-dfs))) (translated-until-guard (if (and untilc (not (eq (excart :untranslated :guard untilc) t))) (translate11 (excart :untranslated :guard untilc) nil stobjs-out-simple nil nil known-dfs nil cform ctx wrld state-vars) (trans-value *t*))) (translated-until-body (if untilc (translate11 (excart :untranslated :body untilc) nil stobjs-out-simple nil nil known-dfs nil cform ctx wrld state-vars) (trans-value *nil*))) (translated-when-guard (if (and whenc (not (eq (excart :untranslated :guard whenc) t))) (translate11 (excart :untranslated :guard whenc) nil stobjs-out-simple nil nil known-dfs nil cform ctx wrld state-vars) (trans-value *t*))) (translated-when-body (if whenc (translate11 (excart :untranslated :body whenc) nil stobjs-out-simple nil nil known-dfs nil cform ctx wrld state-vars) (trans-value *nil*))) (translated-lobody-guard (if (and lobodyc (not (eq (excart :untranslated :guard lobodyc) t))) (translate11 (excart :untranslated :guard lobodyc) nil stobjs-out-simple nil nil known-dfs nil cform ctx wrld state-vars) (trans-value *t*))) (translated-lobody-body (if lobodyc (translate11 (excart :untranslated :body lobodyc) nil stobjs-out-simple nil nil known-dfs nil cform ctx wrld state-vars) (trans-value *nil*)))) (let* ((bindings bindings0) (untilc (if untilc (make-carton (excart :untranslated :guard untilc) translated-until-guard (excart :untranslated :body untilc) translated-until-body) nil)) (whenc (if whenc (make-carton (excart :untranslated :guard whenc) translated-when-guard (excart :untranslated :body whenc) translated-when-body) nil)) (lobodyc (make-carton (excart :untranslated :guard lobodyc) translated-lobody-guard (excart :untranslated :body lobodyc) translated-lobody-body)) (iteration-vars (strip-cars tvsts)) (until-free-vars (if untilc (set-difference-eq (revappend (all-vars1-lst (list (excart :translated :guard untilc) (excart :translated :body untilc)) nil) nil) iteration-vars) nil)) (when-free-vars (if whenc (set-difference-eq (revappend (all-vars1-lst (list (excart :translated :guard whenc) (excart :translated :body whenc)) nil) nil) iteration-vars) nil)) (lobody-free-vars (set-difference-eq (revappend (all-vars1-lst (list (excart :translated :guard lobodyc) (excart :translated :body lobodyc)) nil) nil) iteration-vars))) (translate11 (cond ((and (null (cdr tvsts)) (null until-free-vars) (null when-free-vars) (null lobody-free-vars)) (tag-loop$ x (make-plain-loop$ (car (car tvsts)) (cadr (car tvsts)) (cadddr (car tvsts)) untilc whenc op lobodyc))) (t (tag-loop$ x (make-fancy-loop$ tvsts untilc until-free-vars whenc when-free-vars op lobodyc lobody-free-vars)))) nil stobjs-out-simple bindings known-stobjs known-dfs flet-alist cform ctx wrld state-vars))))))) (t (mv-let (wvts mform values do-bodyc fin-bodyc finp) (mv (nth 1 parse) (nth 2 parse) (nth 3 parse) (nth 4 parse) (nth 5 parse) (nth 6 parse)) (let* ((stobjs (collect-non-nil-df values)) (values0 values) (values (or values '(nil))) (do-expressionp (make do-expressionp :stobjs-out values :with-vars (strip-cars wvts))) (do-state-vars (change state-vars state-vars :do-expressionp do-expressionp)) (settable-vars (append (strip-cars wvts) stobjs))) (cond ((not (symbol-listp values0)) (trans-er+? cform x ctx "The :VALUES keyword of a (loop$ .. do ..) ~ expression must be followed immediately by a ~ true list of symbols, unlike ~x0." values0)) ((and (not (eq stobjs-out t)) (unknown-stobj-names stobjs known-stobjs wrld)) (trans-er+? cform x ctx "The :VALUES keyword of a (loop$ .. do ..) ~ expression must be followed immediately by a ~ list, each member of which is either nil or is ~ known to be a stobj in the current context. ~ However, that is not the case for ~&0." (unknown-stobj-names stobjs known-stobjs wrld))) ((and (consp stobjs-out) (not (equal values stobjs-out))) (trans-er+? cform x ctx "The expression ~x0 ~#1~[implicitly ~/~]specifies ~ :VALUES ~x2, but the expected shape of the ~ return values is ~x3." x (if (null values0) 0 1) values stobjs-out)) (t (trans-er-let* ((twvts (translate-with-var-tuples wvts stobjs-out-simple nil known-stobjs known-dfs cform ctx wrld state-vars)) (known-dfs (trans-value (adjust-known-dfs-for-var-tuples twvts known-dfs))) (translated-mform (translate11 mform nil stobjs-out-simple nil known-stobjs known-dfs nil cform ctx wrld state-vars)) (translated-do-body-guard (translate11 (excart :untranslated :guard do-bodyc) nil stobjs-out-simple nil known-stobjs known-dfs nil cform ctx wrld state-vars)) (translated-do-body (translate11 (excart :untranslated :body do-bodyc) nil stobjs-out-simple nil known-stobjs known-dfs nil cform ctx wrld do-state-vars)) (translated-fin-body-guard (translate11 (excart :untranslated :guard fin-bodyc) nil stobjs-out-simple nil known-stobjs known-dfs nil cform ctx wrld state-vars)) (translated-fin-body (cond ((and (not finp) (not (equal values '(nil))) (not (ffnnamep 'ersatz-loop-finish translated-do-body))) (trans-value (fcons-term* 'ersatz-return (loop$-default values)))) (t (translate11-do-finally (excart :untranslated :body fin-bodyc) stobjs-out-simple known-stobjs known-dfs cform ctx wrld do-state-vars settable-vars))))) (let* ((vars (append settable-vars (set-difference-eq (all-vars1-lst (list translated-mform translated-do-body translated-fin-body) nil) settable-vars))) (all-stobj-names (collect-all-stobj-names vars known-stobjs wrld))) (mv-let (okp msg) (well-formed-do-body nil translated-do-body settable-vars wrld) (cond ((not okp) (trans-er+? cform x ctx "Illegal DO body: ~@0 See :DOC do-loop$." msg)) ((and (not (equal values '(nil))) (null (excart :untranslated :body fin-bodyc)) (ffnnamep 'ersatz-loop-finish translated-do-body)) (trans-er+? cform x ctx "A do loop$ with :VALUES other than ~x0 and a ~x1 ~ call must have a non-nil FINALLY clause. See :DOC ~ loop$." '(nil) 'loop-finish)) (t (mv-let (okp msg) (well-formed-do-body (if (equal values '(nil)) t values) translated-fin-body settable-vars wrld) (cond ((not okp) (trans-er+ x ctx "Illegal FINALLY body: ~@0 See :DOC ~ loop$." msg)) (t (let* ((do-body-term (cmp-do-body translated-do-body twvts vars wrld)) (measure-term (if mform translated-mform (guess-do-body-measure translated-do-body))) (untrans-measure (or mform measure-term)) (dolia (make dolia :all-stobj-names all-stobj-names :untrans-measure untrans-measure :untrans-do-loop$ x)) (fin-body-term (cmp-do-body translated-fin-body twvts vars wrld))) (cond ((eq (car do-body-term) :fail) (trans-er+? cform x ctx "~@0" (cdr do-body-term))) ((eq (car fin-body-term) :fail) (trans-er+? cform x ctx "~@0" (cdr fin-body-term))) ((eq measure-term nil) (trans-er+? cform x ctx "No :MEASURE was provided after ~ the DO operator and we failed to ~ find a likely measure. Please ~ supply a :MEASURE in ~X01. See ~ :DOC do-loop$." x nil)) (t (let ((bad-fns (all-unbadged-fnnames measure-term wrld (all-unbadged-fnnames do-body-term wrld (all-unbadged-fnnames fin-body-term wrld nil))))) (cond (bad-fns (trans-er+? cform x ctx "The measure, body, and FINALLY clauses ~ of a DO loop$ must be fully badged but ~ ~&0 ~#0~[has no badge and is used ~ in~/have no badges and are used in~] ~ ~X12. See :DOC do-loop$." (reverse bad-fns) x nil)) (t (mv-let (flg1 flg2 flg3) (mv (not (executable-tamep measure-term wrld)) (not (executable-tamep do-body-term wrld)) (not (executable-tamep fin-body-term wrld))) (cond ((or flg1 flg2 flg3) (trans-er+? cform x ctx "The measure, body, and FINALLY ~ clauses of a DO loop$ must be tame ~ and ~*0 ~#0~[clause is~/clauses ~ are~] not tame in ~X12. See :DOC ~ loop$." (list "" "~s*" "~s* and " "~s*, " (append (if flg1 '("the measure") nil) (if flg2 '("the do") nil) (if flg3 '("the FINALLY") nil))) x nil)) (t (let* ((sigma (var-to-cdr-assoc-var-substitution vars)) (type-preds (collect-twvts-type-preds twvts))) (trans-er-let* ((measure-fn (translate11-do-clause measure-term type-preds translated-do-body-guard sigma all-stobj-names known-stobjs known-dfs flet-alist cform ctx wrld state-vars)) (alist (trans-value (make-initial-do-body-alist twvts vars nil))) (do-fn (translate11-do-clause do-body-term type-preds translated-do-body-guard sigma all-stobj-names known-stobjs known-dfs flet-alist cform ctx wrld state-vars)) (finally-fn (translate11-do-clause fin-body-term type-preds translated-fin-body-guard sigma all-stobj-names known-stobjs known-dfs flet-alist cform ctx wrld state-vars))) (let ((bindings (cond ((and (symbolp stobjs-out) (not (eq stobjs-out t))) (translate-bind stobjs-out values bindings0)) (t bindings0)))) (trans-value (tag-loop$ x (fcons-term* 'do$ measure-fn alist do-fn finally-fn (kwote values) (kwote dolia))))))))))))))))))))))))))))))))))) (defun translate11 (x ilk stobjs-out bindings known-stobjs known-dfs flet-alist cform ctx wrld state-vars) (cond ((or (atom x) (eq (car x) 'quote)) (let* ((stobjs-out (translate-deref stobjs-out bindings)) (vc (legal-variable-or-constant-namep x)) (const (and (eq vc 'constant) (defined-constant x wrld)))) (cond ((and (symbolp x) (not (keywordp x)) (not vc)) (trans-er+? cform x ctx "The symbol ~x0 is being used as a variable or constant ~ symbol but does not have the proper syntax. Such names ~ must ~@1. See :DOC name." x (tilde-@-illegal-variable-or-constant-name-phrase x))) ((and (eq vc 'constant) (not const)) (trans-er+? cform x ctx "The symbol ~x0 (in package ~x1) has the syntax of a ~ constant, but has not been defined." x (symbol-package-name x))) ((and (not (atom x)) (not (termp x wrld))) (trans-er+? cform x ctx "The proper form of a quoted constant is (quote x), but ~ ~x0 is not of this form." x)) (t (trans-er-let* ((transx (cond ((keywordp x) (trans-value (kwote x))) ((symbolp x) (trans-value (cond ((eq vc 'constant) const) (t x)))) ((atom x) (trans-value (kwote x))) ((and (consp (cadr x)) (eq (car (cadr x)) 'lambda) (not (global-val 'boot-strap-flg wrld))) (if (or (eq ilk :fn) (eq ilk :fn?)) (translate11-lambda-object (cadr x) stobjs-out bindings known-stobjs flet-alist cform ctx wrld state-vars nil) (trans-value x))) (t (trans-value x))))) (cond ((and (or (eq ilk :fn) (eq ilk :fn?)) (quotep transx) (not (eq vc 'constant)) (not (global-val 'boot-strap-flg wrld)) (not (and (consp (unquote transx)) (eq (car (unquote transx)) 'lambda))) (cond ((eq ilk :fn) (not (and (symbolp (unquote transx)) (executable-badge (unquote transx) wrld)))) (t (not (symbolp (unquote transx)))))) (trans-er+? cform x ctx "The quoted object ~x0 occurs in a :FN slot of a function call ~ but ~x0 ~@1. We see no reason to allow this! To insist on ~ having such a call, defconst some symbol and use that symbol ~ constant here instead but be advised that even this workaround ~ will not allow such a call in a DEFUN." (unquote transx) (if (symbolp (unquote transx)) (if (function-symbolp (unquote transx) wrld) "does not have a badge" "is not a function symbol") "is not a function symbol or lambda object"))) (t (translate11-var-or-quote-exit x transx stobjs-out bindings known-stobjs known-dfs flet-alist cform ctx wrld state-vars)))))))) ((not (true-listp (cdr x))) (trans-er ctx "Function (and macro) applications in ACL2 must end in NIL. ~ ~x0 is not of this form." x)) ((not (symbolp (car x))) (mv-let (msg val) (lambda-to-let x) (cond (msg (trans-er ctx "~@0" msg)) (t (translate11 val nil stobjs-out bindings known-stobjs known-dfs flet-alist x ctx wrld state-vars))))) ((and (access state-vars state-vars :in-macrolet-def) (assoc-eq (car x) flet-alist)) (trans-er ctx "The call ~x0 is illegal in the body of a MACROLET binding of ~ the symbol ~x1, because that binding is in the scope of a ~ superior binding of ~x2 by ~@3. See :DOC macrolet." x (access state-vars state-vars :in-macrolet-def) (car x) (let ((entry (assoc-eq (car x) flet-alist))) (if (eq (cddr entry) :macrolet) "MACROLET" "FLET")))) ((and (access state-vars state-vars :do-expressionp) (or (eq (car x) 'progn) (assoc-eq (car x) *cltl-to-ersatz-fns*))) (let* ((temp (assoc-eq (car x) *cltl-to-ersatz-fns*)) (ersatz-fn (cadr temp)) (ersatz-arity (caddr temp))) (cond ((or (null ersatz-arity) (eql (length (cdr x)) ersatz-arity)) (case (car x) (mv-setq (cond ((not (and (true-listp (cadr x)) (> (length (cadr x)) 1))) (trans-er+ x ctx "The first form in an MV-SETQ expression must be a ~ true list of length 2 or more. ~x0 does not meet ~ these conditions." (cadr x))) (t (trans-er-let* ((body (translate11 (caddr x) ilk (if (eq stobjs-out t) t (compute-stobj-flags (cadr x) known-stobjs known-dfs wrld)) bindings known-stobjs known-dfs flet-alist cform ctx wrld (change state-vars state-vars :do-expressionp nil)))) (trans-value (make-ersatz-mv-setq (cadr x) body)))))) (setq (trans-er-let* ((body (translate11 (caddr x) ilk (if (eq stobjs-out t) t (compute-stobj-flags (list (cadr x)) known-stobjs known-dfs wrld)) bindings known-stobjs known-dfs flet-alist cform ctx wrld (change state-vars state-vars :do-expressionp nil)))) (trans-value (fcons-term* ersatz-fn (cadr x) body)))) (loop-finish (trans-value (fcons-term* ersatz-fn))) (return (trans-er-let* ((body (translate11 (cadr x) ilk (if (eq stobjs-out t) t (access do-expressionp (access state-vars state-vars :do-expressionp) :stobjs-out)) bindings known-stobjs known-dfs flet-alist cform ctx wrld (change state-vars state-vars :do-expressionp nil)))) (trans-value (fcons-term* ersatz-fn body)))) (prog2 (assert$ (or (eq stobjs-out t) (equal stobjs-out '(nil))) (trans-er-let* ((body1 (translate11 (cadr x) ilk stobjs-out bindings known-stobjs known-dfs flet-alist cform ctx wrld state-vars)) (body2 (translate11 (caddr x) ilk stobjs-out bindings known-stobjs known-dfs flet-alist cform ctx wrld state-vars))) (trans-value (fcons-term* ersatz-fn body1 body2))))) (progn (translate11 (cond ((null (cdr x)) *nil*) ((null (cddr x)) (cadr x)) (t (xxxjoin 'prog2 (cdr x)))) ilk stobjs-out bindings known-stobjs known-dfs flet-alist cform ctx wrld state-vars)) (otherwise (trans-er ctx "Implementation error: There is no ersatz function for ~ ~x0. Please contact the ACL2 implementors." (car x))))) (t (trans-er ctx "~x0, in the context of a DO or FINALLY clause of a loop$ ~ statement, takes ~#1~[no arguments~/1 argument~/~x2 ~ arguments~] but in the call ~x3 it is given ~#4~[no ~ argument~/1 argument~/~x5 arguments~]. The formal ~ parameters list for ~x0 is ~x6." (car x) (zero-one-or-more ersatz-arity) ersatz-arity x (zero-one-or-more (length (cdr x))) (length (cdr x)) (formals ersatz-fn wrld)))))) ((and (not (access state-vars state-vars :do-expressionp)) (ersatz-functionp (car x))) (trans-er ctx "The symbol ~x0, as in ~x1, is not allowed as a ``function ~ symbol'' except in the context of the DO or FINALLY clause of ~ a loop$ statement." (car x) x)) ((eq (car x) 'lambda$) (cond ((not (or (eq ilk :fn) (eq ilk :fn?))) (trans-er+? cform x ctx "It is illegal for a LAMBDA$ expression to occur ~ except in a :FN slot of a mapping function, and ~x0 ~ occurs either in a slot reserved for ~#1~[an ordinary ~ object of a badged function or a slot of unknown ilk ~ in an unbadged function~/a quoted expression or ~ variable of ilk :EXPR~]." x (if (eq ilk :expr) 1 0))) (t (translate11-lambda-object x stobjs-out bindings known-stobjs flet-alist cform ctx wrld state-vars nil)))) ((eq (car x) 'loop$) (cond ((eq ilk nil) (translate11-loop$ x stobjs-out bindings known-stobjs known-dfs flet-alist cform ctx wrld state-vars)) (t (trans-er+? cform x ctx "It is illegal for a LOOP$ expression to occur in a ~ slot of ilk ~x0." ilk)))) ((and (not (eq stobjs-out t)) (eq (car x) 'read-user-stobj-alist)) (trans-er ctx "The function ~x0 must not be called in code (except when ~ generated by expanding a call of ~x1).~@2" 'read-user-stobj-alist 'with-global-stobj *see-doc-with-global-stobj*)) ((and (not (eq stobjs-out t)) (eq (car x) 'swap-stobjs) (= (length (cdr x)) 2)) (let ((s1 (cadr x)) (s2 (caddr x))) (cond ((assoc-eq :stobjs-out bindings) (trans-er ctx "The macro ~x0 must not be called directly in the ACL2 ~ top-level loop. The call ~x1 is thus illegal. Consider ~ defining a function whose body includes this call. See ~ :DOC swap-stobjs." 'swap-stobjs x)) ((and (stobjp s1 known-stobjs wrld) (stobjp s2 known-stobjs wrld) (not (eq s1 s2)) (congruent-stobjsp s1 s2 wrld)) (mv-let (erp val bindings) (translate11 (list 'mv s1 s2) ilk stobjs-out bindings known-stobjs known-dfs flet-alist cform ctx wrld state-vars) (cond (erp (trans-er+? cform x ctx "The form ~x0 failed to translate because ~ translation of the corresponding form, ~x1, ~ failed with the following error ~ message:~|~@2" x (list 'mv s1 s2) val)) (t (trans-value (listify (list s2 s1))))))) (t (trans-er ctx "Illegal swap-stobjs call: ~x0. ~@1 See :DOC swap-stobjs." x (cond ((or (not (stobjp s1 known-stobjs wrld)) (not (stobjp s2 known-stobjs wrld))) (msg "Note that ~&0 ~#0~[is not a known stobj name~/are ~ not known stobj names~] in the context of that ~ call." (if (stobjp s1 known-stobjs wrld) (list s2) (if (stobjp s2 known-stobjs wrld) (list s1) (list s1 s2))))) ((eq s1 s2) "The two arguments of swap-stobjs must be distinct ~ names.") (t "The two arguments fail the requirement of being ~ congruent stobjs."))))))) ((and (not (eq stobjs-out t)) (eq (car x) 'mv)) (let ((stobjs-out (translate-deref stobjs-out bindings))) (cond ((let ((len (length (cdr x)))) (or (< len 2) (> len 32))) (cond ((< (length (cdr x)) 2) (trans-er ctx "MV must be given at least two arguments, but ~x0 ~ has fewer than two arguments." x)) (t (trans-er ctx "MV must be given no more than 32 arguments; thus ~ ~x0 has too many arguments." x)))) ((consp stobjs-out) (cond ((not (int= (length stobjs-out) (length (cdr x)))) (trans-er+? cform x ctx "The expected number of return values for ~x0 is ~x1 ~ but the actual number of return values is ~x2." x (length stobjs-out) (length (cdr x)))) (t (trans-er-let* ((args (translate11-lst (cdr x) nil stobjs-out bindings known-stobjs known-dfs 'mv flet-alist x ctx wrld state-vars))) (trans-value (listify args)))))) (t (let ((stobjs-out-df? (compute-stobj-flags-df? (cdr x) known-stobjs known-dfs wrld))) (cond ((not (no-duplicatesp (set-difference-eq stobjs-out-df? '(nil :df :df?)))) (trans-er ctx "It is illegal to return more than one reference to a ~ given single-threaded object in an MV form. The ~ form ~x0 is thus illegal." x)) (t (mv-let (erp args bindings returned-stobjs-out) (translate11-lst/stobjs-out (cdr x) nil stobjs-out-df? bindings known-stobjs known-dfs 'mv flet-alist x ctx wrld state-vars) (cond (erp (let ((st/call (find-stobj-out-and-call (cdr x) known-stobjs ctx wrld state-vars))) (cond (st/call (trans-er+ x ctx "The form ~x0 is being used as an argument ~ to a call of ~x1. This form evaluates to a ~ single-threaded object, ~x2; but for an ~ argument of ~x1, the stobj variable itself ~ (here, ~x2) is required, not merely a term ~ that returns such a single-threaded object. ~ ~ A suitable LET-binding of ~x2 outside the ~ call of ~x1 may avoid this error; see :DOC ~ stobj." (cdr st/call) 'mv (car st/call))) (t (mv erp args bindings))))) (t (let ((bindings (translate-bind stobjs-out returned-stobjs-out bindings))) (trans-value (listify args))))))))))))) ((eq (car x) 'mv-let) (translate11-mv-let x nil nil stobjs-out bindings known-stobjs known-dfs nil nil flet-alist ctx wrld state-vars)) ((and (eq (car x) 'dfp) (consp (cdr x)) (null (cddr x)) (symbolp (cadr x)) (eq (legal-variable-or-constant-namep (cadr x)) 'variable) (not (stobjp (cadr x) known-stobjs wrld))) (trans-value x)) ((assoc-eq (car x) flet-alist) (let ((entry (assoc-eq (car x) flet-alist))) (cond ((eq (cddr entry) :macrolet) (mv-let (erp expansion) (macrolet-expand x (cadr entry) ctx wrld state-vars) (cond (erp (trans-er+? cform x ctx "~@0" expansion)) (t (translate11 expansion ilk stobjs-out bindings known-stobjs known-dfs flet-alist cform ctx wrld state-vars))))) (t (let* ((lambda-fn (cadr entry)) (formals (lambda-formals lambda-fn)) (stobjs-out (translate-deref stobjs-out bindings)) (stobjs-out2 (translate-deref (cddr entry) bindings))) (cond ((not (eql (length formals) (length (cdr x)))) (trans-er ctx "FLET-bound local function ~x0 takes ~#1~[no ~ arguments~/1 argument~/~x2 arguments~] but in the ~ call ~x3 it is given ~#4~[no arguments~/1 ~ argument~/~x5 arguments~]. The formal ~ parameters list for the applicable FLET-binding ~ of ~x0 is ~X67." (car x) (zero-one-or-more (length formals)) (length formals) x (zero-one-or-more (length (cdr x))) (length (cdr x)) formals nil)) ((eq stobjs-out t) (trans-er-let* ((args (translate11-lst (cdr x) nil t bindings known-stobjs known-dfs nil flet-alist x ctx wrld state-vars))) (trans-value (fcons-term lambda-fn args)))) (t (translate11-call x lambda-fn (cdr x) stobjs-out stobjs-out2 bindings known-stobjs known-dfs (msg "a call of FLET-bound function ~x0" (car x)) flet-alist ctx wrld state-vars)))))))) ((and bindings (not (top-level-bindings-p bindings)) (hons-get (car x) *syms-not-callable-in-code-fal*)) (trans-er+ x ctx "We do not permit the use of ~x0 inside of code to be executed ~ by Common Lisp because its Common Lisp meaning differs from ~ its ACL2 meaning.~@1" (car x) (cond ((eq (car x) 'with-guard-checking-event) (msg " Consider using ~x0 instead." 'with-guard-checking-error-triple)) ((eq (car x) 'with-output) (msg " Consider using ~x0 instead." 'with-output!)) (t "")))) ((and (eq (car x) 'pargs) (true-listp x) (member (length x) '(2 3)) (let ((form (car (last x)))) (or flet-alist (not (and (consp form) (symbolp (car form)) (function-symbolp (car form) wrld)))))) (cond (flet-alist (trans-er+ x ctx "~x0 may not be called in the scope of ~x1." 'pargs 'flet)) (t (let ((form (car (last x)))) (trans-er+ x ctx "~x0 may only be used when its form argument is a function ~ call, unlike the argument ~x1.~@2 See :DOC pargs." 'pargs form (if (and (consp form) (symbolp (car form)) (getpropc (car form) 'macro-body nil wrld)) (list " Note that ~x0 is a macro, not a function ~ symbol." (cons #\0 (car form))) "")))))) ((eq (car x) 'translate-and-test) (cond ((not (equal (length x) 3)) (trans-er+ x ctx "TRANSLATE-AND-TEST requires exactly two arguments.")) (t (trans-er-let* ((ans (translate11 (caddr x) nil stobjs-out bindings known-stobjs known-dfs flet-alist x ctx wrld state-vars))) (mv-let (test-erp test-term test-bindings) (translate11 (list (cadr x) 'form) nil '(nil) nil known-stobjs known-dfs flet-alist x ctx wrld state-vars) (declare (ignore test-bindings)) (cond (test-erp (mv test-erp test-term bindings)) (t (mv-let (erp msg) (ev-w test-term (list (cons 'form ans) (cons 'world wrld)) wrld nil (access state-vars state-vars :safe-mode) (gc-off1 (access state-vars state-vars :guard-checking-on)) nil nil) (cond (erp (trans-er+ x ctx "The attempt to evaluate the ~ TRANSLATE-AND-TEST test, ~x0, when FORM is ~ ~x1, failed with the evaluation ~ error:~%~%``~@2''" (cadr x) ans msg)) ((or (consp msg) (stringp msg)) (trans-er+? cform x ctx "~@0" msg)) (t (trans-value ans))))))))))) ((eq (car x) 'with-local-stobj) (mv-let (erp st mv-let-form creator) (parse-with-local-stobj (cdr x)) (cond (erp (trans-er ctx "Ill-formed with-local-stobj form, ~x0. See :DOC ~ with-local-stobj." x)) ((assoc-eq :stobjs-out bindings) (trans-er ctx "Calls of with-local-stobj, such as ~x0, cannot be ~ evaluated directly, as in the top-level loop. See :DOC ~ with-local-stobj and see :DOC top-level." x)) ((untouchable-fn-p creator wrld (access state-vars state-vars :temp-touchable-fns)) (trans-er ctx "Illegal with-local-stobj form~@0~|~% ~y1:~%the stobj ~ creator function ~x2 is untouchable. See :DOC ~ remove-untouchable.~@3" (if (eq creator 'create-state) " (perhaps expanded from a corresponding ~ with-local-state form)," ",") x creator (if (eq creator 'create-state) " Also see :DOC with-local-state, which describes how ~ to get around this restriction and when it may be ~ appropriate to do so." ""))) ((and st (if (eq st 'state) (eq creator 'create-state) (eq st (stobj-creatorp creator wrld)))) (translate11-mv-let mv-let-form nil nil stobjs-out bindings known-stobjs known-dfs st creator flet-alist ctx wrld state-vars)) (t (let ((actual-creator (get-stobj-creator st wrld))) (cond (actual-creator (trans-er ctx "Illegal with-local-stobj form, ~x0. The creator ~ function for stobj ~x1 is ~x2, but ~@3. See :DOC ~ with-local-stobj." x st actual-creator (cond ((cdddr x) (msg "the function ~x0 was supplied instead" creator)) (t (msg "the creator was computed to be ~x0, so you ~ will need to supply the creator explicitly ~ for your call of ~x1" creator 'with-local-stobj))))) (t (trans-er ctx "Illegal with-local-stobj form, ~x0. The first ~ argument must be the name of a stobj, but ~x1 is not. ~ See :DOC with-local-stobj." x st)))))))) ((eq (car x) 'with-global-stobj) (cond ((assoc-eq :stobjs-out bindings) (trans-er ctx "Calls of WITH-GLOBAL-STOBJ, such as ~x0, cannot be evaluated ~ directly, as in the top-level loop. See :DOC ~ with-global-stobj and see :DOC top-level." x)) ((or (eq stobjs-out t) (eq known-stobjs t) (member-eq 'state known-stobjs)) (mv-let (erp st sig body) (parse-with-global-stobj (cdr x)) (cond (erp (trans-er ctx "~@0~@1" erp *see-doc-with-global-stobj*)) ((and (not (eq stobjs-out t)) (not (stobjp st t wrld))) (trans-er ctx "The call ~x0 is illegal because ~x1 is not ~ a known stobj in the current context.~@2" x st *see-doc-with-global-stobj*)) ((eq st 'state) (trans-er ctx "The call ~x0 is illegal because it binds ~x1 instead of ~ user-defined stobj.~@2" x 'state *see-doc-with-global-stobj*)) (t (let* ((stobjs-out (translate-deref stobjs-out bindings)) (main-body (with-global-stobj-fn1 st sig body nil)) (sig-adjusted (and sig (not (eq stobjs-out t)) (with-global-stobj-adjust-signature-or-vars st sig))) (bindings (cond ((and sig (symbolp stobjs-out) (not (eq stobjs-out t))) (translate-bind stobjs-out sig-adjusted bindings)) (t bindings))) (known-stobjs+ (if (eq known-stobjs t) t (add-to-set-eq st known-stobjs))) (stobjs-out-reduced (if (and (null sig) (consp stobjs-out)) (remove1 'st stobjs-out) stobjs-out))) (trans-er-let* ((tbody (if (and (consp stobjs-out) sig (not (equal stobjs-out sig-adjusted))) (trans-er ctx "The form ~x0 is illegal here because of a ~ signature mismatch. Its signature argument is ~ ~X12, which indicates that it will return a ~ result of shape ~X32. However, a result of ~ shape ~X42 is required.~@5" x sig nil sig-adjusted stobjs-out *see-doc-with-global-stobj*) (translate11 body nil (if (or (eq stobjs-out t) (null sig)) stobjs-out-reduced sig) bindings known-stobjs+ known-dfs flet-alist x ctx wrld state-vars))) (ignore (if (or sig (eq stobjs-out t) (consp stobjs-out)) (trans-value nil) (let ((stobjs-out (translate-deref stobjs-out bindings))) (cond ((symbolp stobjs-out) (trans-er ctx "The read-only WITH-GLOBAL-STOBJS call ~ ~x0 is illegal because, at the time we ~ process it, we are unable to determine ~ the stobjs returned by its body in ~ this environment -- so we are unable ~ to verify that the bound stobj, ~x1, ~ is not returned by its body.~@2" x st *see-doc-with-global-stobj*)) ((member-eq st stobjs-out) (trans-er ctx "The read-only WITH-GLOBAL-STOBJS call ~ ~x0 is illegal because its body ~ returns the bound stobj, ~x1.~@2" x st *see-doc-with-global-stobj*)) (t (trans-value nil)))))) (translated-main-body (cond ((null sig) (trans-value tbody)) ((null (cdr sig)) (case-match main-body (('let ((!st !body)) ('write-user-stobj-alist ('quote !st) !st 'state)) (trans-er-let* ((write-call (translate11 (list 'write-user-stobj-alist (kwote st) st 'state) nil (if (eq stobjs-out t) t '(state)) bindings known-stobjs+ known-dfs flet-alist x ctx wrld state-vars))) (translate11-let main-body write-call (list tbody) (if (eq stobjs-out t) t '(state)) bindings known-stobjs+ known-dfs flet-alist ctx wrld state-vars))) (& (trans-er+ x ctx "Implementation error (please report to the ~ ACL2 implementors): mismatch for LET ~ (updating) case of WITH-GLOBAL-STOBJ.")))) (t (case-match main-body (('mv-let & !body let-expr) (trans-er-let* ((translated-let-expr (translate11 let-expr nil t bindings known-stobjs+ known-dfs flet-alist x ctx wrld state-vars))) (translate11-mv-let main-body tbody translated-let-expr stobjs-out bindings known-stobjs+ known-dfs nil nil flet-alist ctx wrld state-vars))) (& (trans-er+ x ctx "Implementation error (please report to the ~ ACL2 implementors): mismatch for MV-LET ~ (updating) case of WITH-GLOBAL-STOBJ."))))))) (let ((msg (chk-global-stobj-body x tbody wrld))) (cond (msg (trans-er ctx "~@0" msg)) (t (translate11-let `(let ((,ST (read-user-stobj-alist ',ST state))) ,MAIN-BODY) translated-main-body nil t bindings known-stobjs known-dfs flet-alist ctx wrld state-vars)))))))))) (t (trans-er ctx "The call ~x0 is illegal because the ACL2 state is not a ~ known single-threaded object (stobj) in its context." x)))) ((and (assoc-eq (car x) *ttag-fns*) (not (ttag wrld)) (not (global-val 'boot-strap-flg wrld))) (trans-er+ x ctx "The function ~s0 cannot be called unless a trust tag is in ~ effect. See :DOC defttag.~@1" (car x) (or (cdr (assoc-eq (car x) *ttag-fns*)) ""))) ((and (eq (car x) 'progn!) (not (ttag wrld)) (not (global-val 'boot-strap-flg wrld))) (trans-er+ x ctx "The macro ~s0 cannot be called unless a trust tag is in ~ effect. See :DOC defttag." (car x))) ((and (eq (car x) 'stobj-let) (not (eq stobjs-out t))) (mv-let (msg bound-vars actuals creators stobj producer-vars producer updaters stobj-let-bindings consumer) (parse-stobj-let x) (cond (msg (trans-er ctx "~@0" msg)) ((assoc-eq :stobjs-out bindings) (trans-er ctx "Calls of stobj-let, such as ~x0, cannot be evaluated ~ directly, as in the top-level loop." x)) (t (let ((msg (chk-stobj-let bound-vars actuals stobj producer-vars stobj-let-bindings known-stobjs wrld))) (cond (msg (trans-er ctx "~@0" (illegal-stobj-let-msg msg x))) (t (let* ((new-known-stobjs (if (eq known-stobjs t) t (union-eq bound-vars known-stobjs))) (guarded-producer (if (intersectp-eq bound-vars producer-vars) `(check-vars-not-free (,STOBJ) ,PRODUCER) producer)) (guarded-consumer `(check-vars-not-free ,BOUND-VARS ,CONSUMER)) (letp (null (cdr producer-vars))) (updater-bindings (pairlis-x1 stobj (pairlis-x2 updaters nil))) (body1 `(let* ,UPDATER-BINDINGS ,GUARDED-CONSUMER)) (body2 (cond (letp `(let ((,(CAR PRODUCER-VARS) ,GUARDED-PRODUCER)) (declare (ignorable ,@PRODUCER-VARS)) ,BODY1)) (t `(mv-let ,PRODUCER-VARS ,GUARDED-PRODUCER (declare (ignorable ,@PRODUCER-VARS)) ,BODY1))))) (mv-let (erp tproducer bindings producer-known-dfs) (translate11-collecting-known-dfs guarded-producer (compute-stobj-flags producer-vars new-known-stobjs known-dfs wrld) nil bindings new-known-stobjs known-dfs flet-alist guarded-producer ctx wrld state-vars producer-vars) (cond (erp (trans-er ctx "~@0" tproducer)) (t (trans-er-let* ((tactuals (translate-stobj-calls actuals creators t bindings new-known-stobjs known-dfs flet-alist x ctx wrld state-vars)) (tupdaters (translate-stobj-calls updaters creators nil bindings new-known-stobjs known-dfs flet-alist x ctx wrld state-vars)) (tconsumer (translate11 guarded-consumer nil stobjs-out bindings new-known-stobjs producer-known-dfs flet-alist x ctx wrld state-vars)) (tbody1 (translate11-let* body1 tconsumer tupdaters stobjs-out bindings known-stobjs producer-known-dfs flet-alist ctx wrld state-vars)) (tbody2 (cond (letp (translate11-let body2 tbody1 (list tproducer) stobjs-out bindings new-known-stobjs known-dfs flet-alist ctx wrld state-vars)) (t (translate11-mv-let body2 tproducer tbody1 stobjs-out bindings new-known-stobjs known-dfs nil nil flet-alist ctx wrld state-vars))))) (let ((actual-stobjs-out (translate-deref stobjs-out bindings)) (dups-check (no-duplicate-indices-checks-for-stobj-let-actuals bound-vars actuals creators producer-vars stobj wrld)) (producer-stobjs (collect-non-x nil (compute-stobj-flags producer-vars known-stobjs nil wrld)))) (cond ((and updaters (or (not (consp actual-stobjs-out)) (not (member-eq stobj actual-stobjs-out)))) (let ((stobjs-returned (and (consp actual-stobjs-out) (collect-non-nil-df actual-stobjs-out)))) (trans-er+ x ctx "A STOBJ-LET form has been encountered ~ that specifies (with its list of ~ producer variables) ~#1~[a call~/calls~] ~ of stobj updater~#2~[~/s~] ~&2 of ~x0. ~ It is therefore a requirement that ~x0 ~ be among the outputs of the STOBJ-LET, ~ but it is not. The STOBJ-LET returns ~ ~#3~[no single-threaded objects~/the ~ single-threaded object ~&4~/the ~ single-threaded objects ~&4~/an ~ undetermined output signature in this ~ context~]. See :DOC stobj-let." stobj updaters (remove-duplicates-eq (strip-cars updaters)) (if (consp actual-stobjs-out) (zero-one-or-more stobjs-returned) 3) stobjs-returned))) ((and (atom actual-stobjs-out) (set-difference-eq producer-stobjs bound-vars)) (trans-er+ x ctx "A STOBJ-LET form has been encountered that ~ specifies stobj producer ~ variable~#0~[~/s~] ~&0 that cannot be ~ determined to be returned by that ~ STOBJ-LET form, that is, by its consumer ~ form. See :DOC stobj-let." (set-difference-eq producer-stobjs bound-vars))) ((set-difference-eq (set-difference-eq producer-stobjs bound-vars) actual-stobjs-out) (trans-er+ x ctx "A STOBJ-LET form has been encountered that ~ specifies stobj producer variable~#0~[ ~&0 ~ that is~/s ~&0~ that are~] not returned by ~ that STOBJ-LET form, that is, not returned ~ by its consumer form. See :DOC stobj-let." (set-difference-eq (set-difference-eq producer-stobjs bound-vars) actual-stobjs-out))) (t (trans-er-let* ((val (translate11-let `(let ,(PAIRLIS$ BOUND-VARS (PAIRLIS$ ACTUALS NIL)) (declare (ignorable ,@BOUND-VARS)) ,BODY2) tbody2 tactuals stobjs-out bindings known-stobjs known-dfs flet-alist ctx wrld state-vars))) (cond (dups-check (trans-er-let* ((chk (translate11 dups-check nil '(nil) bindings known-stobjs known-dfs flet-alist cform ctx wrld state-vars))) (trans-value (prog2$-call chk val)))) (t (trans-value val))))))))))))))))))) ((and (eq (car x) 'the) (not (eq stobjs-out t)) (consp (cdr x)) (consp (cddr x)) (null (cdddr x)) (eq (cadr x) 'double-float)) (let ((stobjs-out (translate-deref stobjs-out bindings))) (cond ((atom stobjs-out) (assert$ (symbolp stobjs-out) (let ((bindings (translate-bind stobjs-out '(:df) bindings))) (translate11 (caddr x) ilk '(:df) bindings known-stobjs known-dfs flet-alist x ctx wrld state-vars)))) ((cdr stobjs-out) (trans-er+? cform x ctx "The form ~x0 represents a single :DF value, but it ~ is being used where ~n1 values are expected." x (length stobjs-out))) ((not (eq (car stobjs-out) ':df)) (trans-er+? cform x ctx "The form ~x0 represents a :DF, but it is being used ~ where ~#1~[the stobj ~x2~/an ordinary value~] is ~ expected." x (if (car stobjs-out) 0 1) (car stobjs-out))) (t (translate11 (caddr x) ilk stobjs-out bindings known-stobjs known-dfs flet-alist x ctx wrld state-vars))))) ((getpropc (car x) 'macro-body nil wrld) (cond ((and (assoc-eq :stobjs-out bindings) (member-eq (car x) '(pand por pargs plet)) (eq (access state-vars state-vars :parallel-execution-enabled) t)) (trans-er ctx "Parallel evaluation is enabled, but is not implemented for ~ calls of parallelism primitives (~&0) made directly in the ~ ACL2 top-level loop, as opposed to being made inside a ~ function definition. The call ~x1 is thus illegal. To ~ allow such calls to be evaluated (but without parallelism), ~ either evaluate ~x2 or use the macro top-level. See :DOC ~ parallelism-at-the-top-level and :DOC ~ set-parallel-execution." '(pand por pargs plet) x '(set-parallel-execution :bogus-parallelism-ok))) ((and (eq (car x) 'ld) (not (or (eq stobjs-out t) (assoc-eq :stobjs-out bindings))) (not (global-val 'boot-strap-flg wrld)) (true-listp x) (not (member-eq :ld-user-stobjs-modified-warning (cdr x)))) (trans-er+ x ctx "It is illegal to call ~x0 in a function body without ~ specifying a value for :ld-user-stobjs-modified-warning. ~ See :DOC user-stobjs-modified-warnings." (car x))) (t (mv-let (erp expansion) (macroexpand1-cmp x ctx wrld state-vars) (cond (erp (mv erp expansion bindings)) (t (translate11 expansion ilk stobjs-out bindings known-stobjs known-dfs flet-alist x ctx wrld state-vars))))))) ((eq (car x) 'let) (translate11-let x nil nil stobjs-out bindings known-stobjs known-dfs flet-alist ctx wrld state-vars)) ((eq (car x) 'flet) (translate11-flet x stobjs-out bindings known-stobjs flet-alist ctx wrld state-vars)) ((and (not (eq stobjs-out t)) (null (cdr x)) (stobj-creatorp (car x) wrld)) (trans-er+ x ctx "It is illegal to call ~x0 in this context because it is a ~ stobj creator. Calls of stobj creators cannot appear in ~ top-level loop inputs or in function bodies (unless in the ~ scope of defun-nx or non-exec), although they may be called ~ in theorems." (car x))) ((eq (car x) 'macrolet) (translate11-macrolet x stobjs-out bindings known-stobjs flet-alist ctx wrld state-vars)) ((eql (arity (car x) wrld) (length (cdr x))) (cond ((untouchable-fn-p (car x) wrld (access state-vars state-vars :temp-touchable-fns)) (cond ((and (eq (car x) 'untouchable-marker) (consp (cadr x)) (eq (car (cadr x)) 'quote) (symbolp (cadr (cadr x))) (getpropc (cadr (cadr x)) 'macro-body nil wrld) (null (cddr (cadr x)))) (trans-er+ x ctx "It is illegal to call ~x0 because it has been ~ placed on untouchable-fns. That call may have ~ arisen from attempting to expand a call of the ~ macro ~x1, ~#2~[if that macro~/which~] was ~ defined with ~x3." (car x) (cadr (cadr x)) (if (member-eq (car x) '(with-live-state when-pass-2)) 0 1) 'defmacro-untouchable)) (t (trans-er+ x ctx "It is illegal to call ~x0 because it has been ~ placed on untouchable-fns." (car x))))) ((eq (car x) 'if) (cond ((stobjp (cadr x) known-stobjs wrld) (trans-er+ x ctx "It is illegal to test on a single-threaded object ~ such as ~x0." (cadr x))) (t (trans-er-let* ((arg1 (translate11 (cadr x) nil (if (eq stobjs-out t) t '(nil)) bindings known-stobjs known-dfs flet-alist x ctx wrld state-vars))) (mv-let (erp2 arg2 bindings2) (trans-er-let* ((arg2 (translate11 (caddr x) nil stobjs-out bindings known-stobjs known-dfs flet-alist x ctx wrld state-vars))) (trans-value arg2)) (cond (erp2 (cond ((eq bindings2 :unknown-bindings) (mv-let (erp3 arg3 bindings) (translate11 (cadddr x) nil stobjs-out bindings known-stobjs known-dfs flet-alist x ctx wrld state-vars) (cond (erp3 (mv erp2 arg2 bindings2)) (t (trans-er-let* ((arg2 (translate11 (caddr x) nil stobjs-out bindings known-stobjs known-dfs flet-alist x ctx wrld state-vars))) (trans-value (fcons-term* 'if arg1 arg2 arg3))))))) (t (mv erp2 arg2 bindings2)))) (t (let ((bindings bindings2)) (trans-er-let* ((arg3 (translate11 (cadddr x) nil stobjs-out bindings known-stobjs known-dfs flet-alist x ctx wrld state-vars))) (trans-value (fcons-term* 'if arg1 arg2 arg3))))))))))) ((and (eq (car x) 'synp) (eql (length x) 4) (eq stobjs-out t)) (mv-let (erp val bindings) (trans-er-let* ((vars0 (translate11 (cadr x) nil '(nil) bindings '(state) nil flet-alist x ctx wrld state-vars)) (user-form0 (translate11 (caddr x) nil '(nil) bindings '(state) nil flet-alist x ctx wrld state-vars)) (term0 (translate11 (cadddr x) nil '(nil) bindings '(state) nil flet-alist x ctx wrld state-vars))) (let ((quoted-vars (if (quotep vars0) vars0 (quote-normal-form vars0))) (quoted-user-form (if (quotep user-form0) user-form0 (quote-normal-form user-form0))) (quoted-term (if (quotep term0) term0 (quote-normal-form term0)))) (cond ((and (quotep quoted-vars) (quotep quoted-user-form) (quotep quoted-term)) (trans-er-let* ((term-to-be-evaluated (translate11 (unquote quoted-term) nil '(nil) bindings '(state) nil flet-alist x ctx wrld state-vars))) (trans-value (fcons-term* 'synp quoted-vars quoted-user-form (kwote term-to-be-evaluated))))) (t (trans-value (fcons-term* 'synp vars0 user-form0 term0)))))) (cond (erp (let ((quoted-user-form-original (caddr x))) (case-match quoted-user-form-original (('quote ('syntaxp form)) (mv erp (msg "The form ~x0, from a ~x1 hypothesis, is ~ not suitable for evaluation in an ~ environment where its variables are bound ~ to terms. See :DOC ~x1. Here is further ~ explanation:~|~t2~@3" form 'syntaxp 5 val) bindings)) (& (mv erp val bindings))))) (t (mv erp val bindings))))) ((eq stobjs-out t) (trans-er-let* ((args (translate11-lst (cdr x) (ilks-per-argument-slot (car x) wrld) t bindings known-stobjs known-dfs nil flet-alist x ctx wrld state-vars))) (trans-value (fcons-term (car x) args)))) ((eq (car x) 'mv-list) (trans-er-let* ((arg1 (translate11 (cadr x) nil stobjs-out bindings known-stobjs known-dfs flet-alist x ctx wrld state-vars))) (cond ((not (and (quotep arg1) (integerp (unquote arg1)) (<= 2 (unquote arg1)))) (trans-er ctx "A call of ~x0 can only be made when the first ~ argument is explicitly an integer that is at ~ least 2. The call ~x1 is thus illegal." 'mv-list x)) (t (trans-er-let* ((arg2 (translate11 (caddr x) nil (make-list (unquote arg1) :initial-element nil) bindings known-stobjs known-dfs flet-alist x ctx wrld state-vars))) (trans-value (fcons-term* 'mv-list arg1 arg2))))))) ((stobj-field-fn-of-stobj-type-p (car x) wrld) (trans-er+ x ctx "It is illegal to call ~x0 because it is a stobj ~ updater or accessor for a field of stobj type. For a ~ way to generate such a call, see :DOC stobj-let." (car x))) ((eq (car x) 'return-last) (let* ((arg1 (nth 1 x)) (arg2 (nth 2 x)) (arg3 (nth 3 x)) (key (and (consp arg1) (eq (car arg1) 'quote) (consp (cdr arg1)) (cadr arg1))) (keyp (and (symbolp key) key))) (trans-er-let* ((targ1 (translate11 arg1 nil '(nil) bindings known-stobjs known-dfs flet-alist x ctx wrld state-vars))) (cond ((and keyp (not (equal targ1 arg1))) (trans-er ctx "Implementation error: We have thought that a ~ quotep must translate to itself, but ~x0 did not!" arg1)) ((eq key 'mbe1-raw) (trans-er-let* ((targ2 (translate11 arg2 nil stobjs-out bindings known-stobjs known-dfs flet-alist x ctx wrld state-vars)) (targ3 (translate11 arg3 nil stobjs-out bindings known-stobjs known-dfs flet-alist x ctx wrld state-vars))) (trans-value (fcons-term* 'return-last targ1 targ2 targ3)))) ((and (eq key 'ec-call1-raw) (not (and (consp arg3) (true-listp arg3) (and (symbolp (car arg3)) (let ((fn (if (function-symbolp (car arg3) wrld) (car arg3) (corresponding-inline-fn (car arg3) wrld)))) (and fn (not (member-eq fn *ec-call-bad-ops*)))))))) (trans-er ctx "The argument ~x0 is illegal for ~x2, because ~@1. ~ A call of ~x2 must only be made on an argument of ~ the form (FN ...), where FN is a known function ~ symbol of the current ACL2 world not belonging to ~ the list that is the value of the constant ~x3, or ~ is a macro expanding in a certain direct way (as ~ with defun-inline) to a call of FN$INLINE (i.e., ~ the result of adding suffix "$INLINE" to the ~ symbol-name of FN). See :DOC ec-call." arg3 (let* ((fn0 (and (consp arg3) (car arg3))) (fn (and fn0 (symbolp fn0) (if (function-symbolp fn0 wrld) fn0 (corresponding-inline-fn fn0 wrld))))) (cond ((not (and fn0 (true-listp arg3))) (msg "~x0 does not have the form of a ~ function call" arg3)) ((not (symbolp fn0)) (msg "~x0 is not a symbol" fn0)) ((member-eq fn *ec-call-bad-ops*) (msg "~x0 belongs to ~x1" fn '*ec-call-bad-ops*)) ((eq (getpropc fn0 'macro-args t wrld) t) (msg "~x0 is not defined" fn0)) (t (msg "~x0 is a macro, not a function ~ symbol~@1" fn0 (let ((sym (deref-macro-name fn0 (macro-aliases wrld)))) (cond ((eq sym fn0) "") (t (msg ". Note that ~x0 is a ~ macro-alias for ~x1 (see ~ :DOC ~ macro-aliases-table), so ~ a solution might be to ~ replace ~x0 by ~x1" fn0 sym)))))))) 'ec-call '*ec-call-bad-ops*)) ((and (eq key 'ec-call1-raw) (not (or (null arg2) (equal arg2 *nil*) (and (true-listp arg2) (= (length arg2) 3) (eq (car arg2) 'cons) (and (qdfs-check (cadr arg2)) (qdfs-check (caddr arg2))))))) (trans-er ctx "The call ~x0 is illegal. It appears to have ~ arisen from an attempt to macroexpand an illegal ~ call of ~x1 or ~x2." x 'ec-call 'ec-call1)) ((and (eq key 'ec-call1-raw) (bad-dfs-in-out arg2 arg3 wrld)) (trans-er ctx "A use of ~x0 on the term ~x1 requires ~#2~[a ~ suitable :DFS-IN keyword argument~/a suitable ~ :DFS-OUT keyword argument~/suitable :DFS-IN and ~ :DFS-OUT keyword arguments~]. See :DOC ec-call." 'ec-call arg3 (let* ((bad-in/bad-out (bad-dfs-in-out arg2 arg3 wrld)) (bad-in (car bad-in/bad-out)) (bad-out (cdr bad-in/bad-out))) (cond ((not bad-out) 0) ((not bad-in) 1) (t 2))))) ((and (eq key 'with-guard-checking1-raw) (or (not (case-match arg2 (('chk-with-guard-checking-arg &) t) (& nil))) (not (case-match arg3 (('translate-and-test gate form) (equal gate (with-guard-checking-gate form))) (& nil)))) (not (global-val 'boot-strap-flg wrld)) (not (ttag wrld))) (trans-er+? cform x ctx "The form ~x0 is essentially a call of ~x1, but ~ without certain checks performed. This is ~ illegal unless there is an active trust tag; see ~ :DOC defttag. To avoid this error without use ~ of a trust tag, call ~x1 directly." x 'with-guard-checking)) ((and keyp (let ((val (or (return-last-lookup key wrld) (and (global-val 'boot-strap-flg wrld) (cdr (assoc-eq key *initial-return-last-table*)))))) (or (null val) (and (consp val) (assoc-eq :stobjs-out bindings))))) (cond ((not (or (return-last-lookup key wrld) (and (global-val 'boot-strap-flg wrld) (cdr (assoc-eq key *initial-return-last-table*))))) (trans-er ctx "The symbol ~x0 is specified in the first ~ argument of the form ~x1. But ~x0 is not ~ associated in the table ~x2 with a non-nil ~ value. See :DOC return-last." key x 'return-last-table)) (t (trans-er ctx "Illegal call, ~x0: the association of ~x1 with ~ the symbol ~x2 has been restricted to avoid ~ top-level evaluation of such calls of ~x3. See ~ :DOC return-last. Also consider placing the ~ offending call inside a call of ~x4; see :DOC ~ ~x4." x key (car (return-last-lookup key wrld)) 'return-last 'top-level)))) (t (mv-let (erp targ2 targ2-bindings) (translate11 arg2 nil '(nil) bindings known-stobjs known-dfs flet-alist x ctx wrld state-vars) (declare (ignore targ2-bindings)) (cond (erp (mv erp targ2 bindings)) ((throw-nonexec-error-p1 targ1 targ2 :non-exec nil) (mv-let (erp targ3 targ3-bindings) (translate11 arg3 nil t bindings nil nil flet-alist x ctx wrld state-vars) (declare (ignore targ3-bindings)) (cond (erp (mv erp targ3 bindings)) (t (trans-value (fcons-term* 'return-last targ1 targ2 targ3)))))) (t (trans-er-let* ((targ3 (translate11 arg3 nil stobjs-out bindings known-stobjs known-dfs flet-alist x ctx wrld state-vars))) (trans-value (fcons-term* 'return-last targ1 targ2 targ3))))))))))) ((and (eq (car x) 'do$) (not (eq (caar bindings) 'do$))) (let* ((quoted-dolia (car (last (fargs x)))) (untrans-do-loop$ (and (true-listp quoted-dolia) (= (length quoted-dolia) 2) (eq (car quoted-dolia) 'quote) (consp (access dolia (unquote quoted-dolia) :untrans-do-loop$)) (eq (car (access dolia (unquote quoted-dolia) :untrans-do-loop$)) 'loop$) (access dolia (unquote quoted-dolia) :untrans-do-loop$)))) (mv-let (erp trans bindings) (if untrans-do-loop$ (translate11 untrans-do-loop$ ilk stobjs-out bindings known-stobjs known-dfs flet-alist cform ctx wrld state-vars) (mv t nil bindings)) (cond ((or erp (not (equal trans (tag-loop$ untrans-do-loop$ x)))) (trans-er ctx "It is illegal to call ~x0 directly in code to be ~ executed (as opposed to theorems), unless that ~ call agrees with the translation of a ~ corresponding ~x1 expression. ~@2 See :DOC ~ loop$." 'do$ 'loop$ (cond ((null untrans-do-loop$) "This call does not have that form.") (t (msg "This call appears to correspond to the ~ expression ~x0, but the translation of ~ that expression ~@1." untrans-do-loop$ (if erp "fails" (msg "is ~x0" trans))))))) (t (trans-value x)))))) ((eq (getpropc (car x) 'non-executablep nil wrld) t) (let ((computed-stobjs-out (compute-stobj-flags (cdr x) known-stobjs known-dfs wrld))) (trans-er-let* ((args (translate11-lst (cdr x) (ilks-per-argument-slot (car x) wrld) computed-stobjs-out bindings known-stobjs known-dfs nil flet-alist x ctx wrld state-vars))) (trans-value (fcons-term (car x) args))))) ((and (member-eq (car x) '(makunbound-global put-global)) (not (eq (access state-vars state-vars :temp-touchable-vars) t)) (or (not (and (consp (cadr x)) (eq (car (cadr x)) 'quote) (null (cddr (cadr x))) (symbolp (cadr (cadr x))))) (and (member-eq (cadr (cadr x)) (global-val 'untouchable-vars wrld)) (not (member-eq (cadr (cadr x)) (access state-vars state-vars :temp-touchable-vars)))) (and (eq (car x) 'makunbound-global) (always-boundp-global (cadr (cadr x)))) (and (global-val 'boot-strap-flg wrld) (not (always-boundp-global (cadr (cadr x))))))) (cond ((not (and (consp (cadr x)) (eq (car (cadr x)) 'quote) (null (cddr (cadr x))) (symbolp (cadr (cadr x))))) (trans-er+ x ctx "The first arg of ~x0 must be a quoted symbol, ~ unlike ~x1. We make this requirement in ~ support of untouchable-vars." (car x) (cadr x))) ((and (member-eq (cadr (cadr x)) (global-val 'untouchable-vars wrld)) (not (member-eq (cadr (cadr x)) (access state-vars state-vars :temp-touchable-vars)))) (trans-er ctx "State global variable ~x0 has been rendered ~ untouchable and thus may not be directly ~ altered, as in ~x1.~@2" (cadr (cadr x)) x (let ((set-fn (intern-in-package-of-symbol (concatenate 'string "SET-" (symbol-name (cadr (cadr x)))) (cadr (cadr x))))) (cond ((function-symbolp set-fn wrld) (msg "~|There is a function ~x0, which ~ (from the name) may provide the ~ functionality you desire." set-fn)) (t ""))))) ((always-boundp-global (cadr (cadr x))) (trans-er ctx "Built-in state global variables may not be made ~ unbound, as in ~x0." x)) (t (trans-er ctx "State global ~x0 needs to be declared for the ~ build by adding it to *initial-global-table*." (cadr (cadr x)))))) (t (let ((stobjs-out (translate-deref stobjs-out bindings)) (stobjs-out2 (let ((temp (translate-deref (car x) bindings))) (cond (temp temp) ((eq (car x) 'do$) (do$-stobjs-out (cdr x))) (t (stobjs-out (car x) wrld)))))) (translate11-call x (car x) (cdr x) stobjs-out stobjs-out2 bindings known-stobjs known-dfs (car x) flet-alist ctx wrld state-vars))))) ((arity (car x) wrld) (trans-er ctx "~x0 takes ~#1~[no arguments~/1 argument~/~x2 arguments~] but ~ in the call ~x3 it is given ~#4~[no arguments~/1 argument~/~x5 ~ arguments~]. The formal parameters list for ~x0 is ~X67." (car x) (zero-one-or-more (arity (car x) wrld)) (arity (car x) wrld) x (zero-one-or-more (length (cdr x))) (length (cdr x)) (formals (car x) wrld) nil)) ((eq (car x) 'declare) (trans-er ctx "It is illegal to use DECLARE as a function symbol, as in ~x0. ~ DECLARE forms are permitted only in very special places, e.g., ~ before the bodies of function definitions, LETs, and MV-LETs. ~ DECLARE forms are never permitted in places in which their ~ ``values'' are relevant. If you already knew this, it is ~ likely you have made a typographical mistake, e.g., including ~ the body in the DECLARE form or closing the superior form ~ before typing the body." x)) (t (let* ((boot-strap-flg (global-val 'boot-strap-flg wrld)) (syms (and (not boot-strap-flg) (macros-and-functions-in-other-packages (car x) wrld)))) (trans-er+ x ctx "The symbol ~x0 (in package ~x1) has neither a function ~ nor macro definition in ACL2. ~#2~[Please define ~ it~@3~/Moreover, this symbol is in the main Lisp package; ~ hence, you cannot define it in ACL2.~] See :DOC ~ near-misses." (car x) (symbol-package-name (car x)) (if (equal (symbol-package-name (car x)) *main-lisp-package-name*) 1 0) (cond ((null syms) ".") ((null (cdr syms)) (msg "; or perhaps you meant ~x0, which has the same ~ name but is in a different package." (car syms))) (t (msg "; or perhaps you meant one of the following, each ~ with the same name but in a different package: ~v0." syms)))))))) (defun translate11-lst-1 (x ilk stobj-out bindings known-stobjs known-dfs msg flet-alist cform ctx wrld state-vars) (cond ((and stobj-out (not (eq stobj-out :df))) (cond ((and (eq x stobj-out) (or (eq known-stobjs t) (member-eq x known-stobjs))) (trans-value x)) ((eq x stobj-out) (let ((known-stobjs (collect-non-x nil known-stobjs))) (trans-er+ cform ctx "The form ~x0 is being used~#1~[ ~/, as an argument to a ~ call of ~x2,~/, ~@2,~] where the single-threaded object ~ of that name is required. But in the current context, ~ ~#3~[there are no declared stobj names~/the only declared ~ stobj name is ~&4~/the only declared stobj names are ~ ~&4~]." x (if (null msg) 0 (if (symbolp msg) 1 2)) msg (cond ((null known-stobjs) 0) ((null (cdr known-stobjs)) 1) (t 2)) known-stobjs))) ((and (symbolp x) (congruent-stobjsp x stobj-out wrld)) (trans-er+ cform ctx "The form ~x0 is being used~#1~[ ~/, as an argument to a ~ call of ~x2,~/, ~@2,~] where the single-threaded object ~x3 ~ was expected, even though these are congruent stobjs. See ~ :DOC defstobj, in particular the discussion of congruent ~ stobjs." x (if (null msg) 0 (if (symbolp msg) 1 2)) msg stobj-out)) (t (trans-er+ cform ctx "The form ~x0 is being used~#1~[ ~/, as an argument to a ~ call of ~x2,~/, ~@2,~] where the single-threaded object ~ ~x3 is required. Note that the variable ~x3 is required, ~ not merely a term that returns such a single-threaded ~ object, so you may need to bind ~x3 with LET; see :DOC ~ stobj." x (if (null msg) 0 (if (symbolp msg) 1 2)) msg stobj-out)))) (t (translate11 x ilk (if stobj-out '(:df) '(nil)) bindings known-stobjs known-dfs flet-alist cform ctx wrld state-vars)))) (defun translate11-lst (lst ilks stobjs-out bindings known-stobjs known-dfs msg flet-alist cform ctx wrld state-vars) (cond ((atom lst) (trans-value nil)) ((eq stobjs-out t) (trans-er-let* ((x (translate11 (car lst) (car ilks) t bindings known-stobjs known-dfs flet-alist (car lst) ctx wrld state-vars)) (y (translate11-lst (cdr lst) (cdr ilks) t bindings known-stobjs known-dfs msg flet-alist cform ctx wrld state-vars))) (trans-value (cons x y)))) (t (trans-er-let* ((x (translate11-lst-1 (car lst) (car ilks) (car stobjs-out) bindings known-stobjs known-dfs msg flet-alist cform ctx wrld state-vars)) (y (translate11-lst (cdr lst) (cdr ilks) (cdr stobjs-out) bindings known-stobjs known-dfs msg flet-alist cform ctx wrld state-vars))) (trans-value (cons x y)))))) (defun translate11-lst/stobjs-out-1 (x bindings known-stobjs known-dfs msg flet-alist cform ctx wrld state-vars) (mv-let (erp1 val1 bindings1) (translate11-lst-1 x nil nil bindings known-stobjs known-dfs msg flet-alist cform ctx wrld state-vars) (cond ((null erp1) (mv nil val1 bindings1 nil)) (t (mv-let (erp2 val2 bindings2) (translate11-lst-1 x nil :df bindings known-stobjs known-dfs msg flet-alist cform ctx wrld state-vars) (cond (erp2 (mv erp1 val1 bindings1 nil)) (t (mv nil val2 bindings2 :df)))))))) (defun translate11-lst/stobjs-out-rec (lst ilks stobjs-out bindings known-stobjs known-dfs msg flet-alist cform ctx wrld state-vars) (cond ((atom lst) (mv nil nil bindings nil)) (t (let ((stobj-out0 (if (eq (car stobjs-out) :df?) (if (car ilks) nil :df?) (car stobjs-out)))) (mv-let (erp val bindings stobj-out) (cond ((eq stobj-out0 :df?) (translate11-lst/stobjs-out-1 (car lst) bindings known-stobjs known-dfs msg flet-alist cform ctx wrld state-vars)) (t (mv-let (erp val bindings) (translate11-lst-1 (car lst) (car ilks) stobj-out0 bindings known-stobjs known-dfs msg flet-alist cform ctx wrld state-vars) (mv erp val bindings stobj-out0)))) (cond (erp (mv erp val bindings 'irrelevant)) (t (mv-let (erp rst bindings stobjs-out) (translate11-lst/stobjs-out-rec (cdr lst) (cdr ilks) (cdr stobjs-out) bindings known-stobjs known-dfs msg flet-alist cform ctx wrld state-vars) (cond (erp (mv erp rst bindings stobjs-out)) (t (mv nil (cons val rst) bindings (cons stobj-out stobjs-out)))))))))))) (defun translate11-lst/stobjs-out (lst ilks stobjs-out bindings known-stobjs known-dfs msg flet-alist cform ctx wrld state-vars) (cond ((member-eq :df? stobjs-out) (translate11-lst/stobjs-out-rec lst ilks stobjs-out bindings known-stobjs known-dfs msg flet-alist cform ctx wrld state-vars)) (t (mv-let (erp val bindings) (translate11-lst lst ilks stobjs-out bindings known-stobjs known-dfs msg flet-alist cform ctx wrld state-vars) (mv erp val bindings stobjs-out))))))
translate11-lambda-object-proxy-builtinfunction
(defun translate11-lambda-object-proxy-builtin (x stobjs-out bindings known-stobjs flet-alist cform ctx wrld state-vars allow-counterfeitsp) (translate11-lambda-object x stobjs-out bindings known-stobjs flet-alist cform ctx wrld state-vars allow-counterfeitsp))
other
(defattach (translate11-lambda-object-proxy translate11-lambda-object-proxy-builtin) :skip-checks t)
translate1-cmp+function
(defun translate1-cmp+ (x stobjs-out bindings known-stobjs known-dfs ctx w state-vars) (trans-er-let* ((result (translate11 x nil stobjs-out bindings known-stobjs known-dfs nil x ctx w state-vars))) (cond ((and bindings (null (cdr bindings)) (symbolp (caar bindings)) (eq (caar bindings) (cdar bindings))) (trans-value result (translate-bind (caar bindings) '(nil) bindings))) (t (trans-value result)))))
translate1-cmpfunction
(defun translate1-cmp (x stobjs-out bindings known-stobjs ctx w state-vars) (translate1-cmp+ x stobjs-out bindings known-stobjs nil ctx w state-vars))
other
(defun@par translate1 (x stobjs-out bindings known-stobjs ctx w state) (cmp-and-value-to-error-quadruple@par (translate1-cmp x stobjs-out bindings known-stobjs ctx w (default-state-vars t)) "Translate"))
logic-fnspmutual-recursion
(mutual-recursion (defun logic-fnsp (term wrld) (declare (xargs :guard (and (plist-worldp wrld) (pseudo-termp term)))) (cond ((variablep term) t) ((fquotep term) t) ((flambdap (ffn-symb term)) (and (logic-fnsp (lambda-body (ffn-symb term)) wrld) (logic-fns-listp (fargs term) wrld))) ((programp (ffn-symb term) wrld) nil) (t (logic-fns-listp (fargs term) wrld)))) (defun logic-fns-listp (lst wrld) (declare (xargs :guard (and (plist-worldp wrld) (pseudo-term-listp lst)))) (cond ((endp lst) t) (t (and (logic-fnsp (car lst) wrld) (logic-fns-listp (cdr lst) wrld))))))
logic-termpfunction
(defun logic-termp (x wrld) (declare (xargs :guard (plist-worldp-with-formals wrld))) (and (termp x wrld) (logic-fnsp x wrld)))
logic-term-listpfunction
(defun logic-term-listp (x w) (declare (xargs :guard (plist-worldp-with-formals w))) (and (term-listp x w) (logic-fns-listp x w)))
logic-fns-list-listpfunction
(defun logic-fns-list-listp (x wrld) (declare (xargs :guard (and (plist-worldp wrld) (pseudo-term-list-listp x)))) (cond ((endp x) t) (t (and (logic-fns-listp (car x) wrld) (logic-fns-list-listp (cdr x) wrld)))))
logic-term-list-listpfunction
(defun logic-term-list-listp (x w) (declare (xargs :guard (plist-worldp-with-formals w))) (and (term-list-listp x w) (logic-fns-list-listp x w)))
translate-cmpfunction
(defun translate-cmp (x stobjs-out logic-modep known-stobjs ctx w state-vars) (mv-let (erp val bindings) (translate1-cmp x stobjs-out nil known-stobjs ctx w state-vars) (declare (ignore bindings)) (cond (erp (mv erp val)) ((and logic-modep (not (logic-fnsp val w))) (er-cmp ctx "Function symbols of mode :program are not allowed ~ in the present context. Yet, the function ~ symbol~#0~[ ~&0 occurs~/s ~&0 occur~] in the ~ translation of the form~|~% ~x1,~%~%which is~|~% ~ ~x2." (collect-programs (all-fnnames val) w) x val)) (t (value-cmp val)))))
other
(defun@par translate (x stobjs-out logic-modep known-stobjs ctx w state) (cmp-to-error-triple@par (translate-cmp x stobjs-out logic-modep known-stobjs ctx w (default-state-vars t)) "Translate"))
translatable-pfunction
(defun translatable-p (form stobjs-out bindings known-stobjs ctx wrld) (mv-let (erp val bindings) (translate1-cmp form stobjs-out bindings known-stobjs ctx wrld (default-state-vars nil)) (declare (ignore val bindings)) (null erp)))
chk-translatablemacro
(defmacro chk-translatable (form shape) `(translate-and-test (lambda (qform) (cond ((translatable-p (cadr qform) ',(COND ((EQ SHAPE 'STATE) '(STATE)) (T (CDR SHAPE))) nil t 'chk-translatable world) t) (t (msg "IO? was given the following body, which fails to ~ translate for the expected shape, STATE:~|~ ~y0" ',FORM)))) ',FORM))
loop$-stobjs-outfunction
(defun loop$-stobjs-out (loop$-expr trans) (case-match trans (('return-last ''progn & ('do$ . &)) (mv-let (erp parse) (parse-loop$ loop$-expr) (cond ((or erp (not (eq (car parse) 'do))) (er hard! 'loop$-stobjs-out "Implementation error: Unexpected failure to parse ~x0 ~ expression that translated to a call of ~x1:~|~x2." 'loop$ 'do$ loop$-expr)) (t (or (nth 3 parse) '(nil)))))) (& '(nil))))
replaced-stobjfunction
(defun replaced-stobj (name) (if (eq name 'state) 'replaced-state (packn (list 'replaced- name))))
replace-stobjs1function
(defun replace-stobjs1 (stobjs-out val) (cond ((endp val) val) ((and (car stobjs-out) (not (eq (car stobjs-out) :df))) (cons (replaced-stobj (car stobjs-out)) (replace-stobjs1 (cdr stobjs-out) (cdr val)))) (t (cons (car val) (replace-stobjs1 (cdr stobjs-out) (cdr val))))))
replace-stobjsfunction
(defun replace-stobjs (stobjs-out val) (cond ((null stobjs-out) val) ((null (cdr stobjs-out)) (cond ((and (car stobjs-out) (not (eq (car stobjs-out) :df))) (replaced-stobj (car stobjs-out))) (t val))) (t (replace-stobjs1 stobjs-out val))))
user-stobjspfunction
(defun user-stobjsp (stobjs-out) (cond ((endp stobjs-out) nil) ((or (null (car stobjs-out)) (eq (car stobjs-out) :df) (eq (car stobjs-out) 'state)) (user-stobjsp (cdr stobjs-out))) (t t)))
put-assoc-eq-alistfunction
(defun put-assoc-eq-alist (alist1 alist2) (declare (xargs :guard (and (symbol-alistp alist1) (symbol-alistp alist2)) :measure (len alist2))) (cond ((endp alist2) alist1) ((equal alist2 alist1) alist1) (t (put-assoc-eq-alist (put-assoc-eq (caar alist2) (cdar alist2) alist1) (cdr alist2)))))
collect-user-stobjsfunction
(defun collect-user-stobjs (stobjs-out) (cond ((endp stobjs-out) nil) ((or (null (car stobjs-out)) (eq (car stobjs-out) :df) (eq (car stobjs-out) 'state)) (collect-user-stobjs (cdr stobjs-out))) (t (cons (car stobjs-out) (collect-user-stobjs (cdr stobjs-out))))))
filter-known-stobjsfunction
(defun filter-known-stobjs (vars known-stobjs wrld) (declare (xargs :guard (and (symbol-listp vars) (symbol-listp known-stobjs) (plist-worldp wrld)))) (cond ((endp vars) nil) ((stobjp (car vars) known-stobjs wrld) (cons (car vars) (filter-known-stobjs (cdr vars) known-stobjs wrld))) (t (filter-known-stobjs (cdr vars) known-stobjs wrld))))
chk-global-stobjsfunction
(defun chk-global-stobjs (term mvp user-stobjs-out ctx state) (let ((vars (all-vars term))) (cond ((not (member-eq 'state vars)) (value nil)) (t (let* ((wrld (w state)) (stobj-vars (filter-known-stobjs vars t wrld))) (cond ((and (null stobj-vars) (null user-stobjs-out)) (value nil)) (t (mv-let (reads writes fns-seen) (collect-global-stobjs term wrld nil nil nil) (declare (ignore fns-seen)) (cond ((intersectp-eq stobj-vars writes) (er soft ctx "Illegal top-level form, ~x0.~|The stobj~#1~[ ~&1 ~ occurs~/~&1s occur~] free, yet~#1~[~/ each~] may be bound ~ by an updating WITH-GLOBAL-STOBJ form, ~@2~@3" (if mvp (maybe-convert-to-mv (untranslate term nil wrld)) (untranslate term nil wrld)) (intersection-eq stobj-vars writes) (let* ((upd t) (st (car (intersection-eq stobj-vars writes))) (path (path-to-with-global-stobj st (all-fnnames term) upd wrld nil nil))) (with-global-stobj-illegal-path-msg "as the top-level form calls" "" path st upd wrld)) *see-doc-with-global-stobj*)) ((or (intersectp-eq user-stobjs-out reads) (intersectp-eq user-stobjs-out writes)) (er soft ctx "Illegal top-level form, ~x0.~|The stobj~#1~[ ~&1 is~/~&1s ~ are~] returned by evaluation of that form, yet ~#1~[~/each ~ ~]is bound by a WITH-GLOBAL-STOBJ form, ~@2~@3" (untranslate term nil wrld) (intersection-eq user-stobjs-out (append? reads writes)) (let* ((upd nil) (st (car (or (intersection-eq user-stobjs-out reads) (intersection-eq user-stobjs-out writes)))) (path (path-to-with-global-stobj st (all-fnnames term) upd wrld nil nil))) (with-global-stobj-illegal-path-msg "as the top-level form calls" "" path st upd wrld)) *see-doc-with-global-stobj*)) (t (value nil)))))))))))
ev-for-trans-evalfunction
(defun ev-for-trans-eval (trans stobjs-out ctx state aok user-stobjs-modified-warning) (let* ((user-stobj-alist (user-stobj-alist state)) (alist (cons (cons 'state (coerce-state-to-object state)) user-stobj-alist)) (user-stobjs (collect-user-stobjs stobjs-out))) (er-progn (chk-global-stobjs trans (consp (cdr stobjs-out)) user-stobjs ctx state) (mv-let (erp val latches) (ev trans alist state alist nil aok) (pprogn (coerce-object-to-state (cdr (car latches))) (cond (user-stobjs (pprogn (update-user-stobj-alist (put-assoc-eq-alist (user-stobj-alist state) (cdr latches)) state) (cond (user-stobjs-modified-warning (warning$ ctx "User-stobjs-modified" "A call of the ACL2 evaluator on the term ~x0 may ~ have modified the user stobj~#1~[~/s~] ~&1. See ~ :DOC user-stobjs-modified-warnings." trans user-stobjs)) (t state)))) (t state)) (cond (erp (error1 ctx "Evaluation" (car val) (cdr val) state)) (t (mv nil (cons stobjs-out (replace-stobjs stobjs-out val)) state))))))))
macroexpand1*function
(defun macroexpand1* (x ctx wrld state) (cmp-to-error-triple (macroexpand1*-cmp x ctx wrld (default-state-vars t))))
trans-eval1function
(defun trans-eval1 (term stobjs-out ctx wrld state aok user-stobjs-modified-warning) (let* ((vars (all-vars term)) (unknown-stobj-names (unknown-stobj-names vars t wrld)) (non-global-stobj-names (and (null unknown-stobj-names) (remove1 'state (set-difference-assoc-eq vars (user-stobj-alist state)))))) (cond (unknown-stobj-names (er soft ctx "Global variables, such as ~&0, are not allowed. See :DOC ASSIGN ~ and :DOC @." (reverse unknown-stobj-names))) (non-global-stobj-names (er soft ctx "Non-global stobj names, such as ~&0, are not allowed. See :DOC ~ add-global-stobj." (reverse non-global-stobj-names))) (t (ev-for-trans-eval term stobjs-out ctx state aok user-stobjs-modified-warning)))))
trans-eval0function
(defun trans-eval0 (form ctx state aok user-stobjs-modified-warning) (let ((wrld (w state))) (er-let* ((form (macroexpand1* form ctx wrld state))) (cond ((and (consp form) (eq (car form) 'if) (true-listp form) (equal (length form) 4)) (let ((simple-stobjs-out '(nil))) (er-let* ((arg0 (translate (cadr form) simple-stobjs-out nil t ctx wrld state)) (val0 (trans-eval1 arg0 simple-stobjs-out ctx wrld state aok user-stobjs-modified-warning))) (if (cdr val0) (trans-eval0 (caddr form) ctx state aok user-stobjs-modified-warning) (trans-eval0 (cadddr form) ctx state aok user-stobjs-modified-warning))))) (t (mv-let (erp trans bindings state) (translate1 form :stobjs-out '((:stobjs-out . :stobjs-out)) t ctx wrld state) (cond (erp (mv t nil state)) (t (trans-eval1 trans (translate-deref :stobjs-out bindings) ctx wrld state aok user-stobjs-modified-warning)))))))))
trans-evalfunction
(defun trans-eval (form ctx state aok) (trans-eval0 form ctx state aok t))
trans-eval-no-warningfunction
(defun trans-eval-no-warning (form ctx state aok) (trans-eval0 form ctx state aok nil))
trans-eval-default-warningfunction
(defun trans-eval-default-warning (form ctx state aok) (trans-eval0 form ctx state aok (f-get-global 'ld-user-stobjs-modified-warning state)))
tagged-loop$pfunction
(defun tagged-loop$p (term) (declare (xargs :guard (and (nvariablep term) (not (fquotep term))))) (and (eq (ffn-symb term) 'return-last) (equal (fargn term 1) ''progn) (quotep (fargn term 2)) (consp (unquote (fargn term 2))) (eq (car (unquote (fargn term 2))) 'loop$)))
collect-certain-tagged-loop$smutual-recursion
(mutual-recursion (defun collect-certain-tagged-loop$s (flg term ans) (cond ((variablep term) ans) ((fquotep term) ans) ((tagged-loop$p term) (cond ((eq flg :all) (collect-certain-tagged-loop$s flg (fargn term 3) (add-to-set-equal term ans))) (t (add-to-set-equal term ans)))) ((throw-nonexec-error-p term :non-exec nil) ans) ((flambda-applicationp term) (collect-certain-tagged-loop$s flg (lambda-body (ffn-symb term)) (collect-certain-tagged-loop$s-lst flg (fargs term) ans))) (t (collect-certain-tagged-loop$s-lst flg (fargs term) ans)))) (defun collect-certain-tagged-loop$s-lst (flg terms ans) (cond ((endp terms) ans) (t (collect-certain-tagged-loop$s flg (car terms) (collect-certain-tagged-loop$s-lst flg (cdr terms) ans))))))
eliminate-lambda$mutual-recursion
(mutual-recursion (defun eliminate-lambda$ (term wrld) (cond ((variablep term) term) ((fquotep term) (let ((x (unquote term))) (cond ((and (well-formed-lambda-objectp x wrld) (lambda$-bodyp (lambda-object-body x))) (let* ((formals (lambda-object-formals x)) (dcl (lambda-object-dcl x)) (xbody (eliminate-lambda$ (fargn (lambda-object-body x) 3) wrld)) (guardp (assoc-keyword :guard (cdr (assoc-eq 'xargs (cdr dcl))))) (xguard (if guardp (eliminate-lambda$ (cadr guardp) wrld) nil)) (xdcl (if guardp (cons 'declare (put-assoc-eq 'xargs `(:guard ,XGUARD :split-types t) (cdr dcl))) nil))) (list 'quote (make-lambda-object formals xdcl xbody)))) (t term)))) ((flambdap (ffn-symb term)) (fcons-term `(lambda ,(LAMBDA-FORMALS (FFN-SYMB TERM)) ,(ELIMINATE-LAMBDA$ (LAMBDA-BODY (FFN-SYMB TERM)) WRLD)) (eliminate-lambda$-lst (fargs term) wrld))) (t (fcons-term (ffn-symb term) (eliminate-lambda$-lst (fargs term) wrld))))) (defun eliminate-lambda$-lst (terms wrld) (cond ((endp terms) nil) (t (cons (eliminate-lambda$ (car terms) wrld) (eliminate-lambda$-lst (cdr terms) wrld))))))
tilde-@-lambda$-replacement-phrase1function
(defun tilde-@-lambda$-replacement-phrase1 (lst wrld) (cond ((endp lst) nil) (t (cons (msg "replace~%~X02 by~%~X12" (unquote (fargn (lambda-object-body (car lst)) 2)) (eliminate-lambda$ (kwote (car lst)) wrld) nil) (tilde-@-lambda$-replacement-phrase1 (cdr lst) wrld)))))
tilde-*-lambda$-replacement-phrase2function
(defun tilde-*-lambda$-replacement-phrase2 (lst wrld) (list "" "~@*~%" "~@*~%~%and~%~%" "~@*~%" (tilde-@-lambda$-replacement-phrase1 lst wrld)))
tilde-@-lambda$-replacement-phrase3function
(defun tilde-@-lambda$-replacement-phrase3 (caller lst wrld) (msg "In ~s0:~%~*1" caller (tilde-*-lambda$-replacement-phrase2 lst wrld)))
tilde-@-lambda$-replacement-phrase4function
(defun tilde-@-lambda$-replacement-phrase4 (alist wrld) (cond ((endp alist) nil) (t (cons (tilde-@-lambda$-replacement-phrase3 (car (car alist)) (cdr (car alist)) wrld) (tilde-@-lambda$-replacement-phrase4 (cdr alist) wrld)))))
tilde-*-lambda$-replacement-phrase5function
(defun tilde-*-lambda$-replacement-phrase5 (alist wrld) (list "" "~@*~%~%" "~@*~%~%" "~@*~%~%" (tilde-@-lambda$-replacement-phrase4 alist wrld)))
simple-translate-and-evalfunction
(defun simple-translate-and-eval (x alist ok-stobj-names msg ctx wrld state aok) (er-let* ((term (translate x '(nil) nil t ctx wrld state))) (let ((vars (all-vars term)) (legal-vars (append (strip-cars alist) ok-stobj-names))) (cond ((not (subsetp-eq vars legal-vars)) (er soft ctx "~@0 may contain ~#1~[no variables~/only the ~ variable ~&2~/only the variables ~&2~], but ~ ~x3 contains ~&4." msg (cond ((null legal-vars) 0) ((null (cdr legal-vars)) 1) (t 2)) legal-vars x (reverse vars))) (t (let ((ancestral-lambda$s (and (not (quotep term)) (f-get-global 'safe-mode state) (ancestral-lambda$s-by-caller "this event" term wrld)))) (cond ((null ancestral-lambda$s) (mv-let (erp val latches) (ev term (append alist (cons (cons 'state (coerce-state-to-object state)) (user-stobj-alist state))) state nil nil aok) (declare (ignore latches)) (cond (erp (mv-let (erp0 val0 state) (er-soft ctx "Translate" "~@0" val) (declare (ignore erp0 val0)) (er-soft ctx "Translate" "~@0 could not be evaluated." msg))) (t (value (cons term val)))))) (t (er-soft ctx "Translate" "~@0" (prohibition-of-loop$-and-lambda$-msg ancestral-lambda$s))))))))))
error-fms-cwfunction
(defun error-fms-cw (hardp ctx summary str alist) (wormhole 'comment-window-io '(lambda (whs) (set-wormhole-entry-code whs :enter)) (list hardp ctx summary str alist) `(let ((hardp (nth 0 (@ wormhole-input))) (ctx (nth 1 (@ wormhole-input))) (str (nth 2 (@ wormhole-input))) (summary (nth 3 (@ wormhole-input))) (alist (nth 4 (@ wormhole-input)))) (pprogn (error-fms hardp ctx summary str alist state) (value :q))) :ld-error-action :error :ld-verbose nil :ld-pre-eval-print nil :ld-prompt nil))
simple-translate-and-eval-cmpfunction
(defun simple-translate-and-eval-cmp (x alist ok-stobj-names msg ctx wrld state aok safe-mode gc-off) (er-let*-cmp ((term (translate-cmp x '(nil) nil t ctx wrld (default-state-vars t)))) (let ((vars (all-vars term)) (legal-vars (append (strip-cars alist) ok-stobj-names))) (cond ((not (subsetp-eq vars legal-vars)) (er-cmp ctx "~@0 may contain ~#1~[no variables~/only the variable ~ ~&2~/only the variables ~&2~], but ~x3 contains ~&4." msg (cond ((null legal-vars) 0) ((null (cdr legal-vars)) 1) (t 2)) legal-vars x (reverse vars))) (t (mv-let (erp val) (ev-w term (append alist (cons (cons 'state (coerce-state-to-object state)) (user-stobj-alist state))) (w state) (user-stobj-alist state) safe-mode gc-off nil aok) (cond (erp (prog2$ (and (not (member-eq 'error (f-get-global 'inhibit-output-lst state))) (error-fms-cw nil ctx nil (car val) (cdr val))) (er-cmp ctx "~@0 could not be evaluated." msg))) (t (value-cmp (cons term val))))))))))
simple-translate-and-eval-error-doublefunction
(defun simple-translate-and-eval-error-double (x alist ok-stobj-names msg ctx wrld state aok safe-mode gc-off) (cmp-to-error-double (simple-translate-and-eval-cmp x alist ok-stobj-names msg ctx wrld state aok safe-mode gc-off)))
tilde-*-alist-phrase1function
(defun tilde-*-alist-phrase1 (alist evisc-tuple level) (cond ((null alist) nil) (t (cons (msg "~t0~s1 : ~Y23~|" level (caar alist) (cdar alist) evisc-tuple) (tilde-*-alist-phrase1 (cdr alist) evisc-tuple level)))))
tilde-*-alist-phrasefunction
(defun tilde-*-alist-phrase (alist evisc-tuple level) (list "" "~@*" "~@*" "~@*" (tilde-*-alist-phrase1 alist evisc-tuple level)))
set-temp-touchable-fnsfunction
(defun set-temp-touchable-fns (x state) (cond ((or (eq x t) (symbol-listp x)) (f-put-global 'temp-touchable-fns x state)) (t (prog2$ (er hard 'set-temp-touchable-fns "The first argument to ~x0 may must be either ~x1 or a ~ true list of symbols, unlike:~| ~x2" 'set-temp-touchable-fns t x) state))))
set-temp-touchable-varsfunction
(defun set-temp-touchable-vars (x state) (cond ((or (eq x t) (symbol-listp x)) (f-put-global 'temp-touchable-vars x state)) (t (prog2$ (er hard 'set-temp-touchable-vars "The first argument to ~x0 may must be either ~x1 or a ~ true list of symbols, unlike:~| ~x2" 'set-temp-touchable-vars t x) state))))
clear-temp-touchable-fnsfunction
(defun clear-temp-touchable-fns (state) (f-put-global 'temp-touchable-fns nil state))
clear-temp-touchable-varsfunction
(defun clear-temp-touchable-vars (state) (f-put-global 'temp-touchable-vars nil state))
mapcar$function
(defun mapcar$ (fn l state) (cond ((null l) (value nil)) (t (er-let* ((ans (trans-eval (list fn (list 'quote (car l))) 'mapcar$ state t)) (rst (mapcar$ fn (cdr l) state))) (value (cons (cdr ans) rst))))))
mapdofunction
(defun mapdo (fn l state) (cond ((null l) (value nil)) (t (er-let* ((ans (trans-eval (list fn (list 'quote (car l))) 'mapdo state t)) (rst (mapdo fn (cdr l) state))) (value nil)))))
alwaysfunction
(defun always (fn l state) (cond ((null l) (value t)) (t (er-let* ((ans (trans-eval (list fn (list 'quote (car l))) 'always state t))) (cond ((null (cdr ans)) (value nil)) (t (always fn (cdr l) state)))))))
thereisfunction
(defun thereis (fn l state) (cond ((null l) (value nil)) (t (er-let* ((ans (trans-eval (list fn (list 'quote (car l))) 'thereis state t))) (cond ((cdr ans) (value l)) (t (thereis fn (cdr l) state)))))))
other
(set-table-guard guard-msg-table (and (symbolp key) (or (null val) (termp val world))) :topic set-guard-msg)
set-guard-msgmacro
(defmacro set-guard-msg (fn form) (declare (xargs :guard (symbolp fn))) `(table guard-msg-table ',FN (mv-let (erp term bindings) (translate1-cmp ',FORM '(nil) nil t 'set-guard-msg world (default-state-vars nil)) (declare (ignore bindings)) (prog2$ (and erp (er hard! erp "~@0" term)) term))))
other
(set-guard-msg the-check (msg "The object ~x0 does not satisfy the type declaration ~ ~x1.~@2" (nth 2 args) (nth 1 args) coda))
other
(set-guard-msg the-check-for-*1* (msg "The object ~x0 does not satisfy the type declaration ~x1 ~ for bound variable ~x2.~@3" (nth 2 args) (nth 1 args) (nth 3 args) coda))
other
(set-guard-msg check-dcl-guardian (if (and (consp (cadr args)) (eq (car (cadr args)) 'setq) (consp (caddr (cadr args))) (eq (car (caddr (cadr args))) 'the)) (msg "The type-spec on ~x0, which was ~x1, was violated by ~ ~x2.~@3" (cadr (cadr args)) (cadr (caddr (cadr args))) `(setq ,(CADR (CADR ARGS)) ,(UNTRANSLATE (CADDR (CADDR (CADR ARGS))) NIL WORLD)) coda) (msg "The guard condition ~x0, which was generated from a ~ type declaration, has failed.~@1" (untranslate (cadr args) t world) coda)))
other
(set-guard-msg fmx-cw-fn (msg "Guard violation for ~x0:~|~@1" 'fmx-cw-fn (let ((str (nth 0 args)) (alist (nth 1 args))) (fmx-cw-msg str alist))))
other
(set-guard-msg fmx!-cw-fn (msg "Guard violation for ~x0:~|~@1" 'fmx!-cw-fn (let ((str (nth 0 args)) (alist (nth 1 args))) (fmx-cw-msg str alist))))
other
(set-guard-msg add-invisible-fns (msg "The call ~x0 is illegal, because the arguments are not ~ all symbols. See :DOC add-invisible-fns." (cons 'add-invisible-fns args)))
other
(set-guard-msg remove-invisible-fns (msg "The call ~x0 is illegal, because the arguments are not ~ all symbols. See :DOC remove-invisible-fns." (cons 'remove-invisible-fns args)))
sublis-equalfunction
(defun sublis-equal (alist tree) (declare (xargs :guard (alistp alist))) (let ((pair (assoc-equal tree alist))) (if pair (cdr pair) (if (atom tree) tree (cons (sublis-equal alist (car tree)) (sublis-equal alist (cdr tree)))))))
*type-spec-templates*constant
(defconst *type-spec-templates* '(integer (integer -3 *) (integer * 5) (integer -3 5) rational real complex (rational -1/7 *) (rational * 1/11) (rational -1/7 1/11) (real -1/7 *) (real * 1/11) (real -1/7 1/11) bit atom character cons list null ratio standard-char string (string 2) symbol t))
pair-type-expressions-with-type-specsfunction
(defun pair-type-expressions-with-type-specs (tplist subs qsubs keys-seen wrld) (declare (xargs :mode :program)) (cond ((endp tplist) nil) (t (let ((g (translate-declaration-to-guard (car tplist) 'var wrld))) (mv-let (erp val bindings) (translate1-cmp g t nil nil 'trans-to-type wrld (default-state-vars nil)) (declare (ignore bindings)) (cond (erp (er hard 'type-expressions "Unable to translate to type expression:~|~x0" g)) (t (let* ((new-key (sublis-equal qsubs val)) (new-key-seen (member-equal new-key keys-seen)) (rest (pair-type-expressions-with-type-specs (cdr tplist) subs qsubs (if new-key-seen keys-seen (cons new-key keys-seen)) wrld))) (cond (new-key-seen rest) (t (acons new-key (sublis subs (car tplist)) rest)))))))))))