From 16be51f61801c021d75679720e950dd5498652ac Mon Sep 17 00:00:00 2001
From: Keshav Kini
Examples:
@({ - (defpointer acl2 acl2-sedan) + (defpointer acl2s acl2-sedan) (defpointer guard-hints xargs t) }) From 5988770b6dafb56fc0163788bd3a0a20c355d6f9 Mon Sep 17 00:00:00 2001 From: "David L. Rager"The book \"clause-processors/use-by-hint\" now contains an additional
From 958989fbf6e898ca61b178b1579502b7e36f4ce5 Mon Sep 17 00:00:00 2001
From: "David L. Rager"
ACL2 sometimes omits the checking of @(see guard)s on recursive + calls of functions. This omission is signaled by a message like the one shown + below.
+ + @({ + ACL2 !>(factorial 3) + + ACL2 Warning [Guards] in TOP-LEVEL: Guard-checking will be inhibited + for some recursive calls for FACTORIAL and perhaps other functions; + see :DOC guard-checking-inhibited. + + 6 + ACL2 !> + }) + +More precisely, the warning is printed only when guard-checking is the + default, @('t') (see @(see set-guard-checking)) and guards are not verified + for the indicated function. No further such message is printed (for any + function) before the next top-level form is submitted.
+ +To check guards on all recursive calls:
+ + @({ + (set-guard-checking :all) + }) + +To leave the current behavior unchanged except for inhibiting such + messages:
+ + @({ + (set-guard-checking :nowarn) + })") + (defxdoc guard-debug :parents (guard debugging) :short "Generate markers to indicate sources of @(see guard) proof obligations" @@ -76488,6 +76524,11 @@ it." ; some error messages related to :do-not-induct. Thanks to a query from Eric ; Smith that led to these changes. +; Cleaned up handling of raw-guard-warningp, including: now a state global +; instead of a Lisp special, modified warning message, added :doc +; guard-checking-inhibited, and cleared raw-guard-warningp in a simple way for +; each top level form (in ld-read-eval-print). + :parents (release-notes) :short "ACL2 Version 7.5 (xxx, 20xx) Notes" :long "NOTE! New users can ignore these release notes, because the @(see
diff --git a/doc.lisp b/doc.lisp
index e790a27b511..a998fdc7388 100644
--- a/doc.lisp
+++ b/doc.lisp
@@ -28429,7 +28429,13 @@ Subtopics
[guards-and-evaluation], for a discussion of guards and their
connection to evaluation. Advanced system hackers who want to see
the executable-counterpart definition for f may invoke (trace!
- (oneify-cltl-code :native t)) before defining f in ACL2.")
+ (oneify-cltl-code :native t)) before defining f in ACL2.
+
+
+Subtopics
+
+ [Guard-checking-inhibited]
+ Evaluating ACL2 expressions")
(EVALUATOR-RESTRICTIONS
(META)
"Some restrictions on the use of evaluators in meta-level rules
@@ -36705,6 +36711,9 @@ Subtopics
[Extra-info]
Sources of measure or guard proof obligations
+ [Guard-checking-inhibited]
+ Evaluating ACL2 expressions
+
[Guard-debug]
Generate markers to indicate sources of [guard] proof obligations
@@ -36796,6 +36805,37 @@ Subtopics
[With-guard-checking-event]
Suppress or enable guard-checking for an event form")
+ (GUARD-CHECKING-INHIBITED
+ (EVALUATION GUARD)
+ "Evaluating ACL2 expressions
+
+ ACL2 sometimes omits the checking of [guard]s on recursive calls of
+ functions. This omission is signaled by a message like the one
+ shown below.
+
+ ACL2 !>(factorial 3)
+
+ ACL2 Warning [Guards] in TOP-LEVEL: Guard-checking will be inhibited
+ for some recursive calls for FACTORIAL and perhaps other functions;
+ see :DOC guard-checking-inhibited.
+
+ 6
+ ACL2 !>
+
+ More precisely, the warning is printed only when guard-checking is
+ the default, t (see [set-guard-checking]) and guards are not
+ verified for the indicated function. No further such message is
+ printed (for any function) before the next top-level form is
+ submitted.
+
+ To check guards on all recursive calls:
+
+ (set-guard-checking :all)
+
+ To leave the current behavior unchanged except for inhibiting such
+ messages:
+
+ (set-guard-checking :nowarn)")
(GUARD-DEBUG
(GUARD DEBUGGING)
"Generate markers to indicate sources of [guard] proof obligations
diff --git a/futures-raw.lisp b/futures-raw.lisp
index 50daf02e495..87e76c54436 100644
--- a/futures-raw.lisp
+++ b/futures-raw.lisp
@@ -1208,7 +1208,7 @@
; Parallelism no-fix: we have considered causing child threads to inherit
; ld-specials from their parents, or even other state globals such as
-; *ev-shortcut-okp* and *raw-guard-warningp*, as the following comment from
+; *ev-shortcut-okp* and raw-guard-warningp, as the following comment from
; David Rager suggests. But this now seems too difficult to justify that
; effort, and we do not feel obligated to do so; see the "IMPORTANT NOTE" in
; :doc parallelism.
diff --git a/interface-raw.lisp b/interface-raw.lisp
index ca6d20f2732..7ec121d70c2 100644
--- a/interface-raw.lisp
+++ b/interface-raw.lisp
@@ -1616,17 +1616,14 @@
(t nil))))
(get-declared-stobjs (cdr edcls)))))
-(defun-one-output warn-for-guard-body (fn)
- (assert$ (boundp '*raw-guard-warningp*)
- (setq *raw-guard-warningp* nil))
- (let ((state *the-live-state*))
- (warning$ 'top-level "Guards"
- "Guard-checking will be inhibited on recursive calls of the ~
- executable-counterpart (i.e., in the ACL2 logic) of ~x0. To ~
- check guards on all recursive calls:~% (set-guard-checking ~
- :all)~%To leave behavior unchanged except for inhibiting this ~
- message:~% (set-guard-checking :nowarn)"
- fn)))
+(defun maybe-warn-for-guard-body (fn state)
+ (assert$ (f-get-global 'raw-guard-warningp state)
+ (pprogn (f-put-global 'raw-guard-warningp nil state)
+ (warning$ 'top-level "Guards"
+ "Guard-checking will be inhibited for some ~
+ recursive calls, including ~x0; see :DOC ~
+ guard-checking-inhibited."
+ fn))))
(defun-one-output create-live-user-stobjp-test (stobjs)
(if (endp stobjs)
@@ -2358,9 +2355,10 @@
(return-from ,*1*fn ,*1*body)))))
(and (and labels-can-miss-guard
(not trace-rec-for-none)) ; else skip labels form
- `((when (and *raw-guard-warningp*
+ `((when (and (f-get-global 'raw-guard-warningp
+ *the-live-state*)
(eq ,guard-checking-on-form t))
- (warn-for-guard-body ',fn))))))
+ (maybe-warn-for-guard-body ',fn *the-live-state*))))))
(*1*-body-forms
(cond ((eq defun-mode :program)
(append
diff --git a/ld.lisp b/ld.lisp
index dab47ba20b5..970309e6906 100644
--- a/ld.lisp
+++ b/ld.lisp
@@ -1058,6 +1058,7 @@
(pprogn (f-put-global 'trace-level 0 state)
(print-deferred-ttag-notes-summary state)))
(t state))
+ (f-put-global 'raw-guard-warningp t state)
(mv-let
(col state)
(if (and (eql (f-get-global 'in-verify-flg state) 1)
diff --git a/translate.lisp b/translate.lisp
index b91072c6aa4..4429e118c92 100644
--- a/translate.lisp
+++ b/translate.lisp
@@ -271,14 +271,6 @@
(t latches)))
(t (latch-stobjs1 stobjs-out vals latches))))
-#-acl2-loop-only
-; We deliberately do not assign a value for the following. It is let-bound in
-; ev and friends and assigned during the evaluation of *1* functions. If we
-; call *1* functions directly in raw Lisp, we will presumably get an
-; unbound-variable error, but at least that will call our attention to the fact
-; that it should be bound before calling *1* functions.
-(defvar *raw-guard-warningp*)
-
(defun actual-stobjs-out1 (stobjs-in args user-stobj-alist)
(cond ((endp stobjs-in)
(assert$ (null args) nil))
@@ -1069,35 +1061,6 @@
(untranslate-preprocess-fn ,wrld)
,wrld))
-#-acl2-loop-only
-(defmacro raw-guard-warningp-binding ()
-
-; We bind *raw-guard-warningp* in calls of ev-fncall, ev, ev-lst, ev-w,
-; ev-w-lst, and ev-fncall-w. The initial binding is t if guard-checking is on,
-; else nil. When a *1* function is poised to call warn-for-guard-body to print
-; a warning related to guard violations, it first checks that
-; *raw-guard-warningp*. Hence, we do not want to re-assign this variable once
-; it is bound to nil by warn-for-guard-body, because we only want to see the
-; corresponding guard warning once per top-level evaluation. We do however
-; want to re-assign this variable from t to nil once the warning has been
-; printed and also if guard-checking has been turned off, in particular for the
-; situation involving the prover that is described in the next paragraph. (But
-; if guard-checking were, surprisingly, to transition instead from nil to t,
-; and we failed to re-assign this variable from nil to t, we could live with
-; that.)
-
-; Note that *raw-guard-warningp* will be bound to t just under the trans-eval
-; at the top level. If we then enter the prover we will bind guard-checking-on
-; to nil, and we then want to re-bind *raw-guard-warningp* to nil if we enter
-; ev-fncall during the proof, so that the proof output will not contain guard
-; warning messages. (This was handled incorrectly in Version_2.9.1.)
-
- '(if (and (boundp '*raw-guard-warningp*)
- (null *raw-guard-warningp*))
- nil
- (eq (f-get-global 'guard-checking-on *the-live-state*)
- t)))
-
(defun save-ev-fncall-guard-er (fn guard stobjs-in args)
(wormhole-eval 'ev-fncall-guard-er-wormhole
'(lambda (whs)
@@ -2460,9 +2423,6 @@
(defun ev-fncall-rec (fn args w user-stobj-alist big-n safe-mode gc-off latches
hard-error-returns-nilp aok)
-
-; WARNING: This function should only be called with *raw-guard-warningp* bound.
-
(declare (xargs :guard (plist-worldp w)))
#-acl2-loop-only
(cond (*ev-shortcut-okp*
@@ -2606,8 +2566,6 @@
(defun ev-rec (form alist w user-stobj-alist big-n safe-mode gc-off latches
hard-error-returns-nilp aok)
-; WARNING: This function should only be called with *raw-guard-warningp* bound.
-
; See also ev-respecting-ens.
; Note: Latches includes a binding of 'state. See the Essay on EV.
@@ -2791,9 +2749,6 @@
(defun ev-rec-lst (lst alist w user-stobj-alist big-n safe-mode gc-off latches
hard-error-returns-nilp aok)
-
-; WARNING: This function should only be called with *raw-guard-warningp* bound.
-
(declare (xargs :guard (and (plist-worldp w)
(term-listp lst w)
(symbol-alistp alist))))
@@ -2826,8 +2781,6 @@
safe-mode gc-off latches
hard-error-returns-nilp aok)
-; WARNING: This function should only be called with *raw-guard-warningp* bound.
-
; Sketch: We know that form is a termp wrt w and that it is recognized by
; translated-acl2-unwind-protectp. We therefore unpack it into its body and
; two cleanup forms and give it special attention. If the body evaluates
@@ -3064,8 +3017,7 @@
; Keep the two ev-fncall-rec calls below in sync.
#-acl2-loop-only
- (let ((*ev-shortcut-okp* t)
- (*raw-guard-warningp* (raw-guard-warningp-binding)))
+ (let ((*ev-shortcut-okp* t))
(state-free-global-let*
((safe-mode safe-mode)
(guard-checking-on
@@ -3128,8 +3080,7 @@
; See the comment in ev for why we don't check the time limit here.
#-acl2-loop-only
- (let ((*ev-shortcut-okp* t)
- (*raw-guard-warningp* (raw-guard-warningp-binding)))
+ (let ((*ev-shortcut-okp* t))
(state-free-global-let*
((safe-mode safe-mode)
(guard-checking-on
@@ -3648,8 +3599,7 @@
(defun ev-fncall (fn args state latches hard-error-returns-nilp aok)
(declare (xargs :guard (state-p state)))
- (let #-acl2-loop-only ((*ev-shortcut-okp* (live-state-p state))
- (*raw-guard-warningp* (raw-guard-warningp-binding)))
+ (let #-acl2-loop-only ((*ev-shortcut-okp* (live-state-p state)))
#+acl2-loop-only ()
; See the comment in ev for why we don't check the time limit here.
@@ -3669,8 +3619,7 @@
(declare (xargs :guard (and (state-p state)
(termp form (w state))
(symbol-alistp alist))))
- (let #-acl2-loop-only ((*ev-shortcut-okp* (live-state-p state))
- (*raw-guard-warningp* (raw-guard-warningp-binding)))
+ (let #-acl2-loop-only ((*ev-shortcut-okp* (live-state-p state)))
#+acl2-loop-only ()
; At one time we called time-limit5-reached-p here so that we can quit if we
@@ -3703,8 +3652,7 @@
(declare (xargs :guard (and (state-p state)
(term-listp lst (w state))
(symbol-alistp alist))))
- (let #-acl2-loop-only ((*ev-shortcut-okp* (live-state-p state))
- (*raw-guard-warningp* (raw-guard-warningp-binding)))
+ (let #-acl2-loop-only ((*ev-shortcut-okp* (live-state-p state)))
#+acl2-loop-only ()
; See the comment in ev for why we don't check the time limit here.
@@ -3801,8 +3749,7 @@
; See the comment in ev for why we don't check the time limit here.
#-acl2-loop-only
- (let ((*ev-shortcut-okp* t)
- (*raw-guard-warningp* (raw-guard-warningp-binding)))
+ (let ((*ev-shortcut-okp* t))
(state-free-global-let*
((safe-mode safe-mode)
(guard-checking-on
From 85cadb39a816d2a523912c0e8b385ddaf45364ac Mon Sep 17 00:00:00 2001
From: Keshav Kini
This is a simple macro that expands to a @(see defxdoc) form. It introduces a new @(see xdoc) topic, @('new-topic'), that merely links to @('target-topic'). The new topic will only be listed under @(see -pointers).
") +pointers). + +A common practice when documenting keyword symbols is to create a +doc topic in in the \"ACL2\" package or some other relevant package, +rather than the \"KEYWORD\" package to which the keyword symbol +rightfully belongs. In keeping with this practice, the @('keywordp') +argument to @('defpointer'), if non-nil, adds a clarification that the +doc topic is really about the keyword symbol with the same name as +@('new-topic'), rather than @('new-topic') itself.
") (defxdoc add-resource-directory From 25deb4f55c4831d5f23c6e250da25c548d40de3d Mon Sep 17 00:00:00 2001 From: Keshav KiniNOTE! New users can ignore these release notes, because the @(see @@ -76792,6 +76795,23 @@ it." especially for his contributions to a fix through helpful conversations and by providing code and examples.
+The built-in evaluator functions for ACL2 relied on a system function, + @('ev-fncall-w'), that was not a function! We do not see how to exploit this + oddity to prove @('nil'), since @('ev-fncall-w') is guaranteed never to be in + @(see logic) mode. However, it is clearly undesirable. In the following + example, the two @('ev-fncall-w') calls gave different answers on the same + inputs — @('(mv nil 7)') and @('(mv nil 12)') — but now the second + call results in an error.
+ + @({ + (defun foo (x y) (+ x y)) + (assign old-w (w state)) + (ev-fncall-w 'foo '(3 4) (@ old-w) nil nil nil t nil) + (u) + (defun foo (x y) (* x y)) + (ev-fncall-w 'foo '(3 4) (@ old-w) nil nil nil t nil) + }) +The check for the requisite theorems supporting a @(tsee defabsstobj) event
included a case where the check was too weak, and it also could cause an
unexpected assertion. The first of these could probably cause unsoundness.
diff --git a/defuns.lisp b/defuns.lisp
index 62d73f8be4e..469c753ec7d 100644
--- a/defuns.lisp
+++ b/defuns.lisp
@@ -1825,7 +1825,9 @@
; Sol Swords sent an example in which a clause-processor failed during a
; termination proof. That problem goes away if we install the world, which we
-; do by making the following binding.
+; do by making the following binding. This seems particularly important now
+; that raw-ev-fncall calls chk-raw-ev-fncall to ensure that the world is
+; (essentially) installed.
t ; formerly big-mutrec
wrld1))
diff --git a/doc.lisp b/doc.lisp
index a998fdc7388..e4608bff3ca 100644
--- a/doc.lisp
+++ b/doc.lisp
@@ -75492,6 +75492,21 @@ Bug Fixes
especially for his contributions to a fix through helpful
conversations and by providing code and examples.
+ The built-in evaluator functions for ACL2 relied on a system
+ function, ev-fncall-w, that was not a function! We do not see how
+ to exploit this oddity to prove nil, since ev-fncall-w is
+ guaranteed never to be in [logic] mode. However, it is clearly
+ undesirable. In the following example, the two ev-fncall-w calls
+ gave different answers on the same inputs --- (mv nil 7) and (mv
+ nil 12) --- but now the second call results in an error.
+
+ (defun foo (x y) (+ x y))
+ (assign old-w (w state))
+ (ev-fncall-w 'foo '(3 4) (@ old-w) nil nil nil t nil)
+ (u)
+ (defun foo (x y) (* x y))
+ (ev-fncall-w 'foo '(3 4) (@ old-w) nil nil nil t nil)
+
The check for the requisite theorems supporting a [defabsstobj] event
included a case where the check was too weak, and it also could
cause an unexpected assertion. The first of these could probably
diff --git a/history-management.lisp b/history-management.lisp
index 7857a0ba9de..02944b41c60 100644
--- a/history-management.lisp
+++ b/history-management.lisp
@@ -3547,6 +3547,7 @@
(t (f-put-global 'current-package "ACL2" state))))
#-acl2-loop-only
(cond ((live-state-p state)
+ (setf (car *fncall-cache*) nil)
(cond ((and *wormholep*
(not (eq wrld (w *the-live-state*))))
(push-wormhole-undo-formi 'cloaked-set-w! (w *the-live-state*)
diff --git a/translate.lisp b/translate.lisp
index 4429e118c92..cb5f5f98ea4 100644
--- a/translate.lisp
+++ b/translate.lisp
@@ -405,124 +405,6 @@
nil)
-#-acl2-loop-only
-(defun raw-ev-fncall (fn args latches w user-stobj-alist
- hard-error-returns-nilp aok)
- (the #+acl2-mv-as-values (values t t t)
- #-acl2-mv-as-values t
- (let* ((*aokp*
-
-; We expect the parameter aok, here and in all functions in the "ev family"
-; that take aok as an argument, to be Boolean. If it's not, then there is no
-; real harm done: *aokp* would be bound here to a non-Boolean value, suggesting
-; that an attachment has been used when that isn't necessarily the case; see
-; *aokp*.
-
- aok)
- (pair (assoc-eq 'state latches))
- (w (if pair (w (cdr pair)) w)) ; (cdr pair) = *the-live-state*
- (throw-raw-ev-fncall-flg t)
- (**1*-as-raw*
-
-; We defeat the **1*-as-raw* optimization so that when we use raw-ev-fncall to
-; evaluate a call of a :logic mode term, all of the evaluation will take place
-; in the logic. Note that we don't restrict this special treatment to
-; :common-lisp-compliant functions, because such a function might call an
-; :ideal mode function wrapped in ec-call. But we do restrict to :logic mode
-; functions, since they cannot call :program mode functions and hence there
-; cannot be a subsidiary rebinding of **1*-as-raw* to t.
-
- (if (logicp fn w)
- nil
- **1*-as-raw*))
- (*1*fn (*1*-symbol fn))
- (applied-fn (cond
- ((fboundp *1*fn) *1*fn)
- ((and (global-val 'boot-strap-flg w)
- (not (global-val 'boot-strap-pass-2 w)))
- fn)
- (t
- (er hard 'raw-ev-fncall
- "We had thought that *1* functions were ~
- always defined outside the first pass of ~
- initialization, but the *1* function for ~
- ~x0, which should be ~x1, is not."
- fn *1*fn))))
- (stobjs-out
- (cond ((eq fn 'return-last)
-
-; Things can work out fine if we imagine that return-last returns a single
-; value: in the case of (return-last ... (mv ...)), the mv returns a list and
-; we just pass that along.
-
- '(nil))
-; The next form was originally conditionalized with #+acl2-extra-checks, but we
-; want to do this unconditionally.
- (latches ; optimization
- (actual-stobjs-out fn args w user-stobj-alist))
- (t (stobjs-out fn w))))
- (val (catch 'raw-ev-fncall
- (cond ((not (fboundp fn))
- (er hard 'raw-ev-fncall
- "A function, ~x0, that was supposed to be ~
- defined is not. Supposedly, this can only ~
- arise because of aborts during undoing. ~
- There is no recovery from this erroneous ~
- state."
- fn)))
- (prog1
- (let ((*hard-error-returns-nilp*
- hard-error-returns-nilp))
- #-acl2-mv-as-values
- (apply applied-fn args)
- #+acl2-mv-as-values
- (cond ((null (cdr stobjs-out))
- (apply applied-fn args))
- (t (multiple-value-list
- (apply applied-fn args)))))
- (setq throw-raw-ev-fncall-flg nil))))
-
-; It is important to rebind w here, since we may have updated state since the
-; last binding of w.
-
- (w (if pair
-
-; We use the live state now if and only if we used it above, in which case (cdr
-; pair) = *the-live-state*.
-
- (w (cdr pair))
- w)))
-
-; Observe that if a throw to 'raw-ev-fncall occurred during the
-; (apply fn args) then the local variable throw-raw-ev-fncall-flg
-; is t and otherwise it is nil. If a throw did occur, val is the
-; value thrown.
-
- (cond
- (throw-raw-ev-fncall-flg
- (mv t (ev-fncall-msg val w user-stobj-alist) latches))
- (t #-acl2-mv-as-values ; adjust val for the multiple value case
- (let ((val
- (cond
- ((null (cdr stobjs-out)) val)
- (t (cons val
- (mv-refs (1- (length stobjs-out))))))))
- (mv nil
- val
-; The next form was originally conditionalized with #+acl2-extra-checks, with
-; value latches when #-acl2-extra-checks; but we want this unconditionally.
- (latch-stobjs stobjs-out ; adjusted to actual-stobjs-out
- val
- latches)))
- #+acl2-mv-as-values ; val already adjusted for multiple value case
- (mv nil
- val
-; The next form was originally conditionalized with #+acl2-extra-checks, with
-; value latches when #-acl2-extra-checks; but we want this unconditionally.
- (latch-stobjs stobjs-out ; adjusted to actual-stobjs-out
- val
- latches)))))))
-
(defun translated-acl2-unwind-protectp4 (term)
; This hideous looking function recognizes those terms that are the
@@ -2033,8 +1915,214 @@
(cadr x)))
(t (list 'not x))))
+(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)))
+
+#-acl2-loop-only
+(progn
+
+(defvar *fncall-cache*
+ '(nil))
+
+(defun raw-ev-fncall-okp (wrld aokp &aux (w-state (w *the-live-state*)))
+ (when (eq wrld w-state)
+ (return-from raw-ev-fncall-okp :live))
+ (let* ((fncall-cache *fncall-cache*)
+ (cached-w (car *fncall-cache*)))
+ (cond ((and wrld
+ (eq wrld cached-w))
+ t)
+ (t
+ (let ((fns nil))
+ (loop for tail on wrld
+ until (eq tail w-state)
+ do (let ((trip (car tail)))
+ (cond
+ ((member-eq (cadr trip)
+ '(unnormalized-body
+ stobjs-out
+
+; 'Symbol-class supports the programp call in ev-fncall-guard-er-msg.
+
+ symbol-class
+ table-alist))
+ (setq fns (add-to-set-eq (car trip) fns)))
+ ((and (eq (car trip) 'guard-msg-table)
+ (eq (cadr trip) 'table-alist))
+
+; The table, guard-msg-table, is consulted in ev-fncall-guard-er-msg.
+
+ (return-from raw-ev-fncall-okp nil))
+ ((and (eq (car trip) 'event-landmark)
+ (eq (cadr trip) 'global-value))
+
+; This case is due to the get-event call in guard-raw.
+
+ (setq fns
+ (union-eq (event-tuple-fn-names (cddr trip))
+ fns)))
+ ((and aokp
+ (eq (car trip) 'attachment-records)
+ (eq (cadr trip) 'global-value))
+ (return-from raw-ev-fncall-okp nil))))
+ finally
+ (cond (tail (setf (car fncall-cache) nil
+ (cdr fncall-cache) fns
+ (car fncall-cache) wrld))
+ (t (return-from raw-ev-fncall-okp nil)))))
+ t)
+ (t nil))))
+
+(defun chk-raw-ev-fncall (fn wrld aokp)
+ (let ((ctx 'raw-ev-fncall)
+ (okp (raw-ev-fncall-okp wrld aokp)))
+ (cond ((eq okp :live) nil)
+ (okp
+ (when (member-eq fn (cdr *fncall-cache*))
+ (er hard ctx
+ "Implementation error: Unexpected call of raw-ev-fncall for ~
+ function ~x0 (the world is sufficiently close to (w state) ~
+ in general, but not for that function symbol)."
+ fn)))
+ (t
+ (er hard ctx
+ "Implementation error: Unexpected call of raw-ev-fncall (the ~
+ world is not sufficiently close to (w state)).")))))
+
+(defun raw-ev-fncall (fn args latches w user-stobj-alist
+ hard-error-returns-nilp aok)
+
+; Here we assume that w is "close to" (w state), as implemented by
+; chk-raw-ev-fncall.
+
+ (the #+acl2-mv-as-values (values t t t)
+ #-acl2-mv-as-values t
+ (let* ((*aokp*
+
+; We expect the parameter aok, here and in all functions in the "ev family"
+; that take aok as an argument, to be Boolean. If it's not, then there is no
+; real harm done: *aokp* would be bound here to a non-Boolean value, suggesting
+; that an attachment has been used when that isn't necessarily the case; see
+; *aokp*.
+
+ aok)
+ (pair (assoc-eq 'state latches))
+ (w (if pair (w (cdr pair)) w)) ; (cdr pair) = *the-live-state*
+ (throw-raw-ev-fncall-flg t)
+ (**1*-as-raw*
+
+; We defeat the **1*-as-raw* optimization so that when we use raw-ev-fncall to
+; evaluate a call of a :logic mode term, all of the evaluation will take place
+; in the logic. Note that we don't restrict this special treatment to
+; :common-lisp-compliant functions, because such a function might call an
+; :ideal mode function wrapped in ec-call. But we do restrict to :logic mode
+; functions, since they cannot call :program mode functions and hence there
+; cannot be a subsidiary rebinding of **1*-as-raw* to t.
+
+ (if (logicp fn w)
+ nil
+ **1*-as-raw*))
+ (*1*fn (*1*-symbol fn))
+ (applied-fn (cond
+ ((fboundp *1*fn) *1*fn)
+ ((and (global-val 'boot-strap-flg w)
+ (not (global-val 'boot-strap-pass-2 w)))
+ fn)
+ (t
+ (er hard 'raw-ev-fncall
+ "We had thought that *1* functions were ~
+ always defined outside the first pass of ~
+ initialization, but the *1* function for ~
+ ~x0, which should be ~x1, is not."
+ fn *1*fn))))
+ (stobjs-out
+ (cond ((eq fn 'return-last)
+
+; Things can work out fine if we imagine that return-last returns a single
+; value: in the case of (return-last ... (mv ...)), the mv returns a list and
+; we just pass that along.
+
+ '(nil))
+; The next form was originally conditionalized with #+acl2-extra-checks, but we
+; want to do this unconditionally.
+ (latches ; optimization
+ (actual-stobjs-out fn args w user-stobj-alist))
+ (t (stobjs-out fn w))))
+ (val (catch 'raw-ev-fncall
+ (chk-raw-ev-fncall fn w aok)
+ (cond ((not (fboundp fn))
+ (er hard 'raw-ev-fncall
+ "A function, ~x0, that was supposed to be ~
+ defined is not. Supposedly, this can only ~
+ arise because of aborts during undoing. ~
+ There is no recovery from this erroneous ~
+ state."
+ fn)))
+ (prog1
+ (let ((*hard-error-returns-nilp*
+ hard-error-returns-nilp))
+ #-acl2-mv-as-values
+ (apply applied-fn args)
+ #+acl2-mv-as-values
+ (cond ((null (cdr stobjs-out))
+ (apply applied-fn args))
+ (t (multiple-value-list
+ (apply applied-fn args)))))
+ (setq throw-raw-ev-fncall-flg nil))))
+
+; It is important to rebind w here, since we may have updated state since the
+; last binding of w.
+
+ (w (if pair
+
+; We use the live state now if and only if we used it above, in which case (cdr
+; pair) = *the-live-state*.
+
+ (w (cdr pair))
+ w)))
+
+; Observe that if a throw to 'raw-ev-fncall occurred during the
+; (apply fn args) then the local variable throw-raw-ev-fncall-flg
+; is t and otherwise it is nil. If a throw did occur, val is the
+; value thrown.
+
+ (cond
+ (throw-raw-ev-fncall-flg
+ (mv t (ev-fncall-msg val w user-stobj-alist) latches))
+ (t #-acl2-mv-as-values ; adjust val for the multiple value case
+ (let ((val
+ (cond
+ ((null (cdr stobjs-out)) val)
+ (t (cons val
+ (mv-refs (1- (length stobjs-out))))))))
+ (mv nil
+ val
+; The next form was originally conditionalized with #+acl2-extra-checks, with
+; value latches when #-acl2-extra-checks; but we want this unconditionally.
+ (latch-stobjs stobjs-out ; adjusted to actual-stobjs-out
+ val
+ latches)))
+ #+acl2-mv-as-values ; val already adjusted for multiple value case
+ (mv nil
+ val
+; The next form was originally conditionalized with #+acl2-extra-checks, with
+; value latches when #-acl2-extra-checks; but we want this unconditionally.
+ (latch-stobjs stobjs-out ; adjusted to actual-stobjs-out
+ val
+ latches)))))))
+)
+
(mutual-recursion
+; These functions assume that the input world is "close to" the installed
+; world, (w *the-live-state*), since ultimately they typically lead to calls of
+; the check chk-raw-ev-fncall within raw-ev-fncall.
+
; Here we combine what may naturally be thought of as two separate
; mutual-recursion nests: One for evaluation and one for untranslate. However,
; functions in the ev nest call untranslate1 for error messages, and
From 622a9f9bd0ee216a937f9204a8033be44024c45f Mon Sep 17 00:00:00 2001
From: Matt Kaufmann