1 ;;; -*- Mode: LISP; Package: (SCREAMER :USE CL :COLON-MODE :EXTERNAL); Base: 10; Syntax: Ansi-common-lisp -*-
3 ;;; LaHaShem HaAretz U'Mloah
6 ;;; A portable efficient implementation of nondeterministic CommonLisp
11 ;;; Jeffrey Mark Siskind (Department of Computer Science, University of Toronto)
12 ;;; David Allen McAllester (MIT Artificial Intelligence Laboratory)
14 ;;; Copyright 1991 Massachusetts Institute of Technology. All rights reserved.
15 ;;; Copyright 1992, 1993 University of Pennsylvania. All rights reserved.
16 ;;; Copyright 1993 University of Toronto. All rights reserved.
18 ;;; Permission is hereby granted, free of charge, to any person obtaining a copy of
19 ;;; this software and associated documentation files (the "Software"), to deal in
20 ;;; the Software without restriction, including without limitation the rights to
21 ;;; use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
22 ;;; the Software, and to permit persons to whom the Software is furnished to do so,
23 ;;; subject to the following conditions:
25 ;;; The above copyright and authorship notice and this permission notice shall be
26 ;;; included in all copies or substantial portions of the Software.
28 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
29 ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
30 ;;; FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
31 ;;; COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
32 ;;; IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
33 ;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
35 ;;; Important notice: In this version of Screamer, if Screamer is already
36 ;;; loaded and you wish to recompile the entire file, the recompilation will
37 ;;; proceed much faster if you first do:
38 ;;; (CLRHASH SCREAMER::*FUNCTION-RECORD-TABLE*)
42 ;;; 2. Should have way of having a stream of values.
43 ;;; 3. Kashket's constraint additions Fall90-158.
44 ;;; 4. Compress trail after repeated LOCAL SETF/SETQ to same variable
45 ;;; 5. LOCAL SETF/SETQ on symbol can use special variable binding stack
46 ;;; instead of unwind-protect.
47 ;;; 6. (F (G (H (EITHER X Y)))) where F, G and H are deterministic can
48 ;;; CPS-CONVERT to (FUNCALL #'(LAMBDA (Z) (F (G (H Z)))) (EITHER X Y)).
49 ;;; 7. Should give warning when it recompiles functions due to changing
50 ;;; determinism status.
51 ;;; 8. =V <V <=V >V and >=V should do congruence/monotone closure.
52 ;;; 9. =V should propagate domains.
54 ;;; 11. Should cache VARIABLE-LOWER-BOUND/VARIABLE-UPPER-BOUND for domain
56 ;;; 12. Faster version of BIND! which doesn't cons.
57 ;;; 13. Get DIAGNOSIS and MONTAGUE to work.
58 ;;; 14. Get GROW-UP and NONLINEAR examples to work.
59 ;;; 15. FUNCALLV and APPLYV need to assert the domains of the variable that
61 ;;; 16. Check that +V, -V, *V, /V, MINV and MAXV work and do the right thing
62 ;;; with type propagation.
63 ;;; 17. Check that PROPAGATE does the right thing with bounds of integers.
64 ;;; 18. MEMBERV and derivatives should support vectors.
65 ;;; 19. Backtracking out of INTEGER-BETWEENV and the like will yield an
66 ;;; unconstrained variable since the constraints are asserted locally.
69 ;;; 1. LOCAL SETF does the wrong thing with GETHASH.
70 ;;; 2. LOCAL (SETF/SETQ X e) will signal an error if X is unbound because it
71 ;;; needs to trail the previous value of X and it has none.
72 ;;; 3. Deterministic/nondeterministic LOCAL SETF/SETQ undone out of order.
73 ;;; 4. Changing determinism status can cause code from a different file to
74 ;;; be included causing wierd behavior.
75 ;;; 5. Will signal an obscure error if FAIL is called in a deterministic
76 ;;; context which is not nested in a choice point.
77 ;;; 6. May loop when expressions contain circular lists.
78 ;;; 7. APPLY-NONDETERMINISTIC conses.
81 ;;; 1. Does not handle SETF methods with multiple values for LOCAL SETF.
82 ;;; 2. If you do a (SETF (SYMBOL-FUNCTION 'FOO) ...) to a nondeterministic
83 ;;; function you will lose when you attempt to evaluate (FOO ...).
84 ;;; 3. If you do a (SETF (SYMBOL-FUNCTION 'FOO) ...) to a deterministic
85 ;;; function when FOO was previously defined as a nondeterministic
86 ;;; function you will lose when you attempt to evaluate (FOO ...).
87 ;;; 4. The function record table will not work if we ever support FLET and
88 ;;; LABELS and in particular, if we ever support FLET and LABELS of
89 ;;; nondeterministic functions.
90 ;;; 5. There is no way to force Screamer into compiling a deterministic
91 ;;; function as a nondeterministic one. A wizard might want to do this to
92 ;;; take advantage of the fact that a LOCAL SETF/SETQ in a nondeterministic
93 ;;; function does not cons up closures.
94 ;;; 6. Doesn't handle most CommonLisp special forms.
102 ;;; MULTIPLE-VALUE-CALL
103 ;;; MULTIPLE-VALUE-PROG1
110 ;;; Probably will never handle:
127 ;;; WITH-ADDED-METHODS
132 ;;; Changed the who calls database code to fix the bug whereby after loading
133 ;;; the definition of a nondeterministic function FOO
134 ;;; (ALL-VALUES (FOO ...)) would not work because FOO would not be recognized
135 ;;; as nondeterministic until at least one DEFUN was expanded. In the process
136 ;;; changed the OLD/NEW-DETERMINISTIC? terminology.
138 ;;; Fixed the bug whereby a function FOO which referenced #'BAR or
139 ;;; #'(LAMBDA (...) ... (BAR ...) ...) would not be recompiled when the
140 ;;; deterministic status of BAR changed. This involved a polarity switch on
141 ;;; NESTED?. This also fixed the bug whereby STATIC-ORDERING and REORDER were
142 ;;; incorrectly classified as nondeterministic.
144 ;;; Made SOLUTION walk its argument.
146 ;;; Separated USE-PACKAGE from IN-PACKAGE.
148 ;;; Added *SCREAMER-VERSION*. Set it to 2.1
150 ;;; Added FLIP. Changed EITHER to a macro which expands into FLIP. Expunged
151 ;;; from the code walker, any notion of EITHER being a special form. Removed
152 ;;; the optimization that inline expanded calls to FAIL. Version 2.2.
154 ;;; Fixed bug in VARIABLES-IN. Version 2.3.
156 ;;; Added COUNT-FAILURES. Version 2.4.
158 ;;; Added :SCREAMER to *FEATURES* at the request of CGDEMARC. Version 2.5.
160 ;;; Fixed bug with FUTURE-COMMON-LISP on Symbolics with SETF, FUNCTION and
161 ;;; LAMBDA. Version 2.6.
163 ;;; Fixed INTEGER-BETWEEN to work correctly with noninteger arguments.
164 ;;; Removed SUBST form of Beta-conversion. Version 2.7.
166 ;;; Changed -NOT- to -NOTV- naming convention to be consistent.
167 ;;; Changed INTEGERV to INTEGERPV, REALV to REALPV, NUMBERV to NUMBERPV and
168 ;;; BOOLEANV to BOOLEANPV to be consistent.
169 ;;; Can now walk EVAL-WHEN, FLET, LABELS, PROGV and THE.
170 ;;; Can now CPS convert THE. Also added types to CPS conversion.
171 ;;; Added WHEN-FAILING and rewrote COUNT-FAILURES.
176 ;;; Fixed PROCESS-SUBFORMS to fix bug whereby it didn't correctly walk
177 ;;; EVAL-WHEN, FLET and LABELS.
178 ;;; Fixed DEFUN FUNCTION-NAME to support RETURN-FROM FUNCTION-NAME in its
179 ;;; body for both deterministic and nondeterministic cases.
180 ;;; Fixed PEAL-OFF-DOCUMENTATION-STRING-AND-DECLARATIONS to not consider a
181 ;;; lone string in the body as a documentation string.
184 ;;; Removed redundant "Improper form" error.
185 ;;; Changed all ''NIL and 'NIL to NIL.
186 ;;; Reorganized FORM-TYPEs.
187 ;;; Changed CONSTANT to QUOTE.
188 ;;; Aesthetic capitalization of ALLOW-OTHER-KEYS.
189 ;;; Renamed BLOCK to SEGMENT to be consistent.
190 ;;; Added SELF-EVALUATING? and QUOTIFY and changed processing of QUOTE and
192 ;;; Enforce non-NIL function names.
193 ;;; Added SCREAMER? argument to WALK.
194 ;;; Allow FLET/LABELS to bind SETF functions.
197 ;;; Built new mechanism to determine when to recompile functions due to
198 ;;; changing determinism status to solve a long standing bug.
199 ;;; PERFORM-SUBSTITUTIONS had a call to itself rather than a FUNCALL to
201 ;;; Removed redundant check for NEEDS-SUBSTITUTION? in CPS-CONVERT since that
202 ;;; was checked by PERFORM-SUBSTITUTION anyway.
203 ;;; Made the check performed by NEEDS-SUBSTITUTION? tighter so that fewer
204 ;;; needless macro expansions take place for deterministic DEFUNs.
206 ;;; M6Apr92, T7Apr92, R9Apr92, M13Apr92 Qobi
207 ;;; Changed DEFUN-COMPILE-TIME to compile functions.
208 ;;; Fixed bug in CPS-CONVERT introduced by QUOTE change.
209 ;;; Fixed polarity bug of FUNCTION-LAMBDA in NEEDS-SUBSTITUTION?
210 ;;; Got rid of POSITIVE/NEGATIVE-INFINITY and (OR RATIONAL FLOAT) bogosity.
211 ;;; Changed rules to use (NOT (VARIABLE? X)) instead of prior bogosity.
212 ;;; Fixed fence-post error in trail unwinding.
213 ;;; Added UNWIND-TRAIL.
214 ;;; Added COST-FUNCTION and PREDICATE parameters to REORDER
215 ;;; Fixed bug in DOMAIN-SIZE.
216 ;;; Added RANGE-SIZE.
217 ;;; Moved consistency checks to ends of rules to fix a bug.
218 ;;; Removed unsound type propagation from rules relating to Gaussian integers.
219 ;;; Changed naming conventions: MIN->LOWER-BOUND, MAX->UPPER-BOUND.
220 ;;; Added fuzzy comparisons to bounds restrictions.
221 ;;; Added *MINIMUM-SHRINK-RATIO*.
222 ;;; Moved type consistency checks in ASSERT!-INTEGERPV etc. to beginning.
223 ;;; Removed all fuzziness except for RANGE-SIZE. Fuzzy noninteger-real
224 ;;; variables no longer dereference. REORDER cost function must now return
225 ;;; non-NIL value for a variable to be forced.
226 ;;; Fixed =-RULE to `support' complex numbers.
227 ;;; Fixed CHECK-MEMBERV-RESTRICTION to check for groundness rather than
229 ;;; Fixed RESTRICT-UPPER/LOWER-BOUND! and ASSERT!-INTEGERPV to have integer
230 ;;; bounds for integer variables fixing (INTEGER-BETWEENV 2.1 2.2) problem.
231 ;;; Added RESTRICT-BOUNDS!
232 ;;; Differentiated up versus down rules.
235 ;;; Added NECESSARILY? and FOR-EFFECTS.
236 ;;; Changed MAP-VALUES to accept multiple forms.
237 ;;; Changed PRINT-VALUES and ALL-VALUES to use new version of MAP-VALUES.
238 ;;; Changed all &BODY BODY to &BODY FORMS.
241 ;;; Changed failure strategy for INTEGER-BETWEEN and MEMBER-OF.
242 ;;; Removed (DECLARE (IGNORE FORM)) from NEEDS-SUBSTITUTION?.
243 ;;; Removed MAP-VALUES and changed all callers to use FOR-EFFECTS.
244 ;;; Added AN-INTEGER, INTEGER-ABOVE, INTEGER-BELOW, A-REALV and AN-INTEGERV.
245 ;;; Changed LINEAR-FORCE to no longer require that an integer variable have
247 ;;; Fixed CPS conversion of TAGBODY so that CPS converted code always
248 ;;; evaluates to NIL.
249 ;;; Redid dependency calculations yet again to fix a latent bug.
250 ;;; Removed error messages so that now can RETURN-FROM or GO to deterministic
251 ;;; code from nondeterministic code wrapped in a FOR-EFFECTS but not in a
255 ;;; Fixed a bug in the redone dependency calculations.
258 ;;; Fixed a bug in CHECK-MEMBERV-RESTRICTION that prevented BIND! to a
259 ;;; variable. Wrapped FORMS in PROGN in ALL-VALUES and PRINT-VALUES to fix a
260 ;;; bug introduced by the elimination of MAP-VALUES.
263 ;;; Redid fix for CHECK-MEMBERV-RESTRICTION. Fixed a bug in dependency
264 ;;; calculations so that mutually recursive nondeterministic functions can
265 ;;; become deterministic. Also fixed bug so that macroexpand without compile
266 ;;; doesn't cache definition. Redid PRINT-VARIABLE. Changed NON- to NON.
267 ;;; Fixed bug in EQUALV. Versions of KNOWN?-TRUE-INTERNAL and
268 ;;; KNOWN?-FALSE-INTERNAL without ASSERT!-BOOLEANPV. Type noticers.
269 ;;; Fixed bug in RESTRICT-BOUNDS!. Fixed +V2 -V2 *V2 /V2 MINV2 MAXV2
270 ;;; ASSERT!-=V2 ASSERT!-<=V2 ASSERT!-<V2 ASSERT!-/=V2 to run rule only after
271 ;;; noticers have been attached.
274 ;;; Completely excised all support for domains containing variables.
275 ;;; EQUAL and EQL don't use = so fixed bug that EQUALV and friends mistakingly
276 ;;; used =V for numbers. As a result it is possible for variables to be bound
277 ;;; to numbers, including complex and real numbers. <=V2 and <V2 asserted
278 ;;; theirs arguments to be numbers which sould be real. Completely redesigned
279 ;;; the constraint package. Must walk body of FOR-EFFECTS.
282 ;;; Implemented CGDEMARC's version of AN-INTEGER, AN-INTEGER-ABOVE,
283 ;;; AN-INTEGER-BELOW, AN-INTEGER-BETWEEN, A-MEMBER-OF-VECTOR and
284 ;;; A-MEMBER-OF-LIST. Added IScream-based Y-OR-N-P. Fixed stupid efficiency
285 ;;; bug in ITH-VALUE.
288 ;;; Fixed bug whereby SUPPLIED-P arguments of deterministic surrogate
289 ;;; functions were not ignored. Added VALUE-OF to all primitives. Made
290 ;;; A-MEMBER-OF be one function. Exported *MAXIMUM-DISCRETIZATION-RANGE*.
291 ;;; FIND-BEST now always returns only variables with non-null cost. FIND-BEST
292 ;;; also will not return a corrupted variable, one where a divide-and-conquer
293 ;;; step will not reduce the RANGE-SIZE. REORDER-INTERNAL no longer conses.
294 ;;; DIVIDE-AND-CONQUER-FORCE will stop recursing if a step fails to tighten
295 ;;; the bound it tried to. Added changes from Volker Haarslev to support
296 ;;; MCL 2.0. Changed reference from LISP package to COMMON-LISP. The functions
297 ;;; PRINT-NONDETERMINISTIC-FUNCTION, FAIL, UNWIND-TRAIL, PURGE and
298 ;;; UNWEDGE-SCREAMER are now defined with DEFUN rather than COMMON-LISP:DEFUN.
299 ;;; MCL supports ENVIRONMENT argument to MACRO-FUNCTION. Workaround MCL
300 ;;; MAPHASH bug in CALLERS. Replaced MAPC with DOLIST everywhere.
301 ;;; DEFSTRUCT-COMPILE-TIME VARIABLE. CHECK-LAMBDA-EXPRESSION integrated into
302 ;;; LAMBDA-EXPRESSION?. Fixed bug in CPS-CONVERT-TAGBODY. Added DYNAMIC-EXTENT
306 ;;; Changed RESTRICT-ENUMERATED-DOMAIN! and RESTRICT-ENUMERATED-ANTIDOMAIN! to
307 ;;; call SET-ENUMERATED-DOMAIN! to fix a bug whereby they didn't restrict
308 ;;; upper and lower bounds. Also fixed many bugs in SHARE!. Fixed bug in MINV2
309 ;;; and MAXV2 where they used INFINITY-MIN and INFINITY-MAX incorrectly.
310 ;;; Fixed bug in CORRUPTED? to allow it to work on nonreal variables. Fixed
311 ;;; bug in FIND-BEST so that it dereferences variables. Removed
312 ;;; DEFSTRUCT-COMPILE-TIME VARIABLE since fixed the real bug which was that
313 ;;; GET-SETF-METHOD needed to take the ENVIRONMENT as its argument. Changed
314 ;;; preamble to conform to new style. Changed many calls to LOOP to TAGBODY
315 ;;; since MCL 2.0 macroexpands LOOP into MACROLET which WALK can't handle.
316 ;;; Changed some WHENs to IFs. GET-SETF-METHOD now takes ENVIRONMENT argument.
317 ;;; Removed extra space in PRINT-VALUES Y-OR-N-P. The functions
318 ;;; PRINT-NONDETERMINISTIC-FUNCTION, FAIL, UNWIND-TRAIL, PURGE and
319 ;;; UNWEDGE-SCREAMER are again defined with COMMON-LISP:DEFUN rather than
320 ;;; DEFUN. Modifications to RESTRICT-LOWER-BOUND!, RESTRICT-UPPER-BOUND! and
321 ;;; RESTRICT-BOUNDS! which improves efficiency slightly. Changed calls to
322 ;;; SEQUENCEP to TYPEP SEQUENCE. I don't know why CLtL2 doesn't have
323 ;;; SEQUENCEP while Lucid does. Lifted generators now take optional NAME
324 ;;; argument like MAKE-VARIABLE. Changed = 0, < 0 and > 0 to ZEROP, MINUSP
325 ;;; and PLUSP. Changed INT-CHAR to CODE-CHAR. Changed /-RULE to not divide by
326 ;;; zero. Also *-RULE-UP/DOWN now just FAIL on divide by zero.
329 ;;; Changed references to COMMON-LISP and COMMON-LISP-USER to CL and CL-USER.
330 ;;; Added DEFINE-SCREAMER-PACKAGE and modified definition of SCREAMER-USER to
331 ;;; use it. All calls to GET-SETF-METHOD and MACRO-FUNCTION now pass
332 ;;; ENVIRONMENT since GENERA 8.1, Lucid 4.0.2 and MCL 2.0 all support this
333 ;;; argument. Added Kludge to support Lucid 4.0.2 without CLIM 1.1 loaded.
334 ;;; Added compile-time switch option whereby variables can be represented
335 ;;; either using DEFSTRUCT or using DEFCLASS. Changed FUTURE-COMMON-LISP to
336 ;;; LISP since now using Ansi-common-lisp syntax for Symbolics.
339 ;;; Implemented the missing cases of BCP from ANDV and ORV. Changed
340 ;;; VALUE-OF as per suggestions of Volker Haarslev. Removed check whether
341 ;;; *QUERY-IO* was same as *TERMINAL-IO* from Y-OR-N-P since *QUERY-IO* is
342 ;;; usually a synonym stream and Lucid doesn't implement
343 ;;; SYNONYM-STREAM-SYMBOL and even if it did, there would be no way to
344 ;;; determine whether or not a steam is a a synonym stream.
347 ;;; ATTACH-NOTICER! now runs it. Load extended LOOP macro for MCL since
348 ;;; regular MCL LOOP expands into a MACROLET which WALK can't handle.
349 ;;; Undid change which turned LOOP into TAGBODY. Don't trail unnested LOCAL
350 ;;; SETF and LOCAL-OUTPUT. Special case BOOLEANS. Fixed bug whereby ANDV
351 ;;; didn't return NIL when one argument was known to be NIL and ORV didn't
352 ;;; return T when one argument was known to be T. Added ASSERT!-ORV and
353 ;;; ASSERT!-NOTV-ANDV optimizations. Fixed a really obscure bug in
354 ;;; PERFORM-SUBSTITUTIONS where it didn't perform substitutions on a
358 ;;; Fixed bug in DETERMINE-WHETHER-CALLERS-ARE-DETERMINISTIC. Fixed the fix
359 ;;; to the obscure bug in PERFORM-SUBSTITUTIONS. Changed the call to
360 ;;; CPS-CONVERT inside CPS-CONVERT-RETURN-FROM to pass (FOURTH TAG) as VALUE?
361 ;;; to fix an obscure bug due to John Eric Fosler.
364 ;;; More efficient ANDV, ORV, ASSERT!-NOTV-ANDV and ASSERT!-ORV. Added
365 ;;; COUNT-TRUES and COUNT-TRUESV. Fixed bug in TRANSFORM-ASSERT!. Added
366 ;;; INTERNAL versions of ANDV, ORV, ASSERT!-NOTV-ANDV, ASSERT!-ORV,
367 ;;; COUNT-TRUES and COUNT-TRUESV. Fixed bug in FUNCALLV and APPLYV. Fixed
368 ;;; efficiency bug in CPS-CONVERT-CALL. Fixed bug in RESTRICT-INTEGER!.
370 ;;; T22Dec92--R25Feb93 Qobi
371 ;;; Exported REAL, REALP, BOOLEAN and BOOLEANP. Added support for partial
372 ;;; evaluator. T is now SELF-EVALUATING. Fixed bug in NEEDS-SUBSTITUTION?
373 ;;; so that NESTED? is T. Fixed CACHE-DEFINITION. Added #||# to IN-PACKAGE.
374 ;;; Added EVAL-WHEN to REQUIRE :LOOP for MCL. Fixed bug in RESTRICT-VALUE!.
377 ;;; Changed meaning of POLARITY? in KNOWN?-CONSTRAINT, PROPAGATE, and
378 ;;; ASSERT!-CONSTRAINT so that non-NIL result of FUNCALLV or APPLYV is
379 ;;; considered to satisfy constraint.
381 ;;; S9May93--S11Jul93 Qobi
382 ;;; Added initial values for LAMBDA-LIST, BODY, ENVIRONMENT, CALLEES, and
383 ;;; OLD-DETERMINISTIC? of FUNCTION-RECORD to allow to run under Genera 8.1.1.
384 ;;; Changed WALK of IF to support Genera 8.3. Conditionalized
385 ;;; SPECIAL-OPERATOR-P and GET-SETF-EXPANSION to support both CLtL2 and dpANS.
386 ;;; CACHE-DEFINITION and friends no longer save ENVIRONMENT. Got rid of code
387 ;;; which saved environments in FUNCTION-RECORD in CACHE-ENVIRONMENT and got
388 ;;; rid of COPY-LIST of environments in DEFUN since that was not portable.
389 ;;; Added #-POPLOG ENVIRONMENT to calls to GET-SETF-METHOD and MACRO-FUNCTION.
390 ;;; Added some other conditionalization to support Poplog. Walker
391 ;;; conditionalization for COND now just used for Explorer and not Allegro.
392 ;;; Added wraps around MACRO-FUNCTION to support Allegro. Added support for
393 ;;; nondeterministic functions that return multiple values. Added support for
394 ;;; AKCL. Fixed efficiency bug in ASSERT!-CONSTRAINT. Fixed error messages
395 ;;; for FUNCALLV/APPLYV. FUNCALLV/APPLYV now return ground value when
396 ;;; manifest. Added arc consistency. DEFUN now returns function name.
397 ;;; Completely obliterated all traces of FUNCTION-RECORD-ENVIRONMENT and
398 ;;; commented all cases where current rather than saved environment is used.
399 ;;; Various machinations to get Screamer to run under Harlequin, Allegro, MCL,
400 ;;; and AKCL. Fixed bugs in ASSERT!-MEMBERV-INTERNAL, ASSERT!-MEMBERV,
401 ;;; ASSERT!-NOTV-MEMBERV-INTERNAL, and ASSERT!-NOTV-MEMBERV. FUNCALLV and
402 ;;; APPLYV now propagate to Z when all arguments become bound.
405 ;;; To consolidate version skew on version 3.11.
408 ;;; Fixed bug in -V2 (i.e. (-V2 0 <variable>)) by removing bogus special case.
411 ;;; Since ATTACH-NOTICER! now runs the noticer after attaching it removed the
412 ;;; cases where the noticers were explicitly run by lifted functions.
415 ;;; Iterate no longer exports FINISH under AKCL since it conflicts with PCL.
416 ;;; TERMINATE is a synonym anyway.
418 ;;; T28Sep93-M4Oct93 Qobi
419 ;;; Ported to CMU CommonLisp 17b. This change necesitated converting the
420 ;;; LOOPs in Y-OR-N-P, UNWIND-TRAIL, VALUE-OF, VARIABLIZE, and
421 ;;; CHOICE-POINT-INTERNAL into TAGBODY/GO combintations since CMU CommonLisp
422 ;;; expands LOOP into MACROLET. Changed POSSIBLY-BETA-REDUCE-FUNCALL to again
423 ;;; do SUBST optimization. Changed CPS-CONVERT-BLOCK, CPS-CONVERT-IF,
424 ;;; CPS-CONVERT-TAGBODY, and CPS-CONVERT-CALL to use
425 ;;; POSSIBLY-BETA-REDUCE-FUNCALL to encapsulate the *DYNAMIC-EXTENT?*
426 ;;; interface and fix some efficiency bugs. Even Symbolics port now uses
427 ;;; MAGIC. Set *DYNAMIC-EXTENT?* to NIL for Symbolics. Added patch files for
428 ;;; Lucid bug-5511. *TRAIL* now has an initial size of 4096 and a growth rate
429 ;;; of 1024 so that we don't spend much time growing it on implementations
430 ;;; where that is inefficient.
433 ;;; PERFORM-SUBSTITUTIONS didn't handle FOR-EFFECTS which caused a bug when
434 ;;; a deterministic DEFUN contained a FOR-EFFECTS which had a nested LOCAL
438 ;;; Fixed bug in CPS-CONVERT-RETURN-FROM that surfaced due to the previous
442 ;;; Fixed bug in WHEN-FAILING so that it now nests.
445 ;;; Fixes to make work under Allegro 4.2 and Genera 8.3.
446 ;;; Future work includes integrating the Allegro\PC and CLISP mods,
447 ;;; fixing the conditionalization on the DEFTYPE BOOLEAN, and checking that
448 ;;; the new official DEFTYPE BOOLEAN corresponds to what Screamer expects.
451 (in-package :cl-user
)
453 (defpackage :screamer
454 (:shadow
:defun
:multiple-value-bind
:y-or-n-p
:variable
)
461 :multiple-value-call-nondeterministic
468 :nondeterministic-function?
469 :funcall-nondeterministic
470 :apply-nondeterministic
530 :divide-and-conquer-force
538 :define-screamer-package
542 :*minimum-shrink-ratio
*
543 :*maximum-discretization-range
*
546 (in-package :screamer
)
548 (declaim (declaration magic
))
550 (defmacro define-screamer-package
(defined-package-name &rest options
)
551 `(defpackage ,defined-package-name
553 (:shadowing-import-from
:screamer
:defun
:multiple-value-bind
:y-or-n-p
)
554 (:use
:cl
:screamer
)))
556 (define-screamer-package :screamer-user
)
558 (defmacro defstruct-compile-time
(options &body items
)
559 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
560 (defstruct ,options
,@items
)))
562 (defmacro defvar-compile-time
(name &optional initial-value documentation
)
563 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
564 (defvar ,name
,initial-value
,documentation
)))
566 (defmacro defun-compile-time
(function-name lambda-list
&body body
)
567 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
568 (cl:defun
,function-name
,lambda-list
,@body
)
569 (eval-when (:compile-toplevel
) (compile ',function-name
))))
571 ;;; Needed because Allegro has some bogosity whereby (MACRO-FUNCTION <m> <e>)
572 ;;; returns NIL during compile time when <m> is a macro being defined for the
573 ;;; first time in the file being compiled.
574 (defmacro defmacro-compile-time
(function-name lambda-list
&body body
)
575 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
576 (defmacro ,function-name
,lambda-list
,@body
)))
578 (defparameter *screamer-version
* "3.20"
579 "The version of Screamer which is loaded.")
581 (defvar-compile-time *dynamic-extent?
* t
582 "T to enable the dynamic extent optimization.")
584 (defvar *iscream?
* nil
585 "T if Screamer is running under ILisp/GNUEmacs with iscream.el loaded.")
587 (defvar *nondeterministic?
* nil
"This must be globally NIL.")
589 (defvar-compile-time *screamer?
* nil
590 "This must be NIL except when defining internal Screamer functions.")
592 (defvar-compile-time *nondeterministic-context?
* nil
593 "This must be globally NIL.")
595 (defvar-compile-time *local?
* nil
"This must be globally NIL.")
597 (defvar-compile-time *block-tags
* '() "This must be globally NIL.")
599 (defvar-compile-time *tagbody-tags
* '() "This must be globally NIL.")
601 (defvar *trail
* (make-array 4096 :adjustable t
:fill-pointer
0) "The trail.")
603 (defvar-compile-time *function-record-table
* (make-hash-table :test
#'equal
)
604 "The function record table.")
606 (defvar-compile-time *ordered-lambda-list-keywords
*
607 '(&optional
&rest
&key
&allow-other-keys
&aux
)
608 "The allowed lambda list keywords in order.")
610 (defmacro-compile-time choice-point-internal
(form)
611 ;; note: Is it really better to use VECTOR-PUSH-EXTEND than CONS for the
614 (let ((*nondeterministic?
* t
))
615 (unwind-protect ,form
619 (if (= (fill-pointer *trail
*) trail-pointer
) (return))
620 (funcall (vector-pop *trail
*))
621 ;; note: This is to allow the trail closures to be garbage
623 (setf (aref *trail
* (fill-pointer *trail
*)) nil
)
626 (defmacro-compile-time choice-point-external
(&rest forms
)
627 ;; note: Is it really better to use VECTOR-PUSH-EXTEND than CONS for the
629 `(let ((trail-pointer (fill-pointer *trail
*))) ,@forms
))
631 (defmacro-compile-time choice-point
(form)
632 `(choice-point-external (choice-point-internal ,form
)))
634 (defstruct-compile-time function-record
640 (old-deterministic? nil
)
641 (screamer?
*screamer?
*))
643 (defstruct-compile-time (nondeterministic-function
644 (:print-function print-nondeterministic-function
)
645 (:predicate nondeterministic-function?-internal
))
648 (defun-compile-time screamer-error
(header &rest args
)
654 "~%There are eight types of nondeterministic contexts: the body of a~%~
655 function defined with DEFUN, the body of a call to the FOR-EFFECTS~%~
656 macro, the first argument of a call to the ONE-VALUE macro, the body of~%~
657 a call to the POSSIBLY? macro, the body of a call to the NECESSARILY?~%~
658 macro, the body of a call to the ALL-VALUES macro, the second argument~%~
659 of a call to the ITH-VALUE macro and the body of a call to the~%~
660 PRINT-VALUES macro. Note that, the default forms of &OPTIONAL and &KEY~%~
661 arguments and the initialization forms of &AUX variables, are always~%~
662 deterministic contexts even though they may appear inside a DEFUN.")
665 (defun-compile-time get-function-record
(function-name)
666 (let ((function-record (gethash function-name
*function-record-table
*)))
667 (unless function-record
668 (setf function-record
(make-function-record :function-name function-name
))
669 (setf (gethash function-name
*function-record-table
*) function-record
))
672 (defun-compile-time peal-off-documentation-string-and-declarations
673 (body &optional documentation-string?
)
674 ;; note: This will need to be done as well for LOCALLY and MACROLET when we
675 ;; eventually implement them.
676 ;; needs work: This requires that the documentation string preceed all
677 ;; declarations which needs to be fixed.
678 (let (documentation-string declarations
)
679 (when (and documentation-string?
681 (not (null (rest body
)))
682 (stringp (first body
)))
683 (setf documentation-string
(first body
))
684 (setf body
(rest body
)))
685 (loop (unless (and (not (null body
))
687 (eq (first (first body
)) 'declare
))
689 (push (first body
) declarations
)
691 (values body
(reverse declarations
) documentation-string
)))
693 (defun-compile-time self-evaluating?
(thing)
694 (and (not (consp thing
))
695 (or (not (symbolp thing
))
698 (eq (symbol-package thing
) (symbol-package :x
)))))
700 (defun-compile-time quotify
(thing)
701 (if (self-evaluating? thing
) thing
`',thing
))
703 (defun-compile-time lambda-expression?
(form)
705 (eq (first form
) 'lambda
)
706 (or (and (null (rest (last form
)))
708 (listp (second form
)))
709 (error "Invalid syntax for LAMBDA expression: ~S" form
))))
711 (defun-compile-time valid-function-name?
(function-name)
712 (or (and (symbolp function-name
) (not (null function-name
)))
713 (and (consp function-name
)
714 (eq (first function-name
) 'setf
)
715 (null (rest (last function-name
)))
716 (= (length function-name
) 2)
717 (symbolp (second function-name
))
718 (not (null (second function-name
))))))
720 (defun-compile-time check-function-name
(function-name)
721 (unless (valid-function-name? function-name
)
722 (error "Invalid function name: ~S" function-name
)))
724 (defun-compile-time every-other
(list)
725 (cond ((null list
) list
)
726 ((null (rest list
)) list
)
727 (t (cons (first list
) (every-other (rest (rest list
)))))))
729 (defun-compile-time check-lambda-list-internal
(lambda-list &optional mode
)
732 ((member (first lambda-list
) *ordered-lambda-list-keywords
* :test
#'eq
)
733 (check-lambda-list-internal (rest lambda-list
) (first lambda-list
)))
734 (t (let ((parameter (first lambda-list
)))
737 (unless (symbolp parameter
)
738 (error "Invalid parameter: ~S" parameter
)))
740 (unless (or (symbolp parameter
)
741 (and (consp parameter
)
742 (null (rest (last parameter
)))
743 (or (= (length parameter
) 1)
744 (= (length parameter
) 2)
745 (and (= (length parameter
) 3)
746 (symbolp (third parameter
))))
747 (symbolp (first parameter
))))
748 (error "Invalid &OPTIONAL parameter: ~S" parameter
)))
750 (unless (symbolp parameter
)
751 (error "Invalid &REST parameter: ~S" parameter
)))
753 (unless (or (symbolp parameter
)
754 (and (consp parameter
)
755 (null (rest (last parameter
)))
756 (or (= (length parameter
) 1)
757 (= (length parameter
) 2)
758 (and (= (length parameter
) 3)
759 (symbolp (third parameter
))))
760 (or (symbolp (first parameter
))
761 (and (consp (first parameter
))
762 (null (rest (last (first parameter
))))
763 (= (length (first parameter
)) 2)
764 (symbolp (first (first parameter
)))
765 (symbolp (second (first parameter
)))))))
766 (error "Invalid &KEY parameter: ~S" parameter
)))
768 (unless (or (symbolp parameter
)
769 (and (consp parameter
)
770 (null (rest (last parameter
)))
771 (or (= (length parameter
) 1)
772 (= (length parameter
) 2))
773 (symbolp (first parameter
))))
774 (error "Invalid &AUX parameter: ~S" parameter
)))))
775 (check-lambda-list-internal (rest lambda-list
) mode
))))
777 (defun-compile-time check-lambda-list
(lambda-list)
778 (unless (null (rest (last lambda-list
)))
779 (error "Improper lambda-list: ~S" lambda-list
))
780 (let ((rest (member '&rest lambda-list
:test
#'eq
)))
782 (let ((rest (rest rest
)))
783 (unless (not (member '&rest rest
:test
#'eq
))
784 (error "&REST cannot appear more than once: ~S" lambda-list
))
785 (unless (and (not (null rest
))
786 (not (member (first rest
) lambda-list-keywords
:test
#'eq
))
787 (or (null (rest rest
))
788 (member (first (rest rest
)) lambda-list-keywords
790 (error "&REST must be followed by exactly one variable: ~S"
792 (let ((allow-other-keys (member '&allow-other-keys lambda-list
:test
#'eq
)))
794 (unless (or (null (rest allow-other-keys
))
795 (member (first (rest allow-other-keys
)) lambda-list-keywords
797 (error "&ALLOW-OTHER-KEYS must not be followed by a parameter: ~S"
800 (remove-if-not #'(lambda (argument)
801 (member argument lambda-list-keywords
:test
#'eq
))
803 (unless (every #'(lambda (keyword)
804 (member keyword
*ordered-lambda-list-keywords
* :test
#'eq
))
806 (error "Invalid lambda list keyword: ~S" lambda-list
))
807 (unless (every #'(lambda (x y
)
808 (member y
(member x
*ordered-lambda-list-keywords
*
813 (error "Invalid order for lambda list keywords: ~S" lambda-list
)))
814 (check-lambda-list-internal lambda-list
))
816 (defun-compile-time walk-lambda-list-reducing
817 (map-function reduce-function screamer? partial? nested? lambda-list
818 environment
&optional mode
)
820 ((null lambda-list
) (funcall reduce-function
))
821 ((member (first lambda-list
) *ordered-lambda-list-keywords
* :test
#'eq
)
822 (walk-lambda-list-reducing map-function
829 (first lambda-list
)))
831 ((nil &rest
&allow-other-keys
&aux
)
832 (walk-lambda-list-reducing map-function
841 (if (and (consp (first lambda-list
))
842 (consp (rest (first lambda-list
))))
845 (walk map-function reduce-function screamer? partial? nested?
846 (second (first lambda-list
)) environment
)
847 (walk-lambda-list-reducing map-function
855 (walk-lambda-list-reducing map-function
864 (defun-compile-time walk-lambda-list
865 (map-function reduce-function screamer? partial? nested? lambda-list
867 (check-lambda-list lambda-list
)
871 (funcall map-function lambda-list
'lambda-list
)
872 (walk-lambda-list-reducing map-function
879 (funcall map-function lambda-list
'lambda-list
)))
881 (defun-compile-time walk-block
882 (map-function reduce-function screamer? partial? nested? form environment
)
883 (unless (null (rest (last form
))) (error "Improper BLOCK: ~S" form
))
884 (unless (>= (length form
) 2)
885 (error "BLOCK must have at least one argument, a NAME: ~S" form
))
886 (unless (symbolp (second form
)) (error "NAME must be a symbol: ~S" form
))
888 (funcall reduce-function
889 (funcall map-function form
'block
)
890 (reduce reduce-function
891 (mapcar #'(lambda (subform)
899 (rest (rest form
)))))
900 (funcall map-function form
'block
)))
902 (defun-compile-time walk-catch
903 (map-function reduce-function screamer? partial? nested? form environment
)
904 (unless (null (rest (last form
))) (error "Improper PROGN: ~S" form
))
905 (unless (>= (length form
) 2)
906 (error "CATCH must have at least one argument, a TAG: ~S" form
))
908 (funcall reduce-function
909 (funcall map-function form
'catch
)
910 (reduce reduce-function
911 (mapcar #'(lambda (subform)
920 (funcall map-function form
'catch
)))
922 (defun-compile-time walk-eval-when
923 (map-function reduce-function screamer? partial? nested? form environment
)
924 (unless (null (rest (last form
))) (error "Improper EVAL-WHEN: ~S" form
))
925 (unless (>= (length form
) 2)
926 (error "EVAL-WHEN must have at least one argument: ~S" form
))
927 (unless (listp (second form
))
928 (error "First argument of EVAL-WHEN must be a list: ~S" form
))
929 (unless (null (rest (last (second form
))))
930 (error "Improper list of SITUATIONS: ~S" form
))
931 (unless (every #'(lambda (situation)
932 (member situation
'(:compile-top-level
940 (error "Invalid SITUATION: ~S" form
))
941 (if (member :execute
(second form
) :test
#'eq
)
942 (walk-progn map-function
947 `(progn ,@(rest (rest form
)))
949 (funcall map-function nil
'quote
)))
951 (defun-compile-time walk-flet
/labels
952 (map-function reduce-function screamer? partial? nested? form environment
954 (unless (null (rest (last form
))) (error "Improper ~S: ~S" form-type form
))
955 (unless (>= (length form
) 2)
956 (error "~S must have BINDINGS: ~S" form-type form
))
957 (unless (and (listp (second form
))
958 (null (rest (last (second form
))))
959 (every #'(lambda (binding)
961 (null (rest (last binding
)))
962 (>= (length binding
) 2)
963 (valid-function-name?
(first binding
))
964 (listp (second binding
))))
966 (error "Invalid BINDINGS for ~S: ~S" form-type form
))
970 (funcall map-function form form-type
)
978 (funcall reduce-function
979 (walk-lambda-list map-function
995 (peal-off-documentation-string-and-declarations
996 (rest (rest binding
)) t
))))
998 (reduce reduce-function
999 (mapcar #'(lambda (subform)
1007 (rest (rest form
)))))
1008 (reduce reduce-function
1009 (mapcar #'(lambda (subform)
1017 (rest (rest form
))))))
1018 (funcall map-function form form-type
)))
1020 (defun-compile-time walk-function
1021 (map-function reduce-function screamer? partial? nested? form environment
)
1022 (unless (null (rest (last form
))) (error "Improper FUNCTION: ~S" form
))
1023 (unless (= (length form
) 2)
1024 (error "FUNCTION must have one argument: ~S" form
))
1025 (cond ((lambda-expression?
(second form
))
1026 (if (and reduce-function nested?
)
1029 (funcall map-function form
'function-lambda
)
1032 (walk-lambda-list map-function
1037 (second (second form
))
1041 (mapcar #'(lambda (subform)
1049 (peal-off-documentation-string-and-declarations
1050 (rest (rest (second form
))) t
)))))
1051 (funcall map-function form
'function-lambda
)))
1052 ((valid-function-name?
(second form
))
1054 ((symbolp (second form
))
1055 (if (or (special-operator-p (second form
))
1056 (macro-function (second form
) environment
))
1057 (error "You can't reference the FUNCTION of a special form or~%~
1060 (funcall map-function form
'function-symbol
)))
1061 (t (funcall map-function form
'function-setf
))))
1062 (t (error "Invalid argument to FUNCTION: ~S" form
))))
1064 (defun-compile-time walk-go
(map-function form
)
1065 (unless (null (rest (last form
))) (error "Improper GO: ~S" form
))
1066 (unless (= (length form
) 2) (error "GO must have one argument: ~S" form
))
1067 (unless (or (symbolp (second form
)) (integerp (second form
)))
1068 (error "TAG of GO must be a symbol or integer: ~S" form
))
1069 (funcall map-function form
'go
))
1071 (defun-compile-time walk-if
1072 (map-function reduce-function screamer? partial? nested? form environment
)
1073 (unless (null (rest (last form
))) (error "Improper IF: ~S" form
))
1074 (unless (or (= (length form
) 3) (= (length form
) 4))
1075 (error "IF must have two or three arguments: ~S" form
))
1077 (if (= (length form
) 4)
1078 (funcall reduce-function
1079 (funcall map-function form
'if
)
1080 (funcall reduce-function
1088 (funcall reduce-function
1103 (funcall reduce-function
1104 (funcall map-function form
'if
)
1105 (funcall reduce-function
1120 (funcall map-function form
'if
)))
1122 (defun-compile-time walk-let
/let
*
1123 (map-function reduce-function screamer? partial? nested? form environment
1125 (unless (null (rest (last form
))) (error "Improper ~S: ~S" form-type form
))
1126 (unless (>= (length form
) 2)
1127 (error "~S must have BINDINGS: ~S" form-type form
))
1128 (unless (and (listp (second form
))
1129 (null (rest (last (second form
))))
1130 (every #'(lambda (binding)
1131 (or (symbolp binding
)
1132 (and (consp binding
)
1133 (null (rest (last binding
)))
1134 (or (= (length binding
) 1)
1135 (= (length binding
) 2))
1136 (symbolp (first binding
)))))
1138 (error "Invalid BINDINGS for ~S: ~S" form-type form
))
1142 (funcall map-function form form-type
)
1143 (funcall reduce-function
1144 (reduce reduce-function
1145 (mapcar #'(lambda (binding)
1155 (and (consp binding
)
1156 (= (length binding
) 2)))
1158 (reduce reduce-function
1159 (mapcar #'(lambda (subform)
1167 (peal-off-documentation-string-and-declarations
1168 (rest (rest form
)))))))
1169 (funcall map-function form form-type
)))
1171 (defun-compile-time walk-multiple-value-call
1172 (map-function reduce-function screamer? partial? nested? form environment
)
1173 (unless (null (rest (last form
)))
1174 (error "Improper MULTIPLE-VALUE-CALL: ~S" form
))
1175 (unless (>= (length form
) 2)
1176 (error "MULTIPLE-VALUE-CALL must have at least one argument, a FUNCTION: ~S"
1179 (funcall reduce-function
1180 (funcall map-function form
'multiple-value-call
)
1181 (reduce reduce-function
1182 (mapcar #'(lambda (subform)
1191 (funcall map-function form
'multiple-value-call
)))
1193 (defun-compile-time walk-multiple-value-prog1
1194 (map-function reduce-function screamer? partial? nested? form environment
)
1195 (unless (null (rest (last form
)))
1196 (error "Improper MULTIPLE-VALUE-PROG1: ~S" form
))
1197 (unless (>= (length form
) 2)
1198 (error "MULTIPLE-VALUE-PROG1 must have at least one argument, a FORM: ~S"
1201 (funcall reduce-function
1202 (funcall map-function form
'multiple-value-prog1
)
1203 (reduce reduce-function
1204 (mapcar #'(lambda (subform)
1213 (funcall map-function form
'multiple-value-prog1
)))
1215 (defun-compile-time walk-progn
1216 (map-function reduce-function screamer? partial? nested? form environment
)
1217 (unless (null (rest (last form
))) (error "Improper PROGN: ~S" form
))
1219 (funcall reduce-function
1220 (funcall map-function form
'progn
)
1221 (reduce reduce-function
1222 (mapcar #'(lambda (subform)
1231 (funcall map-function form
'progn
)))
1233 (defun-compile-time walk-progv
1234 (map-function reduce-function screamer? partial? nested? form environment
)
1235 (unless (null (rest (last form
))) (error "Improper PROGV: ~S" form
))
1236 (unless (>= (length form
) 3)
1237 (error "PROGV must have at least two arguments: ~S" form
))
1239 (funcall reduce-function
1240 (funcall map-function form
'progv
)
1241 (funcall reduce-function
1242 (funcall reduce-function
1257 (reduce reduce-function
1258 (mapcar #'(lambda (subform)
1266 (rest (rest (rest form
)))))))
1267 (funcall map-function form
'progv
)))
1269 (defun-compile-time walk-quote
(map-function form
)
1270 (unless (null (rest (last form
))) (error "Improper QUOTE: ~S" form
))
1271 (unless (= (length form
) 2)
1272 (error "QUOTE must have one argument: ~S" form
))
1273 (funcall map-function
(second form
) 'quote
))
1275 (defun-compile-time walk-return-from
1276 (map-function reduce-function screamer? partial? nested? form environment
)
1277 (unless (null (rest (last form
))) (error "Improper RETURN-FROM: ~S" form
))
1278 (unless (or (= (length form
) 2) (= (length form
) 3))
1279 (error "RETURN-FROM must have one or two arguments,~%~
1280 a NAME and an optional RESULT: ~S" form
))
1281 (unless (symbolp (second form
)) (error "NAME must be a symbol: ~S" form
))
1283 (funcall reduce-function
1284 (funcall map-function form
'return-from
)
1290 (if (= (length form
) 3) (third form
) nil
)
1292 (funcall map-function form
'return-from
)))
1294 (defun-compile-time walk-setq
1295 (map-function reduce-function screamer? partial? nested? form environment
)
1296 (unless (null (rest (last form
))) (error "Improper SETQ: ~S" form
))
1297 (unless (every #'symbolp
(every-other (rest form
)))
1298 (error "Invalid destination for SETQ: ~S" form
))
1299 (unless (evenp (length (rest form
)))
1300 (error "Odd number of arguments to SETQ: ~S" form
))
1302 (funcall reduce-function
1303 (funcall map-function form
'setq
)
1304 (reduce reduce-function
1305 (mapcar #'(lambda (subform)
1313 (every-other (rest (rest form
))))))
1314 (funcall map-function form
'setq
)))
1316 (defun-compile-time walk-tagbody
1317 (map-function reduce-function screamer? partial? nested? form environment
)
1318 (unless (null (rest (last form
))) (error "Improper TAGBODY: ~S" form
))
1319 (unless (every #'(lambda (subform)
1320 (or (symbolp subform
) (integerp subform
) (listp subform
)))
1322 (error "A subforms of a TAGBODY must be symbols, integers or lists: ~S"
1324 (let ((tags (remove-if #'consp
(rest form
))))
1325 (unless (= (length tags
) (length (remove-duplicates tags
)))
1326 (error "TAGBODY has duplicate TAGs: ~S" form
)))
1328 (funcall reduce-function
1329 (funcall map-function form
'tagbody
)
1330 (reduce reduce-function
1331 (mapcar #'(lambda (subform)
1339 (remove-if-not #'consp
(rest form
)))))
1340 (funcall map-function form
'tagbody
)))
1342 (defun-compile-time walk-the
1343 (map-function reduce-function screamer? partial? nested? form environment
)
1344 (unless (null (rest (last form
))) (error "Improper THE: ~S" form
))
1345 (unless (= (length form
) 3) (error "THE must have two arguments: ~S" form
))
1347 (funcall reduce-function
1355 (funcall map-function form
'the
))
1356 (funcall map-function form
'the
)))
1358 (defun-compile-time walk-throw
1359 (map-function reduce-function screamer? partial? nested? form environment
)
1360 (unless (null (rest (last form
))) (error "Improper THROW: ~S" form
))
1361 (unless (= (length form
) 3)
1362 (error "THROW must have two arguments, a TAG and a RESULT: ~S" form
))
1364 (funcall reduce-function
1365 (funcall map-function form
'throw
)
1366 (funcall reduce-function
1381 (funcall map-function form
'throw
)))
1383 (defun-compile-time walk-unwind-protect
1384 (map-function reduce-function screamer? partial? nested? form environment
)
1385 (unless (null (rest (last form
))) (error "Improper UNWIND-PROTECT: ~S" form
))
1386 (unless (>= (length form
) 2)
1387 (error "UNWIND-PROTECT must have at least one argument, a PROTECTED-FORM: ~S"
1392 (funcall map-function form
'unwind-protect
)
1393 (funcall reduce-function
1401 (reduce reduce-function
1402 (mapcar #'(lambda (subform)
1410 (rest (rest form
))))))
1411 (funcall map-function form
'unwind-protect
)))
1413 (defun-compile-time walk-for-effects
1414 (map-function reduce-function screamer? partial? nested? form environment
)
1415 (unless (null (rest (last form
))) (error "Improper FOR-EFFECTS: ~S" form
))
1416 ;; note: We used to think that we should never walk the body of FOR-EFFECTS
1417 ;; as we thought that the walker would get confused on the code
1418 ;; generated by FOR-EFFECTS and that FOR-EFFECTS called
1419 ;; CPS-CONVERT-PROGN on its body and that CPS-CONVERT-PROGN did the
1420 ;; walk for us. But that was wrong since FORM-CALLEES also walks and
1421 ;; thus would miss functions called in the body of a FOR-EFFECTS. So now
1422 ;; we walk the body of a FOR-EFFECTS without macro-expanding it, but
1423 ;; only when NESTED? is true which is essentially only for FORM-CALLEES
1424 ;; since DETERMINISTIC? must not walk the body of FOR-EFFECTS or else
1425 ;; it will mistakingly report that that a FOR-EFFECTS form is
1426 ;; nondeterministic when its body is nondeterministic.
1427 (if (and reduce-function nested?
)
1428 (funcall reduce-function
1429 (funcall map-function form
'for-effects
)
1430 (reduce reduce-function
1431 (mapcar #'(lambda (subform)
1440 (funcall map-function form
'for-effects
)))
1442 (defun-compile-time walk-setf
1443 (map-function reduce-function screamer? partial? nested? form environment
)
1444 (unless (null (rest (last form
))) (error "Improper SETF: ~S" form
))
1445 (unless (evenp (length (rest form
)))
1446 (error "Odd number of arguments to SETF: ~S" form
))
1449 (funcall reduce-function
1450 (funcall map-function form
'local-setf
)
1451 (reduce reduce-function
1452 (mapcar #'(lambda (subform)
1460 (every-other (rest (rest form
))))))
1461 (funcall map-function form
'local-setf
))
1467 (let ((*macroexpand-hook
* #'funcall
))
1468 (macroexpand-1 form environment
))
1471 (defun-compile-time walk-multiple-value-call-nondeterministic
1472 (map-function reduce-function screamer? partial? nested? form environment
)
1473 (unless (null (rest (last form
)))
1474 (error "Improper MULTIPLE-VALUE-CALL-NONDETERMINISTIC: ~S" form
))
1475 (unless (>= (length form
) 2)
1476 (error "MULTIPLE-VALUE-CALL-NONDETERMINISTIC must have at least one ~
1477 argument, a FUNCTION: ~S"
1480 (funcall reduce-function
1481 (funcall map-function form
'multiple-value-call-nondeterministic
)
1482 (reduce reduce-function
1483 (mapcar #'(lambda (subform)
1492 (funcall map-function form
'multiple-value-call-nondeterministic
)))
1494 (defun-compile-time walk-full
(map-function form
)
1495 (unless (null (rest (last form
))) (error "Improper FULL: ~S" form
))
1496 (unless (= (length form
) 2)
1497 (error "FULL must have exactly one argument, a FORM: ~S" form
))
1498 (funcall map-function form
'full
))
1500 (defun-compile-time walk-macro-call
1501 (map-function reduce-function screamer? partial? nested? form environment
)
1503 (funcall reduce-function
1504 (funcall map-function form
'macro-call
)
1510 (let ((*macroexpand-hook
* #'funcall
))
1511 (macroexpand-1 form environment
))
1518 (let ((*macroexpand-hook
* #'funcall
))
1519 (macroexpand-1 form environment
))
1522 (defun-compile-time walk-function-call
1523 (map-function reduce-function screamer? partial? nested? form environment
)
1524 (unless (null (rest (last form
)))
1525 (error "Improper function call form: ~S" form
))
1527 ((lambda-expression?
(first form
))
1531 (funcall map-function form
'lambda-call
)
1534 (reduce reduce-function
1535 (mapcar #'(lambda (subform)
1546 (walk-lambda-list map-function
1551 (second (first form
))
1553 (reduce reduce-function
1554 (mapcar #'(lambda (subform)
1562 (peal-off-documentation-string-and-declarations
1563 (rest (rest (first form
))) t
))))))
1564 (funcall map-function form
'lambda-call
)))
1565 ((valid-function-name?
(first form
))
1566 (if (symbolp (first form
))
1568 (funcall reduce-function
1569 (funcall map-function form
'symbol-call
)
1570 (reduce reduce-function
1571 (mapcar #'(lambda (subform)
1580 (funcall map-function form
'symbol-call
))
1582 (funcall reduce-function
1583 (funcall map-function form
'setf-call
)
1584 (reduce reduce-function
1585 (mapcar #'(lambda (subform)
1594 (funcall map-function form
'setf-call
))))
1595 (t (error "CAR of form ~S is not a valid function" form
))))
1597 ;;; Possible FORM-TYPEs
1599 ;;; LAMBDA-LIST VARIABLE
1601 ;;; BLOCK CATCH EVAL-WHEN FLET FUNCTION-LAMBDA FUNCTION-SYMBOL FUNCTION-SETF
1602 ;;; GO IF LABELS LET LET* MULTIPLE-VALUE-CALL MULTIPLE-VALUE-PROG1 PROGN
1603 ;;; PROGV QUOTE RETURN-FROM SETQ TAGBODY THE THROW UNWIND-PROTECT
1604 ;;; Symbolics special forms:
1605 ;;; SYS:VARIABLE-LOCATION COMPILER:INVISIBLE-REFERENCES
1606 ;;; Screamer special forms:
1607 ;;; FOR-EFFECTS LOCAL-SETF
1608 ;;; Partial special forms:
1611 ;;; MACRO-CALL LAMBDA-CALL SYMBOL-CALL SETF-CALL
1613 (defun-compile-time walk
1614 (map-function reduce-function screamer? partial? nested? form environment
)
1615 ;; needs work: Cannot walk MACROLET or special forms not in both CLtL1 and
1618 ((self-evaluating? form
) (funcall map-function form
'quote
))
1619 ((symbolp form
) (funcall map-function form
'variable
))
1620 ((eq (first form
) 'block
)
1622 map-function reduce-function screamer? partial? nested? form environment
))
1623 ((eq (first form
) 'catch
)
1625 map-function reduce-function screamer? partial? nested? form environment
))
1626 ((eq (first form
) 'eval-when
)
1628 map-function reduce-function screamer? partial? nested? form environment
))
1629 ((eq (first form
) 'flet
)
1631 map-function reduce-function screamer? partial? nested? form environment
1633 ((eq (first form
) 'function
)
1635 map-function reduce-function screamer? partial? nested? form environment
))
1636 ((eq (first form
) 'go
) (walk-go map-function form
))
1637 ((eq (first form
) 'if
)
1638 (walk-if map-function reduce-function screamer? partial? nested? form
1640 ((eq (first form
) 'labels
)
1642 map-function reduce-function screamer? partial? nested? form environment
1644 ((eq (first form
) 'let
)
1646 map-function reduce-function screamer? partial? nested? form environment
1648 ((eq (first form
) 'let
*)
1650 map-function reduce-function screamer? partial? nested? form environment
1652 ;; needs work: This is a temporary kludge to support MCL.
1653 ((and (eq (first form
) 'locally
) (null (fourth form
)))
1654 (walk map-function reduce-function screamer? partial? nested?
(third form
)
1656 ((eq (first form
) 'multiple-value-call
)
1657 (walk-multiple-value-call
1658 map-function reduce-function screamer? partial? nested? form environment
))
1659 ((eq (first form
) 'multiple-value-prog1
)
1660 (walk-multiple-value-prog1
1661 map-function reduce-function screamer? partial? nested? form environment
))
1662 ((eq (first form
) 'progn
)
1664 map-function reduce-function screamer? partial? nested? form environment
))
1665 ((eq (first form
) 'progv
)
1667 map-function reduce-function screamer? partial? nested? form environment
))
1668 ((eq (first form
) 'quote
) (walk-quote map-function form
))
1669 ((eq (first form
) 'return-from
)
1671 map-function reduce-function screamer? partial? nested? form environment
))
1672 ((eq (first form
) 'setq
)
1674 map-function reduce-function screamer? partial? nested? form environment
))
1675 ((eq (first form
) 'tagbody
)
1677 map-function reduce-function screamer? partial? nested? form environment
))
1678 ((eq (first form
) 'the
)
1680 map-function reduce-function screamer? partial? nested? form environment
))
1681 ((eq (first form
) 'throw
)
1683 map-function reduce-function screamer? partial? nested? form environment
))
1684 ((eq (first form
) 'unwind-protect
)
1685 (walk-unwind-protect
1686 map-function reduce-function screamer? partial? nested? form environment
))
1687 ((and screamer?
(eq (first form
) 'for-effects
))
1689 map-function reduce-function screamer? partial? nested? form environment
))
1690 ((and screamer?
(eq (first form
) 'setf
))
1692 map-function reduce-function screamer? partial? nested? form environment
))
1693 ((and screamer?
(eq (first form
) 'local
))
1696 map-function reduce-function screamer? partial? nested? form
1698 ((and screamer?
(eq (first form
) 'global
))
1699 (let ((*local?
* nil
))
1701 map-function reduce-function screamer? partial? nested? form
1703 ((and screamer?
(eq (first form
) 'multiple-value-call-nondeterministic
))
1704 (walk-multiple-value-call-nondeterministic
1705 map-function reduce-function screamer? partial? nested? form environment
))
1706 ((and partial?
(eq (first form
) 'full
)) (walk-full map-function form
))
1707 ((and (symbolp (first form
))
1708 (macro-function (first form
) environment
))
1710 map-function reduce-function screamer? partial? nested? form environment
))
1711 ((special-operator-p (first form
))
1712 (error "Cannot (currently) handle the special form ~S" (first form
)))
1713 (t (walk-function-call
1714 map-function reduce-function screamer? partial? nested? form
1717 (defun-compile-time process-subforms
(function form form-type environment
)
1719 (lambda-list (error "This shouldn't happen"))
1720 ((variable go
) form
)
1724 (mapcar #'(lambda (subform)
1725 (funcall function subform environment
))
1726 (rest (rest form
))))))
1731 (cl:multiple-value-bind
(body declarations documentation-string
)
1732 (peal-off-documentation-string-and-declarations
1733 (rest (rest binding
)) t
)
1735 ;; needs work: To process subforms of lambda list.
1737 ,@(if documentation-string
(list documentation-string
))
1740 #'(lambda (subform) (funcall function subform environment
))
1744 #'(lambda (subform) (funcall function subform environment
))
1745 (rest (rest form
)))))
1747 (cl:multiple-value-bind
(body declarations
)
1748 (peal-off-documentation-string-and-declarations (rest (rest form
)))
1752 (if (and (consp binding
) (= (length binding
) 2))
1754 ,(funcall function
(second binding
) environment
))
1759 #'(lambda (subform) (funcall function subform environment
)) body
))))
1762 #'(lambda (subform) (funcall function subform environment
))
1764 (quote (quotify form
))
1765 (the `(the ,(second form
) ,(funcall function
(third form
) environment
)))
1766 (macro-call (error "This shouldn't happen"))
1768 (cl:multiple-value-bind
(body declarations documentation-string
)
1769 (peal-off-documentation-string-and-declarations
1770 (rest (rest (first form
))) t
)
1771 ;; needs work: To process subforms of lambda list.
1772 `((lambda ,(second (first form
))
1773 ,@(if documentation-string
(list documentation-string
))
1775 ,@(mapcar #'(lambda (subform) (funcall function subform environment
))
1778 #'(lambda (subform) (funcall function subform environment
))
1782 (mapcar #'(lambda (subform) (funcall function subform environment
))
1785 (defun-compile-time deterministic?
(form environment
)
1787 #'(lambda (form form-type
)
1789 ((symbol-call setf-call
)
1790 (function-record-deterministic?
(get-function-record (first form
))))
1791 (multiple-value-call-nondeterministic nil
)
1792 ;; note: not really sure about CATCH, THROW and UNWIND-PROTECT
1794 ;; note: potentially inefficient because must walk entire form even
1795 ;; after it is known to be nondeterministic
1796 #'(lambda (&optional
(x nil x?
) y
) (if x?
(and x y
) t
))
1803 (defun-compile-time deterministic-lambda-list?
(lambda-list environment
)
1805 #'(lambda (form form-type
)
1807 ((symbol-call setf-call
)
1808 (function-record-deterministic?
(get-function-record (first form
))))
1809 (multiple-value-call-nondeterministic nil
)
1810 ;; note: not really sure about CATCH, THROW and UNWIND-PROTECT
1812 ;; note: potentially inefficient because must walk entire form even
1813 ;; after it is known to be nondeterministic
1814 #'(lambda (&optional
(x nil x?
) y
) (if x?
(and x y
) t
))
1821 (defun-compile-time needs-substitution?
(form environment
)
1823 #'(lambda (form form-type
)
1826 (not (and (every #'(lambda (form) (deterministic? form environment
))
1827 (peal-off-documentation-string-and-declarations
1828 (rest (rest (second form
))) t
))
1829 (deterministic-lambda-list?
1830 (second (second form
)) environment
))))
1831 ((function-symbol function-setf
)
1832 (not (function-record-deterministic?
1833 (get-function-record (second form
)))))
1834 (return-from (let ((tag (assoc (second form
) *block-tags
* :test
#'eq
)))
1835 (and tag
(second tag
))))
1836 (go (let ((tag (assoc (second form
) *tagbody-tags
*)))
1837 (and tag
(second tag
))))
1841 ;; note: potentially inefficient because must walk entire form even
1842 ;; after it is known to need substitution
1843 #'(lambda (&optional
(x nil x?
) y
) (if x?
(or x y
) '()))
1850 (defun-compile-time contains-local-setf
/setq?
(form environment
)
1851 (walk #'(lambda (form form-type
)
1852 (declare (ignore form
))
1853 (or (and *local?
* (eq form-type
'setq
))
1854 (eq form-type
'local-setf
)))
1855 ;; note: potentially inefficient because must walk entire form even
1856 ;; after it is known to contain a LOCAL SETF/SETQ special form
1857 #'(lambda (&optional
(x nil x?
) y
) (if x?
(or x y
) '()))
1864 (defun-compile-time form-callees
(form environment
)
1865 (walk #'(lambda (form form-type
)
1867 ((function-symbol function-setf
) (list (second form
)))
1868 ((symbol-call setf-call
) (list (first form
)))
1870 #'(lambda (&optional
(x nil x?
) y
)
1871 (if x?
(union x y
:test
#'equal
) '()))
1878 (defun-compile-time callees
(function-name)
1879 (function-record-callees (get-function-record function-name
)))
1881 (defun-compile-time indirect-callees-internal
(function-names callees
)
1882 (if (null function-names
)
1884 (let ((function-name (first function-names
)))
1885 (if (member function-name callees
:test
#'equal
)
1886 (indirect-callees-internal (rest function-names
) callees
)
1887 (indirect-callees-internal
1888 (rest function-names
)
1889 (indirect-callees-internal
1890 (callees function-name
) (cons function-name callees
)))))))
1892 (defun-compile-time indirect-callees
(function-name)
1893 (indirect-callees-internal (callees function-name
) '()))
1895 (defun-compile-time callers
(function-name)
1897 (function-names '()))
1898 (maphash #'(lambda (function-name function-record
)
1899 (declare (ignore function-record
))
1900 (push function-name function-names
))
1901 *function-record-table
*)
1902 (dolist (caller function-names
)
1903 (if (member function-name
(callees caller
) :test
#'equal
)
1904 (pushnew caller callers
:test
#'equal
)))
1907 (defun-compile-time indirect-callers-internal
(function-names callers
)
1908 (if (null function-names
)
1910 (let ((function-name (first function-names
)))
1911 (if (member function-name callers
:test
#'equal
)
1912 (indirect-callers-internal (rest function-names
) callers
)
1913 (indirect-callers-internal
1914 (rest function-names
)
1915 (indirect-callers-internal
1916 (callers function-name
) (cons function-name callers
)))))))
1918 (defun-compile-time indirect-callers
(function-name)
1919 (indirect-callers-internal (callers function-name
) '()))
1921 (defun-compile-time expand-local-setf
(pairs environment
)
1924 (let ((d (gensym "DUMMY-"))
1925 (dummy-argument (gensym "DUMMY-")))
1926 (cl:multiple-value-bind
(vars vals stores store-form access-form
)
1927 (get-setf-expansion (first pairs
) environment
)
1928 `(let* (,@(mapcar #'list vars vals
)
1929 (,dummy-argument
,(second pairs
))
1931 (trail #'(lambda () ,(subst d
(first stores
) store-form
)))
1932 ,@(if (null (rest (rest pairs
)))
1933 (list (subst dummy-argument
(first stores
) store-form
))
1934 (list (subst dummy-argument
(first stores
) store-form
)
1935 (expand-local-setf (rest (rest pairs
)) environment
))))))))
1937 (defun-compile-time expand-local-setq
(pairs environment
)
1940 (let ((d (gensym "DUMMY-")))
1941 `(let ((,d
,(first pairs
)))
1942 (trail #'(lambda () (setq ,(first pairs
) ,d
)))
1943 ,@(if (null (rest (rest pairs
)))
1946 ,(perform-substitutions (second pairs
) environment
)))
1949 ,(perform-substitutions (second pairs
) environment
))
1950 (expand-local-setq (rest (rest pairs
)) environment
)))))))
1952 (defun-compile-time perform-substitutions
(form environment
)
1953 (if (needs-substitution? form environment
)
1955 #'(lambda (form form-type
)
1957 (lambda-list (error "This shouldn't happen"))
1958 (variable (error "This shouldn't happen"))
1959 (block (let ((*block-tags
*
1960 (cons (list (second form
) nil
) *block-tags
*)))
1962 #'perform-substitutions form form-type environment
)))
1964 (unless (deterministic-lambda-list?
1965 (second (second form
)) environment
)
1967 "Cannot (currently) handle a LAMDBA expression with~%~
1968 nondeterministic initializations forms for~%~
1969 &OPTIONAL and &AUX parameters: ~S"
1971 (cl:multiple-value-bind
(body declarations documentation-string
)
1972 (peal-off-documentation-string-and-declarations
1973 (rest (rest (second form
))) t
)
1974 (if (every #'(lambda (form) (deterministic? form environment
))
1976 ;; needs work: To process subforms of lambda list.
1977 `#'(lambda ,(second (second form
))
1978 ,@(if documentation-string
(list documentation-string
))
1982 (perform-substitutions subform environment
))
1984 (let ((continuation (gensym "CONTINUATION-")))
1985 ;; note: This conses every time #'(LAMBDA (...) ...) is
1986 ;; accessed when it is nondeterministic. A small
1987 ;; price to pay for a lot of error checking.
1988 `(make-nondeterministic-function
1990 ;; needs work: To process subforms of lambda list.
1991 #'(lambda (,continuation
,@(second (second form
)))
1992 ,@(if documentation-string
(list documentation-string
))
1994 ,continuation
;ignore
1995 ,(cps-convert-progn body
2000 ((function-symbol function-setf
)
2001 (if (function-record-deterministic?
2002 (get-function-record (second form
)))
2004 ;; note: This conses every time #'FOO or #'(SETF FOO) is
2005 ;; accessed when FOO or (SETF FOO) is nondeterministic.
2006 ;; A small price to pay for a lot of error checking.
2007 `(make-nondeterministic-function
2008 :function
#',(cps-convert-function-name (second form
)))))
2009 (go (let ((tag (assoc (second form
) *tagbody-tags
*)))
2010 ;; note: Can't issue an error here if tag not found since it
2011 ;; might be outside the scope of a FOR-EFFECTS.
2012 (if (and tag
(second tag
)) `(,(second tag
)) form
)))
2013 (quote (error "This shouldn't happen"))
2015 (let ((tag (assoc (second form
) *block-tags
* :test
#'eq
))
2016 (value (perform-substitutions
2017 (if (= (length form
) 3) (third form
) nil
)
2019 ;; note: Can't issue an error here if tag not found since it
2020 ;; might be outside the scope of a FOR-EFFECTS.
2021 (if (and tag
(second tag
))
2022 (possibly-beta-reduce-funcall
2023 (second tag
) '() value
(fourth tag
))
2024 `(return-from ,(second form
) ,value
))))
2026 (expand-local-setq (rest form
) environment
)
2028 #'perform-substitutions form form-type environment
)))
2029 (tagbody (let ((*tagbody-tags
*
2030 (append (mapcar #'(lambda (tag) (list tag nil
))
2031 (remove-if #'consp
(rest form
)))
2034 #'perform-substitutions form form-type environment
)))
2035 (for-effects (perform-substitutions
2036 (let ((*macroexpand-hook
* #'funcall
))
2037 (macroexpand-1 form environment
))
2039 (local-setf (perform-substitutions
2040 (expand-local-setf (rest form
) environment
)
2042 (macro-call (error "This shouldn't happen"))
2043 (otherwise (process-subforms
2044 #'perform-substitutions form form-type environment
))))
2053 (defun-compile-time is-magic-declaration?
(form)
2055 (eq (first form
) 'declare
)
2057 (consp (second form
))
2058 (eq (first (second form
)) 'magic
)))
2060 (defun-compile-time is-magic-continuation?
(continuation)
2061 ;; Checks that CONTINUATION is of the form:
2062 ;; #'(lambda (...) (declare (magic) ...) ...)
2063 (and (consp continuation
)
2064 (eq (first continuation
) 'function
)
2065 (null (rest (last continuation
)))
2066 (= (length continuation
) 2)
2067 (lambda-expression?
(second continuation
))
2068 (>= (length (second continuation
)) 3)
2069 (is-magic-declaration?
(third (second continuation
)))))
2071 (defun-compile-time magic-continuation-argument
(continuation)
2072 (if (or (eq (first (second (second continuation
))) '&optional
)
2073 (eq (first (second (second continuation
))) '&rest
))
2074 (second (second (second continuation
)))
2075 (first (second (second continuation
)))))
2077 (defun-compile-time possibly-beta-reduce-funcall
2078 (continuation types form value?
)
2079 (unless (or (and (symbolp continuation
) (not (symbol-package continuation
)))
2080 (and (consp continuation
)
2081 (eq (first continuation
) 'function
)
2082 (null (rest (last continuation
)))
2083 (= (length continuation
) 2)
2084 (symbolp (second continuation
)))
2085 (is-magic-continuation? continuation
))
2086 (error "Please report this bug; This shouldn't happen (A)"))
2088 ((symbolp continuation
)
2092 `(multiple-value-call ,continuation
,form
)
2093 ;; note: This optimization is technically unsound if FORM
2094 ;; is a symbol macro that returns multiple values.
2095 `(funcall ,continuation
,form
))
2096 ;; note: This optimization assumes that there are no VALUES
2098 `(funcall ,continuation
(the (and ,@types
) ,form
)))
2099 `(progn ,form
(funcall ,continuation
))))
2100 ((symbolp (second continuation
))
2104 `(multiple-value-call ,continuation
,form
)
2105 ;; note: This optimization is technically unsound if FORM
2106 ;; is a symbol macro that returns multiple values.
2107 `(,(second continuation
) ,form
))
2108 ;; note: This optimization assumes that there are no VALUES
2110 `(,(second continuation
) (the (and ,@types
) ,form
)))
2111 `(progn ,form
(,(second continuation
)))))
2114 (if (null (second (second continuation
)))
2115 (error "Please report this bug; This shouldn't happen (B)"))
2117 ((eq (first (second (second continuation
))) '&rest
)
2119 `(let ((,(magic-continuation-argument continuation
)
2120 (multiple-value-list ,form
)))
2121 ;; Peal off LAMBDA, arguments, and DECLARE.
2122 ,@(rest (rest (rest (second continuation
)))))
2123 `(let ((,(magic-continuation-argument continuation
)
2124 (list (the (and ,@types
) ,form
))))
2125 ;; Peal off LAMBDA, arguments, and DECLARE.
2126 ,@(rest (rest (rest (second continuation
)))))))
2127 ((or (and (consp form
)
2129 (and (eq (first form
) 'function
)
2130 (null (rest (last form
)))
2132 (symbolp (second form
)))))
2133 (and (symbolp form
) (symbol-package form
))
2134 (symbol-package (magic-continuation-argument continuation
)))
2136 `(let ((,(magic-continuation-argument continuation
) ,form
))
2137 ,@(if (and *dynamic-extent?
* (is-magic-continuation? form
))
2140 ,(magic-continuation-argument continuation
)))))
2141 ;; Peal off LAMBDA, arguments, and DECLARE.
2142 ,@(rest (rest (rest (second continuation
)))))
2143 `(let ((,(magic-continuation-argument continuation
)
2144 (the (and ,@types
) ,form
)))
2147 ,(magic-continuation-argument continuation
)))
2148 ;; Peal off LAMBDA, arguments, and DECLARE.
2149 ,@(rest (rest (rest (second continuation
)))))))
2150 ;; note: This case may be unsoundly taken in the following cases:
2151 ;; a. (MAGIC-CONTINUATION-ARGUMENT CONTINUATION) is a
2152 ;; non-Screamer GENSYM. This can only happen if a
2153 ;; a BINDING-VARIABLE is a GENSYM in CPS-CONVERT-LET*.
2154 ;; b. FORM is a non-Screamer GENSYM
2157 (magic-continuation-argument continuation
)
2158 ;; Peal off LAMBDA, arguments, and DECLARE.
2159 `(progn ,@(rest (rest (rest (second continuation
)))))
2161 (subst `(the (and ,@types
) ,form
)
2162 (magic-continuation-argument continuation
)
2163 ;; Peal off LAMBDA, arguments, and DECLARE.
2164 `(progn ,@(rest (rest (rest (second continuation
)))))
2167 (unless (null (second (second continuation
)))
2168 (error "Please report this bug; This shouldn't happen (C)"))
2169 ;; Peal off LAMBDA, arguments, and DECLARE.
2170 `(progn ,form
,@(rest (rest (rest (second continuation
))))))))))
2172 (defun-compile-time void-continuation
(continuation)
2173 (unless (or (and (symbolp continuation
) (not (symbol-package continuation
)))
2174 (and (consp continuation
)
2175 (eq (first continuation
) 'function
)
2176 (null (rest (last continuation
)))
2177 (= (length continuation
) 2)
2178 (symbolp (second continuation
)))
2179 (is-magic-continuation? continuation
))
2180 (error "Please report this bug; This shouldn't happen (D)"))
2181 (let ((dummy-argument (gensym "DUMMY-")))
2182 ;; note: We could get rid of this bogosity by having two versions of each
2183 ;; nondeterministic function, one which returned a value and one which
2185 `#'(lambda (&rest
,dummy-argument
)
2187 (ignore ,dummy-argument
))
2188 ,@(cond ((symbolp continuation
) `((funcall ,continuation
)))
2189 ((symbolp (second continuation
)) `((,(second continuation
))))
2190 ;; Peal off LAMBDA, arguments, and DECLARE.
2191 (t (rest (rest (rest (second continuation
)))))))))
2193 (defun-compile-time cps-convert-function-name
(function-name)
2194 (if (symbolp function-name
)
2195 (intern (format nil
"~A-NONDETERMINISTIC" (string function-name
))
2196 (symbol-package function-name
))
2197 `(setf ,(intern (format nil
"~A-NONDETERMINISTIC"
2198 (string (second function-name
)))
2199 (symbol-package (second function-name
))))))
2201 (defun-compile-time cps-convert-block
2202 (name body continuation types value? environment
)
2203 (let* ((c (gensym "CONTINUATION-"))
2204 (*block-tags
* (cons (list name c types value?
) *block-tags
*)))
2205 (possibly-beta-reduce-funcall
2208 ,(cps-convert-progn body c types value? environment
))
2213 (defun-compile-time cps-convert-if
(antecedent
2220 (let ((c (gensym "CONTINUATION-"))
2221 (dummy-argument (gensym "DUMMY-"))
2222 (other-arguments (gensym "OTHER-")))
2223 (possibly-beta-reduce-funcall
2228 `#'(lambda (&optional
,dummy-argument
&rest
,other-arguments
)
2230 (ignore ,other-arguments
))
2232 ,(cps-convert consequent c types value? environment
)
2233 ,(cps-convert alternate c types value? environment
)))
2241 (defun-compile-time cps-convert-let
(bindings
2253 ,(cps-convert-progn body continuation types value? environment
))
2254 (let* ((binding (first bindings
))
2256 (if (symbolp binding
) binding
(first binding
)))
2258 (if (and (consp binding
) (= (length binding
) 2))
2261 (dummy-argument (gensym "DUMMY-"))
2262 (other-arguments (gensym "OTHER-")))
2265 `#'(lambda (&optional
,dummy-argument
&rest
,other-arguments
)
2267 (ignore ,other-arguments
))
2268 ,(cps-convert-let (rest bindings
)
2275 (cons (list binding-variable dummy-argument
)
2281 (defun-compile-time cps-convert-let
* (bindings
2289 (if (null declarations
)
2290 (cps-convert-progn body continuation types value? environment
)
2293 ,(cps-convert-progn body continuation types value? environment
)))
2294 (let* ((binding (first bindings
))
2296 (if (symbolp binding
) binding
(first binding
)))
2298 (if (and (consp binding
) (= (length binding
) 2))
2301 (other-arguments (gensym "OTHER-")))
2304 `#'(lambda (&optional
,binding-variable
&rest
,other-arguments
)
2306 (ignore ,other-arguments
))
2307 ,(cps-convert-let* (rest bindings
)
2318 (defun-compile-time cps-convert-multiple-value-call-internal
2319 (nondeterministic? function forms continuation types value? environment
2320 &optional arguments
)
2322 (if nondeterministic?
2323 ;; needs work: TYPES is never actually used in this branch.
2324 `(apply-nondeterministic-nondeterministic
2325 ,(if value? continuation
(void-continuation continuation
))
2327 (append ,@(reverse arguments
)))
2328 (possibly-beta-reduce-funcall
2331 `(apply ,function
(append ,@(reverse arguments
)))
2333 (let ((dummy-argument (gensym "DUMMY-")))
2336 `#'(lambda (&rest
,dummy-argument
)
2338 ,(cps-convert-multiple-value-call-internal
2339 nondeterministic? function
(rest forms
) continuation types value?
2340 environment
(cons dummy-argument arguments
)))
2345 (defun-compile-time cps-convert-multiple-value-call
2346 (nondeterministic? function forms continuation types value? environment
)
2347 (let ((dummy-argument (gensym "DUMMY-"))
2348 (other-arguments (gensym "OTHER-")))
2351 `#'(lambda (&optional
,dummy-argument
&rest
,other-arguments
)
2353 (ignore ,other-arguments
))
2354 ,(cps-convert-multiple-value-call-internal
2355 nondeterministic? dummy-argument forms continuation types value?
2361 (defun-compile-time cps-convert-multiple-value-prog1
2362 (form forms continuation types value? environment
)
2364 (let ((dummy-argument (gensym "DUMMY-")))
2367 `#'(lambda (&rest
,dummy-argument
)
2373 (possibly-beta-reduce-funcall
2374 continuation types
`(values-list ,dummy-argument
) t
))
2381 (cps-convert-progn (cons form forms
) continuation types nil environment
)))
2383 (defun-compile-time cps-convert-progn
2384 (body continuation types value? environment
)
2386 ((null body
) (possibly-beta-reduce-funcall continuation types nil value?
))
2388 (cps-convert (first body
) continuation types value? environment
))
2394 (rest body
) continuation types value? environment
))
2399 (defun-compile-time cps-convert-return-from
(name result environment
)
2400 (let ((tag (assoc name
*block-tags
* :test
#'eq
)))
2401 (if (and tag
(second tag
))
2402 (cps-convert result
(second tag
) (third tag
) (fourth tag
) environment
)
2403 ;; note: Can't issue an error here if tag not found since it might be
2404 ;; outside the scope of a FOR-EFFECTS. Thus we must compile a
2405 ;; RETURN-FROM nondeterministic code to deterministic code.
2406 ;; Likewise, can't issue an error here if tag is found but
2407 ;; (SECOND TAG) is NIL since this arrises when you have a
2408 ;; RETURN-FROM inside a FOR-EFFECTS to a tag outside the
2410 (let ((dummy-argument (gensym "DUMMY-")))
2413 `#'(lambda (&rest
,dummy-argument
)
2415 (return-from ,name
(values-list ,dummy-argument
)))
2420 (defun-compile-time cps-convert-setq
2421 (arguments continuation types value? environment
)
2422 (if (null arguments
)
2423 (possibly-beta-reduce-funcall continuation types nil value?
)
2424 (let ((dummy-argument (gensym "DUMMY-"))
2425 (other-arguments (gensym "OTHER-")))
2428 `#'(lambda (&optional
,dummy-argument
&rest
,other-arguments
)
2430 (ignore ,other-arguments
)
2431 ,@(if (and (null (rest (rest arguments
)))
2433 `((type (and ,@types
) ,dummy-argument
))))
2434 ,(if (null (rest (rest arguments
)))
2435 (possibly-beta-reduce-funcall
2438 `(setq ,(first arguments
) ,dummy-argument
)
2440 `(progn (setq ,(first arguments
) ,dummy-argument
)
2442 (rest (rest arguments
))
2447 (if (null (rest (rest arguments
))) types
'())
2451 (defun-compile-time cps-convert-tagbody
2452 (body continuation types value? environment
)
2453 (let ((segments (list (list 'header
)))
2454 (*tagbody-tags
* *tagbody-tags
*)) ;cool!
2457 (push form
(rest (first segments
)))
2458 (let ((c (gensym "CONTINUATION-")))
2459 (push (list form c
) *tagbody-tags
*)
2460 (push (list c
) segments
))))
2461 (push nil
(rest (first segments
)))
2462 (let ((segments (reverse segments
))
2463 (dummy-argument (gensym "DUMMY-"))
2464 (other-arguments (gensym "OTHER-")))
2465 ;; needs work: The closures created by LABELS functions aren't declared to
2466 ;; have DYNAMIC-EXTENT since I don't know how to do this in
2470 (let ((next (rest (member segment segments
:test
#'eq
))))
2472 (&optional
,dummy-argument
&rest
,other-arguments
)
2473 (declare (ignore ,dummy-argument
,other-arguments
))
2475 (reverse (rest segment
))
2476 (if next
`#',(first (first next
)) continuation
)
2481 ,(let ((next (rest segments
)))
2483 (reverse (rest (first segments
)))
2484 (if next
`#',(first (first next
)) continuation
)
2489 (defun-compile-time cps-convert-local-setf
/setq
2490 (arguments continuation types value? environment
)
2491 (if (null arguments
)
2492 (possibly-beta-reduce-funcall continuation types nil value?
)
2493 (let ((d (gensym "DUMMY-"))
2494 (dummy-argument (gensym "DUMMY-"))
2495 (other-arguments (gensym "OTHER-")))
2496 (cl:multiple-value-bind
(vars vals stores store-form access-form
)
2497 (get-setf-expansion (first arguments
) environment
)
2500 `#'(lambda (&optional
,dummy-argument
&rest
,other-arguments
)
2502 (ignore ,other-arguments
)
2503 ,@(if (and (null (rest (rest arguments
)))
2505 `((type (and ,@types
) ,dummy-argument
))))
2506 (let* (,@(mapcar #'list vars vals
) (,d
,access-form
))
2508 ,(if (null (rest (rest arguments
)))
2509 (possibly-beta-reduce-funcall
2512 (subst dummy-argument
(first stores
) store-form
)
2518 ,(cps-convert-local-setf/setq
2519 (rest (rest arguments
))
2524 ,(subst d
(first stores
) store-form
))))
2525 (if (null (rest (rest arguments
))) types
'())
2529 (defun-compile-time cps-convert-call
(function-name
2537 ;; needs work: TYPES is never actually used here.
2538 (if (null arguments
)
2539 (let ((c (gensym "CONTINUATION-")))
2540 (possibly-beta-reduce-funcall
2543 (,(cps-convert-function-name function-name
)
2545 ,@(reverse dummy-arguments
)))
2547 (if value? continuation
(void-continuation continuation
))
2549 (let ((dummy-argument (gensym "DUMMY-"))
2550 (other-arguments (gensym "OTHER-")))
2553 `#'(lambda (&optional
,dummy-argument
&rest
,other-arguments
)
2555 (ignore ,other-arguments
))
2563 (cons dummy-argument dummy-arguments
)))
2568 (defun-compile-time cps-non-convert-call
(function-name
2576 (if (null arguments
)
2577 (possibly-beta-reduce-funcall
2580 (if (not (null types
))
2581 `(the (and ,@types
) (,function-name
,@(reverse dummy-arguments
)))
2582 `(,function-name
,@(reverse dummy-arguments
)))
2584 (let ((dummy-argument (gensym "DUMMY-"))
2585 (other-arguments (gensym "OTHER-")))
2588 `#'(lambda (&optional
,dummy-argument
&rest
,other-arguments
)
2590 (ignore ,other-arguments
))
2591 ,(cps-non-convert-call
2598 (cons dummy-argument dummy-arguments
)))
2603 (defun-compile-time cps-convert
(form continuation types value? environment
)
2604 (walk #'(lambda (form form-type
)
2605 (if (and (not (eq form-type
'quote
))
2606 (deterministic? form environment
)
2607 (not (contains-local-setf/setq? form environment
)))
2608 (possibly-beta-reduce-funcall
2611 (perform-substitutions form environment
)
2614 (lambda-list (error "This shouldn't happen"))
2615 (variable (possibly-beta-reduce-funcall
2616 continuation types form value?
))
2617 (block (cps-convert-block (second form
)
2623 ((function-lambda function-symbol function-setf
)
2624 (possibly-beta-reduce-funcall
2627 (perform-substitutions form environment
)
2629 (go (error "This shouldn't happen"))
2630 (if (cps-convert-if (second form
)
2632 (if (null (rest (rest (rest form
))))
2639 (let (cl:multiple-value-bind
(body declarations
)
2640 (peal-off-documentation-string-and-declarations
2650 (let* (cl:multiple-value-bind
(body declarations
)
2651 (peal-off-documentation-string-and-declarations
2661 (multiple-value-call
2662 (cps-convert-multiple-value-call
2670 (multiple-value-prog1
2671 (cps-convert-multiple-value-prog1
2678 (progn (cps-convert-progn
2679 (rest form
) continuation types value? environment
))
2680 (quote (possibly-beta-reduce-funcall
2681 continuation types
(quotify form
) value?
))
2682 (return-from (cps-convert-return-from
2684 (if (= (length form
) 2) nil
(third form
))
2687 (cps-convert-local-setf/setq
2688 (rest form
) continuation types value? environment
)
2690 (rest form
) continuation types value? environment
)))
2691 (tagbody (cps-convert-tagbody
2692 (rest form
) continuation types value? environment
))
2693 (the (cps-convert (third form
)
2695 (cons (second form
) types
)
2698 (for-effects (possibly-beta-reduce-funcall
2699 continuation types form value?
))
2701 (cps-convert-local-setf/setq
2702 (rest form
) continuation types value? environment
))
2703 (multiple-value-call-nondeterministic
2704 (cps-convert-multiple-value-call
2712 (macro-call (error "This shouldn't happen"))
2714 (unless (deterministic-lambda-list?
2715 (second (first form
)) environment
)
2717 "Cannot (currently) handle a LAMDBA expression with~%~
2718 nondeterministic initializations forms for~%~
2719 &OPTIONAL and &AUX parameters: ~S"
2722 #'(lambda (argument)
2723 (and (symbolp argument
)
2724 (not (member argument lambda-list-keywords
2726 (second (first form
)))
2727 (error "Cannot (currently) handle a nondeterministic~%~
2728 form whose CAR is a LAMBDA expression with~%~
2729 lambda list keywords or arguments that are not~%~
2732 (unless (= (length (second (first form
)))
2733 (length (rest form
)))
2734 (error "The form ~S has a CAR which is a LAMBDA~%~
2735 expression which takes a different number of~%~
2736 arguments than it is called with"
2738 (cl:multiple-value-bind
(body declarations
)
2739 (peal-off-documentation-string-and-declarations
2740 (rest (rest (first form
))) t
)
2741 ;; note: The documentation string is lost for lambda calls
2742 ;; that are CPS Converted.
2744 (mapcar #'list
(second (first form
)) (rest form
))
2751 ((symbol-call setf-call
)
2752 (if (function-record-deterministic?
2753 (get-function-record (first form
)))
2754 (cps-non-convert-call (first form
)
2760 (cps-convert-call (first form
)
2768 "Cannot (currently) handle the special form ~S inside a~%~
2769 nondeterministic context."
2778 (defun-compile-time declare-deterministic
(function-name)
2779 (setf (function-record-deterministic?
(get-function-record function-name
)) t
))
2781 (defun-compile-time declare-nondeterministic
(function-name)
2782 (setf (function-record-deterministic?
(get-function-record function-name
))
2785 (defun-compile-time compute-callees
(body environment
)
2786 ;; note: What bogosity in CommonLisp! UNION should allow zero arguments and
2787 ;; return NIL as the identity element for use by REDUCE.
2790 (mapcar #'(lambda (form) (form-callees form environment
))
2791 (peal-off-documentation-string-and-declarations body t
))
2792 :initial-value
'()))
2794 (defun-compile-time cache-definition
(function-name lambda-list body callees
)
2795 (let ((function-record (get-function-record function-name
)))
2796 (setf (function-record-lambda-list function-record
) lambda-list
)
2797 (setf (function-record-body function-record
) body
)
2798 (setf (function-record-callees function-record
) callees
)))
2800 (defun-compile-time determine-whether-deterministic
(function-name environment
)
2801 ;; note: This is using the current rather than the saved ENVIRONMENT.
2802 (let* ((function-record (get-function-record function-name
)))
2803 (setf (function-record-deterministic? function-record
)
2804 (and (every #'(lambda (form) (deterministic? form environment
))
2805 (peal-off-documentation-string-and-declarations
2806 (function-record-body function-record
) t
))
2807 (deterministic-lambda-list?
2808 (function-record-lambda-list function-record
) environment
)))))
2810 (defun-compile-time determine-whether-callers-are-deterministic
2811 (function-name function-names environment
)
2812 ;; note: This is using the current rather than the saved ENVIRONMENT.
2813 (dolist (caller (callers function-name
))
2814 (unless (member caller function-names
:test
#'equal
)
2815 (determine-whether-deterministic caller environment
)
2816 (determine-whether-callers-are-deterministic
2817 caller
(cons caller function-names
) environment
))))
2819 (defun-compile-time function-definition
(function-name environment
)
2820 ;; note: This is using the current rather than the saved ENVIRONMENT.
2821 (let* ((function-record (get-function-record function-name
))
2822 (lambda-list (function-record-lambda-list function-record
))
2823 (body (function-record-body function-record
)))
2824 (cl:multiple-value-bind
(body declarations documentation-string
)
2825 (peal-off-documentation-string-and-declarations body t
)
2826 (if (function-record-deterministic? function-record
)
2827 (let ((*block-tags
* (list (list function-name nil
))))
2828 ;; needs work: To process subforms of lambda list.
2829 (list `(cl:defun
,function-name
,lambda-list
2830 ,@(if documentation-string
(list documentation-string
))
2832 ,@(mapcar #'(lambda (form)
2833 (perform-substitutions form environment
))
2835 `(declare-deterministic ',function-name
)))
2836 (let* ((continuation (gensym "CONTINUATION-"))
2837 ;; note: Could provide better TYPES and VALUE? here.
2838 (*block-tags
* (list (list function-name continuation
'() t
))))
2839 (list `(cl:defun
,function-name
,lambda-list
2840 ,@(if documentation-string
(list documentation-string
))
2847 #'(lambda (argument)
2848 (if (consp argument
)
2849 (if (and (consp (rest argument
))
2850 (consp (rest (rest argument
))))
2851 (list (first argument
) (third argument
))
2852 (list (first argument
)))
2856 lambda-list-keywords
2859 "Function ~S is a nondeterministic function. As such, it~%~
2860 must be called only from a nondeterministic context."
2862 `(cl:defun
,(cps-convert-function-name function-name
)
2863 (,continuation
,@lambda-list
)
2864 ,@(if documentation-string
(list documentation-string
))
2866 ,continuation
;ignore
2867 ,(cps-convert-progn body continuation
'() t environment
))
2868 `(declare-nondeterministic ',function-name
)))))))
2870 (defun-compile-time modified-function-definitions
(function-name environment
)
2871 ;; note: This is using the current rather than the saved ENVIRONMENT.
2872 (let ((function-record (get-function-record function-name
))
2873 (callers (indirect-callers function-name
))
2874 (function-records '()))
2875 (setf (function-record-old-deterministic? function-record
)
2876 (function-record-deterministic? function-record
))
2877 (setf (function-record-deterministic? function-record
) t
)
2878 (push function-record function-records
)
2879 (dolist (caller callers
)
2880 (let ((function-record (get-function-record caller
)))
2881 (unless (member function-record function-records
:test
#'eq
)
2882 (setf (function-record-old-deterministic? function-record
)
2883 (function-record-deterministic? function-record
))
2884 (setf (function-record-deterministic? function-record
) t
)
2885 (push function-record function-records
))))
2886 (dolist (caller callers
)
2887 (dolist (callee (callees caller
))
2888 (let ((function-record (get-function-record callee
)))
2889 (unless (member function-record function-records
:test
#'eq
)
2890 (setf (function-record-old-deterministic? function-record
)
2891 (function-record-deterministic? function-record
))
2892 (push function-record function-records
)))))
2893 (determine-whether-deterministic function-name environment
)
2894 (determine-whether-callers-are-deterministic function-name nil environment
)
2895 (let ((definitions (function-definition function-name environment
)))
2896 (unless (eq (not (function-record-deterministic? function-record
))
2897 (not (function-record-old-deterministic? function-record
)))
2898 (dolist (caller callers
)
2899 (if (and (not (equal caller function-name
))
2900 (some #'(lambda (callee)
2901 (let ((function-record (get-function-record callee
)))
2902 (not (eq (not (function-record-deterministic?
2904 (not (function-record-old-deterministic?
2905 function-record
))))))
2908 (append (function-definition caller environment
)
2910 ;; note: This is so that macroexpand without compile doesn't get out of
2912 (dolist (function-record function-records
)
2913 (setf (function-record-deterministic? function-record
)
2914 (function-record-old-deterministic? function-record
)))
2919 (defmacro-compile-time defun
2920 (function-name lambda-list
&body body
&environment environment
)
2921 (let ((*nondeterministic-context?
* t
))
2922 (check-function-name function-name
)
2923 (let* ((callees (compute-callees body environment
))
2924 (function-record (get-function-record function-name
))
2925 (function-record-lambda-list
2926 (function-record-lambda-list function-record
))
2927 (function-record-body (function-record-body function-record
))
2928 (function-record-callees (function-record-callees function-record
))
2929 (function-record-deterministic?
2930 (function-record-deterministic? function-record
))
2931 (function-record-old-deterministic?
2932 (function-record-old-deterministic? function-record
))
2933 (function-record-screamer?
2934 (function-record-screamer? function-record
)))
2935 (cache-definition function-name lambda-list body callees
)
2936 (let ((modified-function-definitions
2937 ;; note: This is using the current rather than the saved ENVIRONMENT.
2938 (modified-function-definitions function-name environment
)))
2939 ;; note: This is so that macroexpand without compile doesn't get out of
2941 (setf (function-record-lambda-list function-record
)
2942 function-record-lambda-list
)
2943 (setf (function-record-body function-record
) function-record-body
)
2944 (setf (function-record-callees function-record
)
2945 function-record-callees
)
2946 (setf (function-record-deterministic? function-record
)
2947 function-record-deterministic?
)
2948 (setf (function-record-old-deterministic? function-record
)
2949 function-record-old-deterministic?
)
2950 (setf (function-record-screamer? function-record
)
2951 function-record-screamer?
)
2952 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
2953 (cache-definition ',function-name
',lambda-list
',body
',callees
)
2954 ,@modified-function-definitions
2955 ',function-name
)))))
2957 (defmacro-compile-time either
(&body forms
)
2958 (case (length forms
)
2961 (otherwise `(if (a-boolean) ,(first forms
) (either ,@(rest forms
))))))
2963 (defmacro-compile-time local
(&body forms
&environment environment
)
2966 #'(lambda (form) (perform-substitutions form environment
))
2969 (defmacro-compile-time global
(&body forms
&environment environment
)
2970 (let ((*local?
* nil
))
2972 #'(lambda (form) (perform-substitutions form environment
))
2975 (defmacro-compile-time for-effects
(&body forms
&environment environment
)
2977 ,(let ((*nondeterministic-context?
* t
))
2978 (cps-convert-progn forms
'#'fail nil nil environment
))))
2980 (defmacro-compile-time one-value
(form1 &optional
(form2 nil form2?
))
2982 (for-effects (return-from one-value
,form1
))
2983 ,(if form2? form2
'(fail))))
2985 (defmacro-compile-time possibly?
(&body forms
)
2986 `(one-value (let ((value (progn ,@forms
))) (unless value
(fail)) value
) nil
))
2988 (defmacro-compile-time necessarily?
(&body forms
)
2991 (let ((value (progn ,@forms
)))
2992 (when value
(setf result value
) (fail))
2996 (defmacro-compile-time all-values
(&body forms
)
2998 (last-value-cons nil
))
3000 (let ((value (progn ,@forms
)))
3001 (global (cond ((null values
)
3002 (setf last-value-cons
(list value
))
3003 (setf values last-value-cons
))
3004 (t (setf (rest last-value-cons
) (list value
))
3005 (setf last-value-cons
(rest last-value-cons
)))))))
3008 (defmacro-compile-time ith-value
(i form1
&optional
(form2 nil form2?
))
3010 (let ((i (value-of ,i
)))
3011 (for-effects (let ((value ,form1
))
3012 (if (zerop i
) (return-from ith-value value
))
3014 ,(if form2? form2
'(fail)))))
3016 (defun trail (function)
3017 ;; note: Is it really better to use VECTOR-PUSH-EXTEND than CONS for the
3019 (if *nondeterministic?
* (vector-push-extend function
*trail
* 1024)))
3022 (&optional
(format-string nil format-string?
) &rest format-args
)
3025 (let ((query (if format-string?
3026 (format nil
"~A (Y or N): "
3027 (apply #'format nil format-string format-args
))
3029 (emacs-eval '(y-or-n-p-begin))
3033 (format *query-io
* "~%~A" query
)
3034 (let ((char (read-char *query-io
*)))
3035 (when (or (char= char
#\y
) (char= char
#\Y
))
3036 (format *query-io
* "Y")
3037 (return-from y-or-n-p t
))
3038 (when (or (char= char
#\n) (char= char
#\N
))
3039 (format *query-io
* "N")
3040 (return-from y-or-n-p nil
)))
3041 (format *query-io
* "Please type a single character, Y or N")
3043 (emacs-eval '(y-or-n-p-end)))))
3044 (format-string?
(apply #'cl
:y-or-n-p format-string format-args
))
3047 (defmacro-compile-time print-values
(&body forms
)
3050 (let ((value (progn ,@forms
)))
3052 (unless (y-or-n-p "Do you want another solution?")
3053 (throw 'succeed value
))))))
3055 ;;; note: Should have way of having a stream of values.
3057 (eval-when (:compile-toplevel
:load-toplevel
:execute
) (setf *screamer?
* t
))
3059 (defun print-nondeterministic-function
3060 (nondeterministic-function stream print-level
)
3061 (declare (ignore print-level
))
3062 (format stream
"#<~A ~S>"
3064 (nondeterministic-function-function nondeterministic-function
)))
3066 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
3067 (declare-nondeterministic 'a-boolean
))
3069 (cl:defun
a-boolean ()
3071 "A-BOOLEAN is a nondeterministic function. As such, it must be called only~%~
3072 from a nondeterministic context."))
3074 (cl:defun
a-boolean-nondeterministic (continuation)
3075 (choice-point (funcall continuation t
))
3076 (funcall continuation nil
))
3078 (defun fail () (throw 'fail nil
))
3080 (defmacro-compile-time when-failing
((&body failing-forms
) &body forms
)
3081 (let ((old-fail (gensym "FAIL-")))
3082 `(let ((,old-fail
#'fail
))
3084 (progn (setf (symbol-function 'fail
)
3085 #'(lambda () ,@failing-forms
(funcall ,old-fail
)))
3087 (setf (symbol-function 'fail
) ,old-fail
)))))
3089 (defmacro-compile-time count-failures
(&body forms
)
3090 (let ((values (gensym "VALUES-")))
3091 `(let ((failure-count 0))
3092 (when-failing ((incf failure-count
))
3093 (let ((,values
(multiple-value-list (progn ,@forms
))))
3094 (format t
"Failures = ~10<~;~d~>" failure-count
)
3095 (values-list ,values
))))))
3097 (defun nondeterministic-function?
(thing)
3098 (nondeterministic-function?-internal
(value-of thing
)))
3100 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
3101 (declare-nondeterministic 'funcall-nondeterministic
))
3103 (cl:defun
funcall-nondeterministic (function &rest arguments
)
3104 (declare (ignore function arguments
))
3106 "FUNCALL-NONDETERMINISTIC is a nondeterministic function. As such, it~%~
3107 must be called only from a nondeterministic context."))
3109 (cl:defun
funcall-nondeterministic-nondeterministic
3110 (continuation function
&rest arguments
)
3111 (let ((function (value-of function
)))
3112 (if (nondeterministic-function? function
)
3113 (apply (nondeterministic-function-function function
)
3116 (funcall continuation
(apply function arguments
)))))
3118 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
3119 (declare-nondeterministic 'apply-nondeterministic
))
3121 (cl:defun
apply-nondeterministic (function argument
&rest arguments
)
3122 (declare (ignore function argument arguments
))
3124 "APPLY-NONDETERMINISTIC is a nondeterministic function. As such, it must~%~
3125 be called only from a nondeterministic context."))
3127 (cl:defun
apply-nondeterministic-nondeterministic
3128 (continuation function argument
&rest arguments
)
3129 (let ((function (value-of function
)))
3130 (if (nondeterministic-function? function
)
3131 ;; note: I don't know how to avoid the consing here.
3132 (apply (nondeterministic-function-function function
)
3134 (apply #'list
* (cons argument arguments
)))
3135 (funcall continuation
(apply function argument arguments
)))))
3137 (defmacro-compile-time multiple-value-bind
3138 (variables form
&body body
&environment environment
)
3139 (if (every #'(lambda (form) (deterministic? form environment
))
3140 (peal-off-documentation-string-and-declarations body
))
3141 `(cl:multiple-value-bind
,variables
,form
,@body
)
3142 (let ((other-arguments (gensym "OTHER-")))
3143 `(multiple-value-call-nondeterministic
3144 #'(lambda (&optional
,@variables
&rest
,other-arguments
)
3145 (declare (ignore ,other-arguments
))
3149 (defun unwind-trail ()
3152 (if (zerop (fill-pointer *trail
*)) (return-from unwind-trail
))
3153 (funcall (vector-pop *trail
*))
3154 ;; note: This is to allow the trail closures to be garbage collected.
3155 (setf (aref *trail
* (fill-pointer *trail
*)) nil
)
3158 (defun purge (function-name)
3159 (remhash (value-of function-name
) *function-record-table
*)
3162 (defun unwedge-screamer ()
3163 (maphash #'(lambda (function-name function-record
)
3164 (unless (function-record-screamer? function-record
)
3165 (remhash function-name
*function-record-table
*)))
3166 *function-record-table
*)
3169 ;;; note: These optimized versions of AN-INTEGER, AN-INTEGER-ABOVE,
3170 ;;; AN-INTEGER-BELOW, AN-INTEGER-BETWEEN and A-MEMBER-OF have different
3171 ;;; failure behavior as far as WHEN-FAILING is concerned than the
3172 ;;; original purely Screamer versions. This is likely to affect only
3173 ;;; failure counts generated by COUNT-FAILURES. A small price to pay for
3174 ;;; tail recursion optimization.
3176 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
3177 (declare-nondeterministic 'an-integer
))
3179 (cl:defun
an-integer ()
3181 "AN-INTEGER is a nondeterministic function. As such, it must be called~%~
3182 only from a nondeterministic context."))
3184 (cl:defun
an-integer-nondeterministic (continuation)
3185 (choice-point-external
3186 (choice-point-internal (funcall continuation
0))
3188 (loop (choice-point-internal (funcall continuation i
))
3189 (choice-point-internal (funcall continuation
(- i
)))
3192 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
3193 (declare-nondeterministic 'an-integer-above
))
3195 (cl:defun
an-integer-above (low)
3196 (declare (ignore low
))
3198 "AN-INTEGER-ABOVE is a nondeterministic function. As such, it must be~%~
3199 called only from a nondeterministic context."))
3201 (cl:defun
an-integer-above-nondeterministic (continuation low
)
3202 (let ((low (ceiling (value-of low
))))
3203 (choice-point-external
3205 (loop (choice-point-internal (funcall continuation i
))
3208 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
3209 (declare-nondeterministic 'an-integer-below
))
3211 (cl:defun
an-integer-below (high)
3212 (declare (ignore high
))
3214 "AN-INTEGER-BELOW is a nondeterministic function. As such, it must be~%~
3215 called only from a nondeterministic context."))
3217 (cl:defun
an-integer-below-nondeterministic (continuation high
)
3218 (let ((high (floor (value-of high
))))
3219 (choice-point-external
3221 (loop (choice-point-internal (funcall continuation i
))
3224 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
3225 (declare-nondeterministic 'an-integer-between
))
3227 (cl:defun
an-integer-between (low high
)
3228 (declare (ignore low high
))
3230 "AN-INTEGER-BETWEEN is a nondeterministic function. As such, it must be~%~
3231 called only from a nondeterministic context."))
3233 (cl:defun
an-integer-between-nondeterministic (continuation low high
)
3234 (let ((low (ceiling (value-of low
)))
3235 (high (floor (value-of high
))))
3236 (unless (> low high
)
3237 (choice-point-external
3238 (do ((i low
(1+ i
))) ((= i high
))
3239 (choice-point-internal (funcall continuation i
))))
3240 (funcall continuation high
))))
3242 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
3243 (declare-nondeterministic 'a-member-of
))
3245 (cl:defun
a-member-of (sequence)
3246 (declare (ignore sequence
))
3248 "A-MEMBER-OF is a nondeterministic function. As such, it must be called~%~
3249 only from a nondeterministic context."))
3251 (cl:defun
a-member-of-nondeterministic (continuation sequence
)
3252 (let ((sequence (value-of sequence
)))
3255 (unless (null sequence
)
3256 (choice-point-external
3257 (loop (if (null (rest sequence
)) (return))
3258 (choice-point-internal (funcall continuation
(first sequence
)))
3259 (setf sequence
(value-of (rest sequence
)))))
3260 (funcall continuation
(first sequence
))))
3262 (let ((n (1- (length sequence
))))
3264 (choice-point-external
3266 (choice-point-internal (funcall continuation
(aref sequence i
)))))
3267 (funcall continuation
(aref sequence n
)))))
3268 (t (error "SEQUENCE must be a sequence")))))
3270 ;;; note: The following two functions work only when Screamer is running under
3271 ;;; ILisp/GNUEmacs with iscream.el loaded.
3273 (defun emacs-eval (expression)
3275 (error "Cannot do EMACS-EVAL unless Screamer is running under~%~
3276 ILisp/GNUEmacs with iscream.el loaded."))
3277 (format *terminal-io
* "~A~A~A"
3278 (format nil
"~A" (code-char 27))
3279 (string-downcase (format nil
"~A" expression
))
3280 (format nil
"~A" (code-char 29))))
3282 (defmacro-compile-time local-output
(&body forms
)
3285 (error "Cannot do LOCAL-OUTPUT unless Screamer is running under~%~
3286 ILisp/GNUEmacs with iscream.el loaded."))
3287 (trail #'(lambda () (emacs-eval '(pop-end-marker))))
3288 (emacs-eval '(push-end-marker))
3293 (defvar *name
* 0 "The counter for anonymous names.")
3295 (defvar *minimum-shrink-ratio
* 1e-2
3296 "Ignore propagations which reduce the range of a variable by less than this
3299 (defvar *maximum-discretization-range
* 20
3300 "Discretize integer variables whose range is not greater than this number.
3301 Discretize all integer variables if NIL.
3302 Must be an integer or NIL.")
3304 (defvar *strategy
* :gfc
3305 "Strategy to use for FUNCALLV and APPLYV: either :GFC or :AC")
3307 ;;; note: Enable this to use CLOS instead of DEFSTRUCT for variables.
3309 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
3310 (pushnew :screamer-clos
*features
* :test
#'eq
))
3313 (defstruct-compile-time (variable (:print-function print-variable
)
3314 (:predicate variable?
)
3315 (:constructor make-variable-internal
))
3318 (enumerated-domain t
)
3319 (enumerated-antidomain nil
)
3321 (possibly-integer? t
)
3322 (possibly-noninteger-real? t
)
3323 (possibly-nonreal-number? t
)
3324 (possibly-boolean? t
)
3325 (possibly-nonboolean-nonnumber? t
)
3330 (defclass variable
()
3331 ((name :accessor variable-name
:initarg
:name
)
3332 (noticers :accessor variable-noticers
:initform nil
)
3333 (enumerated-domain :accessor variable-enumerated-domain
:initform t
)
3334 (enumerated-antidomain :accessor variable-enumerated-antidomain
3336 (value :accessor variable-value
)
3337 (possibly-integer?
:accessor variable-possibly-integer?
:initform t
)
3338 (possibly-noninteger-real?
:accessor variable-possibly-noninteger-real?
3340 (possibly-nonreal-number?
:accessor variable-possibly-nonreal-number?
3342 (possibly-boolean?
:accessor variable-possibly-boolean?
:initform t
)
3343 (possibly-nonboolean-nonnumber?
3344 :accessor variable-possibly-nonboolean-nonnumber?
3346 (lower-bound :accessor variable-lower-bound
:initform nil
)
3347 (upper-bound :accessor variable-upper-bound
:initform nil
)))
3350 (defmethod print-object ((variable variable
) stream
)
3351 (print-variable variable stream nil
))
3354 (defun-compile-time variable?
(thing) (typep thing
'variable
))
3356 (defun booleanp (x) (typep x
'boolean
))
3358 (defun infinity-min (x y
) (and x y
(min x y
)))
3360 (defun infinity-max (x y
) (and x y
(max x y
)))
3362 (defun infinity-+ (x y
) (and x y
(+ x y
)))
3364 (defun infinity-- (x y
) (and x y
(- x y
)))
3366 (defun infinity-* (x y
) (and x y
(* x y
)))
3368 (defun contains-variables?
(x)
3370 (cons (or (contains-variables?
(car x
)) (contains-variables?
(cdr x
))))
3374 (defun eliminate-variables (x)
3375 (if (contains-variables? x
)
3377 (cons (eliminate-variables (car x
)) (eliminate-variables (cdr x
)))
3378 (eliminate-variables (variable-value x
)))
3381 (defun print-variable (x stream print-level
)
3382 (declare (ignore print-level
))
3383 (let ((x (value-of x
)))
3386 (if (and (not (eq (variable-enumerated-domain x
) t
))
3387 (not (null (variable-enumerated-antidomain x
))))
3388 (error "This shouldn't happen"))
3389 (format stream
"[~S" (variable-name x
))
3391 (cond ((variable-boolean? x
) " Boolean")
3392 ((variable-integer? x
) " integer")
3394 (if (variable-noninteger? x
) " noninteger-real" " real"))
3395 ((variable-number? x
)
3396 (cond ((variable-nonreal? x
) " nonreal-number")
3397 ((variable-noninteger? x
) " noninteger-number")
3399 ((variable-nonnumber? x
) " nonnumber")
3400 ((variable-nonreal? x
) " nonreal")
3401 ((variable-noninteger? x
) " noninteger")
3403 (if (variable-real? x
)
3404 (if (variable-lower-bound x
)
3405 (if (variable-upper-bound x
)
3406 (format stream
" ~D:~D"
3407 (variable-lower-bound x
) (variable-upper-bound x
))
3408 (format stream
" ~D:" (variable-lower-bound x
)))
3409 (if (variable-upper-bound x
)
3410 (format stream
" :~D" (variable-upper-bound x
)))))
3411 (if (and (not (eq (variable-enumerated-domain x
) t
))
3412 (not (variable-boolean? x
)))
3413 (format stream
" enumerated-domain:~S"
3414 (variable-enumerated-domain x
)))
3415 (if (not (null (variable-enumerated-antidomain x
)))
3416 (format stream
" enumerated-antidomain:~S"
3417 (variable-enumerated-antidomain x
)))
3418 (format stream
"]"))
3419 (t (format stream
"~S" x
)))))
3421 (defun make-variable (&optional
(name nil name?
))
3424 (make-variable-internal :name
(if name? name
(incf *name
*)))
3426 (make-instance 'variable
:name
(if name? name
(incf *name
*)))))
3427 (setf (variable-value variable
) variable
)
3430 (defun variable-integer?
(x)
3431 (and (not (variable-possibly-boolean? x
))
3432 (not (variable-possibly-nonboolean-nonnumber? x
))
3433 (not (variable-possibly-nonreal-number? x
))
3434 (not (variable-possibly-noninteger-real? x
))
3435 (variable-possibly-integer? x
)))
3437 (defun variable-noninteger?
(x)
3438 (and (or (variable-possibly-boolean? x
)
3439 (variable-possibly-nonboolean-nonnumber? x
)
3440 (variable-possibly-nonreal-number? x
)
3441 (variable-possibly-noninteger-real? x
))
3442 (not (variable-possibly-integer? x
))))
3444 (defun variable-real?
(x)
3445 (and (not (variable-possibly-boolean? x
))
3446 (not (variable-possibly-nonboolean-nonnumber? x
))
3447 (not (variable-possibly-nonreal-number? x
))
3448 (or (variable-possibly-noninteger-real? x
)
3449 (variable-possibly-integer? x
))))
3451 (defun variable-nonreal?
(x)
3452 (and (or (variable-possibly-boolean? x
)
3453 (variable-possibly-nonboolean-nonnumber? x
)
3454 (variable-possibly-nonreal-number? x
))
3455 (not (variable-possibly-noninteger-real? x
))
3456 (not (variable-possibly-integer? x
))))
3458 (defun variable-number?
(x)
3459 (and (not (variable-possibly-boolean? x
))
3460 (not (variable-possibly-nonboolean-nonnumber? x
))
3461 (or (variable-possibly-nonreal-number? x
)
3462 (variable-possibly-noninteger-real? x
)
3463 (variable-possibly-integer? x
))))
3465 (defun variable-nonnumber?
(x)
3466 (and (or (variable-possibly-boolean? x
)
3467 (variable-possibly-nonboolean-nonnumber? x
))
3468 (not (variable-possibly-nonreal-number? x
))
3469 (not (variable-possibly-noninteger-real? x
))
3470 (not (variable-possibly-integer? x
))))
3472 (defun variable-boolean?
(x)
3473 (and (variable-possibly-boolean? x
)
3474 (not (variable-possibly-nonboolean-nonnumber? x
))
3475 (not (variable-possibly-nonreal-number? x
))
3476 (not (variable-possibly-noninteger-real? x
))
3477 (not (variable-possibly-integer? x
))))
3479 (defun variable-nonboolean?
(x)
3480 (and (not (variable-possibly-boolean? x
))
3481 (or (variable-possibly-nonboolean-nonnumber? x
)
3482 (variable-possibly-nonreal-number? x
)
3483 (variable-possibly-noninteger-real? x
)
3484 (variable-possibly-integer? x
))))
3486 (defun variable-true?
(x) (eq (variable-value x
) t
))
3488 (defun variable-false?
(x) (null (variable-value x
)))
3493 (if (or (not (variable? x
))
3494 #+screamer-clos
(not (slot-boundp x
'value
))
3495 (eq (variable-value x
) x
))
3496 (return-from value-of x
))
3497 (setf x
(variable-value x
))
3500 (defun variablize (x)
3504 (if (or (not (variable?
(variable-value x
)))
3505 (eq (variable-value x
) x
))
3506 (return-from variablize x
))
3507 (setf x
(variable-value x
))
3509 (let ((y (make-variable))) (restrict-value! y x
) y
)))
3511 (defun bound?
(x) (not (variable?
(value-of x
))))
3514 (let ((x (value-of x
)))
3515 (and (not (variable? x
))
3516 (or (not (consp x
)) (and (ground?
(car x
)) (ground?
(cdr x
)))))))
3518 (defun apply-substitution (x)
3519 (let ((x (value-of x
)))
3521 (cons (apply-substitution (car x
)) (apply-substitution (cdr x
)))
3524 (defun occurs-in?
(x value
)
3525 ;; note: X must be a variable such that (EQ X (VALUE-OF X)).
3526 ;; note: Will loop if VALUE is circular.
3529 ((and (variable? value
) (not (eq value
(variable-value value
))))
3530 (occurs-in? x
(variable-value value
)))
3531 ((consp value
) (or (occurs-in? x
(car value
)) (occurs-in? x
(cdr value
))))
3534 (defun attach-noticer!-internal
(noticer x
)
3535 ;; note: Will loop if X is circular.
3537 (cons (attach-noticer!-internal noticer
(car x
))
3538 (attach-noticer!-internal noticer
(cdr x
)))
3539 (variable (if (eq x
(variable-value x
))
3540 ;; note: I can't remember why this check for duplication is
3542 (unless (member noticer
(variable-noticers x
) :test
#'eq
)
3543 ;; note: This can't be a PUSH because of the Lucid screw.
3544 (local (setf (variable-noticers x
)
3545 (cons noticer
(variable-noticers x
)))))
3546 (attach-noticer!-internal noticer
(variable-value x
))))))
3548 (defun attach-noticer! (noticer x
)
3549 (attach-noticer!-internal noticer x
)
3552 (defun run-noticers (x)
3553 (dolist (noticer (variable-noticers x
)) (funcall noticer
)))
3557 (defun restrict-integer! (x)
3558 ;; note: X must be a variable.
3559 (unless (variable-possibly-integer? x
) (fail))
3560 (if (or (eq (variable-value x
) x
) (not (variable?
(variable-value x
))))
3562 (when (variable-possibly-noninteger-real? x
)
3563 (local (setf (variable-possibly-noninteger-real? x
) nil
))
3565 (when (variable-possibly-nonreal-number? x
)
3566 (local (setf (variable-possibly-nonreal-number? x
) nil
))
3568 (when (variable-possibly-boolean? x
)
3569 (local (setf (variable-possibly-boolean? x
) nil
))
3571 (when (variable-possibly-nonboolean-nonnumber? x
)
3572 (local (setf (variable-possibly-nonboolean-nonnumber? x
) nil
))
3574 (when (and (variable-lower-bound x
)
3575 (not (integerp (variable-lower-bound x
))))
3576 (if (and (variable-upper-bound x
)
3577 (< (variable-upper-bound x
)
3578 (ceiling (variable-lower-bound x
))))
3580 (local (setf (variable-lower-bound x
)
3581 (ceiling (variable-lower-bound x
))))
3583 (when (and (variable-upper-bound x
)
3584 (not (integerp (variable-upper-bound x
))))
3585 (if (and (variable-lower-bound x
)
3586 (> (variable-lower-bound x
)
3587 (floor (variable-upper-bound x
))))
3589 (local (setf (variable-upper-bound x
) (floor (variable-upper-bound x
))))
3592 (cond ((eq (variable-enumerated-domain x
) t
)
3593 (if (and (variable-lower-bound x
)
3594 (variable-upper-bound x
)
3595 (or (null *maximum-discretization-range
*)
3596 (<= (- (variable-upper-bound x
)
3597 (variable-lower-bound x
))
3598 *maximum-discretization-range
*)))
3599 (set-enumerated-domain!
3600 x
(all-values (an-integer-between
3601 (variable-lower-bound x
)
3602 (variable-upper-bound x
))))))
3603 ((not (every #'integerp
(variable-enumerated-domain x
)))
3604 ;; note: Could do less consing if had LOCAL DELETE-IF.
3605 ;; This would also allow checking list only once.
3606 (set-enumerated-domain!
3607 x
(remove-if-not #'integerp
(variable-enumerated-domain x
)))))
3608 (run-noticers x
)))))
3610 (defun restrict-noninteger! (x)
3611 ;; note: X must be a variable.
3612 (unless (or (variable-possibly-noninteger-real? x
)
3613 (variable-possibly-nonreal-number? x
)
3614 (variable-possibly-boolean? x
)
3615 (variable-possibly-nonboolean-nonnumber? x
))
3617 (when (and (or (eq (variable-value x
) x
) (not (variable?
(variable-value x
))))
3618 (variable-possibly-integer? x
))
3619 (local (setf (variable-possibly-integer? x
) nil
))
3620 (if (and (not (eq (variable-enumerated-domain x
) t
))
3621 (some #'integerp
(variable-enumerated-domain x
)))
3622 ;; note: Could do less consing if had LOCAL DELETE-IF.
3623 ;; This would also allow checking list only once.
3624 (set-enumerated-domain!
3625 x
(remove-if #'integerp
(variable-enumerated-domain x
))))
3628 (defun restrict-real! (x)
3629 ;; note: X must be a variable.
3630 (unless (or (variable-possibly-integer? x
)
3631 (variable-possibly-noninteger-real? x
))
3633 (if (or (eq (variable-value x
) x
) (not (variable?
(variable-value x
))))
3635 (when (variable-possibly-nonreal-number? x
)
3636 (local (setf (variable-possibly-nonreal-number? x
) nil
))
3638 (when (variable-possibly-boolean? x
)
3639 (local (setf (variable-possibly-boolean? x
) nil
))
3641 (when (variable-possibly-nonboolean-nonnumber? x
)
3642 (local (setf (variable-possibly-nonboolean-nonnumber? x
) nil
))
3645 (if (and (not (eq (variable-enumerated-domain x
) t
))
3646 (not (every #'realp
(variable-enumerated-domain x
))))
3647 ;; note: Could do less consing if had LOCAL DELETE-IF.
3648 ;; This would also allow checking list only once.
3649 (set-enumerated-domain!
3650 x
(remove-if-not #'realp
(variable-enumerated-domain x
))))
3651 (run-noticers x
)))))
3653 (defun restrict-nonreal! (x)
3654 ;; note: X must be a variable.
3655 (unless (or (variable-possibly-nonreal-number? x
)
3656 (variable-possibly-boolean? x
)
3657 (variable-possibly-nonboolean-nonnumber? x
))
3659 (if (or (eq (variable-value x
) x
) (not (variable?
(variable-value x
))))
3661 (when (variable-possibly-integer? x
)
3662 (local (setf (variable-possibly-integer? x
) nil
))
3664 (when (variable-possibly-noninteger-real? x
)
3665 (local (setf (variable-possibly-noninteger-real? x
) nil
))
3668 (if (and (not (eq (variable-enumerated-domain x
) t
))
3669 (some #'realp
(variable-enumerated-domain x
)))
3670 ;; note: Could do less consing if had LOCAL DELETE-IF.
3671 ;; This would also allow checking list only once.
3672 (set-enumerated-domain!
3673 x
(remove-if #'realp
(variable-enumerated-domain x
))))
3674 (run-noticers x
)))))
3676 (defun restrict-number! (x)
3677 ;; note: X must be a variable.
3678 (unless (or (variable-possibly-integer? x
)
3679 (variable-possibly-noninteger-real? x
)
3680 (variable-possibly-nonreal-number? x
))
3682 (if (or (eq (variable-value x
) x
) (not (variable?
(variable-value x
))))
3684 (when (variable-possibly-boolean? x
)
3685 (local (setf (variable-possibly-boolean? x
) nil
))
3687 (when (variable-possibly-nonboolean-nonnumber? x
)
3688 (local (setf (variable-possibly-nonboolean-nonnumber? x
) nil
))
3691 (if (and (not (eq (variable-enumerated-domain x
) t
))
3692 (not (every #'numberp
(variable-enumerated-domain x
))))
3693 ;; note: Could do less consing if had LOCAL DELETE-IF.
3694 ;; This would also allow checking list only once.
3695 (set-enumerated-domain!
3696 x
(remove-if-not #'numberp
(variable-enumerated-domain x
))))
3697 (run-noticers x
)))))
3699 (defun restrict-nonnumber! (x)
3700 ;; note: X must be a variable.
3701 (unless (or (variable-possibly-boolean? x
)
3702 (variable-possibly-nonboolean-nonnumber? x
))
3704 (if (or (eq (variable-value x
) x
) (not (variable?
(variable-value x
))))
3706 (when (variable-possibly-integer? x
)
3707 (local (setf (variable-possibly-integer? x
) nil
))
3709 (when (variable-possibly-noninteger-real? x
)
3710 (local (setf (variable-possibly-noninteger-real? x
) nil
))
3712 (when (variable-possibly-nonreal-number? x
)
3713 (local (setf (variable-possibly-nonreal-number? x
) nil
))
3716 (if (and (not (eq (variable-enumerated-domain x
) t
))
3717 (some #'numberp
(variable-enumerated-domain x
)))
3718 ;; note: Could do less consing if had LOCAL DELETE-IF.
3719 ;; This would also allow checking list only once.
3720 (set-enumerated-domain!
3721 x
(remove-if #'numberp
(variable-enumerated-domain x
))))
3722 (run-noticers x
)))))
3724 (defun restrict-boolean! (x)
3725 ;; note: X must be a variable.
3726 (unless (variable-possibly-boolean? x
) (fail))
3727 (if (or (eq (variable-value x
) x
) (not (variable?
(variable-value x
))))
3729 (when (variable-possibly-integer? x
)
3730 (local (setf (variable-possibly-integer? x
) nil
))
3732 (when (variable-possibly-noninteger-real? x
)
3733 (local (setf (variable-possibly-noninteger-real? x
) nil
))
3735 (when (variable-possibly-nonreal-number? x
)
3736 (local (setf (variable-possibly-nonreal-number? x
) nil
))
3738 (when (variable-possibly-nonboolean-nonnumber? x
)
3739 (local (setf (variable-possibly-nonboolean-nonnumber? x
) nil
))
3743 ((eq (variable-enumerated-domain x
) t
)
3746 ((member t
(variable-enumerated-antidomain x
) :test
#'eq
)
3747 (cond ((member nil
(variable-enumerated-antidomain x
) :test
#'eq
)
3749 (t (setf (variable-enumerated-domain x
) '(nil))
3750 (setf (variable-enumerated-antidomain x
) '())
3751 (setf (variable-value x
) nil
))))
3752 ((member nil
(variable-enumerated-antidomain x
) :test
#'eq
)
3753 (setf (variable-enumerated-domain x
) '(t))
3754 (setf (variable-enumerated-antidomain x
) '())
3755 (setf (variable-value x
) t
))
3756 (t (setf (variable-enumerated-domain x
) '(t nil
))
3757 (unless (null (variable-enumerated-antidomain x
))
3758 (setf (variable-enumerated-antidomain x
) '()))))))
3759 ((not (every #'booleanp
(variable-enumerated-domain x
)))
3760 ;; note: Could do less consing if had LOCAL DELETE-IF.
3761 ;; This would also allow checking list only once.
3762 (set-enumerated-domain!
3763 x
(remove-if-not #'booleanp
(variable-enumerated-domain x
)))))
3764 (run-noticers x
)))))
3766 (defun restrict-nonboolean! (x)
3767 ;; note: X must be a variable.
3768 (unless (or (variable-possibly-integer? x
)
3769 (variable-possibly-noninteger-real? x
)
3770 (variable-possibly-nonreal-number? x
)
3771 (variable-possibly-nonboolean-nonnumber? x
))
3773 (when (and (or (eq (variable-value x
) x
) (not (variable?
(variable-value x
))))
3774 (variable-possibly-boolean? x
))
3775 (local (setf (variable-possibly-boolean? x
) nil
))
3776 (cond ((eq (variable-enumerated-domain x
) t
)
3777 (local (setf (variable-enumerated-antidomain x
)
3779 (adjoin nil
(variable-enumerated-antidomain x
)
3782 ((some #'booleanp
(variable-enumerated-domain x
))
3783 ;; note: Could do less consing if had LOCAL DELETE-IF.
3784 ;; This would also allow checking list only once.
3785 (set-enumerated-domain!
3786 x
(remove-if #'booleanp
(variable-enumerated-domain x
)))))
3789 (defun restrict-lower-bound! (x lower-bound
)
3790 ;; note: X must be a variable.
3791 ;; note: LOWER-BOUND must be a real constant.
3792 (if (variable-integer? x
) (setf lower-bound
(ceiling lower-bound
)))
3793 (when (and (or (eq (variable-value x
) x
) (not (variable?
(variable-value x
))))
3794 (or (not (variable-lower-bound x
))
3795 (> lower-bound
(variable-lower-bound x
))))
3796 (if (and (variable-upper-bound x
) (< (variable-upper-bound x
) lower-bound
))
3798 (when (or (not (variable-lower-bound x
))
3799 (not (variable-upper-bound x
))
3800 (>= (/ (- lower-bound
(variable-lower-bound x
))
3801 (- (variable-upper-bound x
) (variable-lower-bound x
)))
3802 *minimum-shrink-ratio
*))
3803 (local (setf (variable-lower-bound x
) lower-bound
))
3804 (cond ((eq (variable-enumerated-domain x
) t
)
3805 (if (and lower-bound
3806 (variable-upper-bound x
)
3807 (variable-integer? x
)
3808 (or (null *maximum-discretization-range
*)
3809 (<= (- (variable-upper-bound x
) lower-bound
)
3810 *maximum-discretization-range
*)))
3811 (set-enumerated-domain!
3812 x
(all-values (an-integer-between lower-bound
3813 (variable-upper-bound x
))))))
3814 ((some #'(lambda (element) (< element lower-bound
))
3815 (variable-enumerated-domain x
))
3816 ;; note: Could do less consing if had LOCAL DELETE-IF.
3817 ;; This would also allow checking list only once.
3818 (set-enumerated-domain!
3819 x
(remove-if #'(lambda (element) (< element lower-bound
))
3820 (variable-enumerated-domain x
)))))
3823 (defun restrict-upper-bound! (x upper-bound
)
3824 ;; note: X must be a variable.
3825 ;; note: UPPER-BOUND must be a real constant.
3826 (when (variable-integer? x
)
3827 (setf upper-bound
(floor upper-bound
)))
3828 (when (and (or (eq (variable-value x
) x
) (not (variable?
(variable-value x
))))
3829 (or (not (variable-upper-bound x
))
3830 (< upper-bound
(variable-upper-bound x
))))
3831 (when (and (variable-lower-bound x
) (> (variable-lower-bound x
) upper-bound
))
3833 (when (or (not (variable-lower-bound x
))
3834 (not (variable-upper-bound x
))
3835 (>= (/ (- (variable-upper-bound x
) upper-bound
)
3836 (- (variable-upper-bound x
) (variable-lower-bound x
)))
3837 *minimum-shrink-ratio
*))
3838 (local (setf (variable-upper-bound x
) upper-bound
))
3839 (cond ((eq (variable-enumerated-domain x
) t
)
3840 (when (and (variable-lower-bound x
)
3842 (variable-integer? x
)
3843 (or (null *maximum-discretization-range
*)
3844 (<= (- upper-bound
(variable-lower-bound x
))
3845 *maximum-discretization-range
*)))
3846 (set-enumerated-domain!
3847 x
(all-values (an-integer-between (variable-lower-bound x
)
3849 ((some #'(lambda (element) (> element upper-bound
))
3850 (variable-enumerated-domain x
))
3851 ;; note: Could do less consing if had LOCAL DELETE-IF.
3852 ;; This would also allow checking list only once.
3853 (set-enumerated-domain!
3854 x
(remove-if #'(lambda (element) (> element upper-bound
))
3855 (variable-enumerated-domain x
)))))
3858 (defun restrict-bounds! (x lower-bound upper-bound
)
3859 ;; note: X must be a variable.
3860 ;; note: LOWER-BOUND and UPPER-BOUND must be real constants.
3861 (when (variable-integer? x
)
3862 (if lower-bound
(setf lower-bound
(ceiling lower-bound
)))
3863 (if upper-bound
(setf upper-bound
(floor upper-bound
))))
3864 (if (or (eq (variable-value x
) x
) (not (variable?
(variable-value x
))))
3866 (when (and lower-bound
3867 (or (not (variable-lower-bound x
))
3868 (> lower-bound
(variable-lower-bound x
))))
3869 (if (and (variable-upper-bound x
)
3870 (< (variable-upper-bound x
) lower-bound
))
3872 (when (or (not (variable-lower-bound x
))
3873 (not (variable-upper-bound x
))
3874 (>= (/ (- lower-bound
(variable-lower-bound x
))
3875 (- (variable-upper-bound x
) (variable-lower-bound x
)))
3876 *minimum-shrink-ratio
*))
3877 (local (setf (variable-lower-bound x
) lower-bound
))
3879 (when (and upper-bound
3880 (or (not (variable-upper-bound x
))
3881 (< upper-bound
(variable-upper-bound x
))))
3882 (if (and (variable-lower-bound x
)
3883 (> (variable-lower-bound x
) upper-bound
))
3885 (when (or (not (variable-lower-bound x
))
3886 (not (variable-upper-bound x
))
3887 (>= (/ (- (variable-upper-bound x
) upper-bound
)
3888 (- (variable-upper-bound x
) (variable-lower-bound x
)))
3889 *minimum-shrink-ratio
*))
3890 (local (setf (variable-upper-bound x
) upper-bound
))
3893 (cond ((eq (variable-enumerated-domain x
) t
)
3894 (if (and (variable-lower-bound x
)
3895 (variable-upper-bound x
)
3896 (variable-integer? x
)
3897 (or (null *maximum-discretization-range
*)
3898 (<= (- (variable-upper-bound x
)
3899 (variable-lower-bound x
))
3900 *maximum-discretization-range
*)))
3901 (set-enumerated-domain!
3902 x
(all-values (an-integer-between
3903 (variable-lower-bound x
)
3904 (variable-upper-bound x
))))))
3905 ((or (and lower-bound
3906 (some #'(lambda (element) (< element lower-bound
))
3907 (variable-enumerated-domain x
)))
3909 (some #'(lambda (element) (> element upper-bound
))
3910 (variable-enumerated-domain x
))))
3911 ;; note: Could do less consing if had LOCAL DELETE-IF.
3912 ;; This would also allow checking list only once.
3913 (set-enumerated-domain!
3914 x
(remove-if #'(lambda (element)
3915 (or (and lower-bound
(< element lower-bound
))
3916 (and upper-bound
(> element upper-bound
))))
3917 (variable-enumerated-domain x
)))))
3918 (run-noticers x
)))))
3921 ;; note: X and Y must be variables such that (EQ X (VALUE-OF X)) and
3922 ;; (EQ Y (VALUE-OF Y)).
3924 (y-lower-bound? nil
)
3925 (y-upper-bound? nil
)
3926 (x-lower-bound (variable-lower-bound x
))
3927 (x-upper-bound (variable-upper-bound x
))
3928 (y-lower-bound (variable-lower-bound y
))
3929 (y-upper-bound (variable-upper-bound y
)))
3930 (cond ((and (variable-integer? y
) (not (variable-integer? x
)))
3931 (if x-lower-bound
(setf x-lower-bound
(ceiling x-lower-bound
)))
3932 (if x-upper-bound
(setf x-upper-bound
(floor x-upper-bound
))))
3933 ((and (not (variable-integer? y
)) (variable-integer? x
))
3934 (when (and y-lower-bound
(not (integerp y-lower-bound
)))
3935 (setf y-lower-bound
(ceiling y-lower-bound
))
3936 (setf y-lower-bound? t
))
3937 (when (and y-upper-bound
(not (integerp y-upper-bound
)))
3938 (setf y-upper-bound
(floor y-upper-bound
))
3939 (setf y-upper-bound? t
))))
3940 (when (and (not (variable-possibly-integer? x
))
3941 (variable-possibly-integer? y
))
3942 (local (setf (variable-possibly-integer? y
) nil
))
3944 (when (and (not (variable-possibly-noninteger-real? x
))
3945 (variable-possibly-noninteger-real? y
))
3946 (local (setf (variable-possibly-noninteger-real? y
) nil
))
3948 (when (and (not (variable-possibly-nonreal-number? x
))
3949 (variable-possibly-nonreal-number? y
))
3950 (local (setf (variable-possibly-nonreal-number? y
) nil
))
3952 (when (and (not (variable-possibly-boolean? x
))
3953 (variable-possibly-boolean? y
))
3954 (local (setf (variable-possibly-boolean? y
) nil
))
3956 (when (and (not (variable-possibly-nonboolean-nonnumber? x
))
3957 (variable-possibly-nonboolean-nonnumber? y
))
3958 (local (setf (variable-possibly-nonboolean-nonnumber? y
) nil
))
3960 (unless (or (variable-possibly-integer? y
)
3961 (variable-possibly-noninteger-real? y
)
3962 (variable-possibly-nonreal-number? y
)
3963 (variable-possibly-boolean? y
)
3964 (variable-possibly-nonboolean-nonnumber? y
))
3966 (cond ((and x-lower-bound
3967 (or (not y-lower-bound
) (> x-lower-bound y-lower-bound
)))
3968 (local (setf (variable-lower-bound y
) x-lower-bound
))
3971 (local (setf (variable-lower-bound y
) y-lower-bound
))
3973 (cond ((and x-upper-bound
3974 (or (not y-upper-bound
) (< x-upper-bound y-upper-bound
)))
3975 (local (setf (variable-upper-bound y
) x-upper-bound
))
3978 (local (setf (variable-upper-bound y
) y-upper-bound
))
3980 (unless (or (null (variable-lower-bound y
))
3981 (null (variable-upper-bound y
))
3982 (< (variable-lower-bound y
) (variable-upper-bound y
)))
3985 (let ((lower-bound (variable-lower-bound y
))
3986 (upper-bound (variable-upper-bound y
)))
3987 (if (eq (variable-enumerated-domain y
) t
)
3988 (if (and lower-bound
3990 (variable-integer? y
)
3991 (or (null *maximum-discretization-range
*)
3992 (<= (- upper-bound lower-bound
)
3993 *maximum-discretization-range
*)))
3994 (set-enumerated-domain!
3995 y
(all-values (an-integer-between lower-bound upper-bound
))))
3998 (if (some #'(lambda (element)
3999 (or (< element lower-bound
)
4000 (> element upper-bound
)))
4001 (variable-enumerated-domain y
))
4002 ;; note: Could do less consing if had LOCAL DELETE-IF.
4003 ;; This would also allow checking list only once.
4004 (set-enumerated-domain!
4005 y
(remove-if #'(lambda (element)
4006 (or (< element lower-bound
)
4007 (> element upper-bound
)))
4008 (variable-enumerated-domain y
))))
4009 (if (some #'(lambda (element) (< element lower-bound
))
4010 (variable-enumerated-domain y
))
4011 ;; note: Could do less consing if had LOCAL DELETE-IF.
4012 ;; This would also allow checking list only once.
4013 (set-enumerated-domain!
4014 y
(remove-if #'(lambda (element)
4015 (< element lower-bound
))
4016 (variable-enumerated-domain y
)))))
4018 (if (some #'(lambda (element) (> element upper-bound
))
4019 (variable-enumerated-domain y
))
4020 ;; note: Could do less consing if had LOCAL DELETE-IF.
4021 ;; This would also allow checking list only once.
4022 (set-enumerated-domain!
4023 y
(remove-if #'(lambda (element)
4024 (> element upper-bound
))
4025 (variable-enumerated-domain y
)))))))))
4026 (local (let* ((enumerated-domain
4028 ((eq (variable-enumerated-domain x
) t
)
4029 (if (eq (variable-enumerated-domain y
) t
)
4031 (set-difference (variable-enumerated-domain y
)
4032 (variable-enumerated-antidomain x
)
4034 ((eq (variable-enumerated-domain y
) t
)
4035 (set-difference (variable-enumerated-domain x
)
4036 (variable-enumerated-antidomain y
)
4038 (t (intersection (variable-enumerated-domain x
)
4039 (variable-enumerated-domain y
)
4041 (enumerated-antidomain
4042 (if (eq enumerated-domain t
)
4043 (union (variable-enumerated-antidomain x
)
4044 (variable-enumerated-antidomain y
)
4047 (if (null enumerated-domain
) (fail))
4048 (if (and (not (eq enumerated-domain t
))
4049 (or (eq (variable-enumerated-domain y
) t
)
4050 (< (length enumerated-domain
)
4051 (length (variable-enumerated-domain y
)))))
4052 (setf (variable-enumerated-domain y
) enumerated-domain
))
4053 (if (if (eq enumerated-domain t
)
4054 (> (length enumerated-antidomain
)
4055 (length (variable-enumerated-antidomain y
)))
4056 (not (null (variable-enumerated-antidomain y
))))
4057 (setf (variable-enumerated-antidomain y
) enumerated-antidomain
)))
4058 (setf (variable-noticers y
)
4059 (append (variable-noticers y
) (variable-noticers x
)))
4060 (setf (variable-noticers x
) '())
4061 (setf (variable-value x
) y
))
4064 (defun restrict-value! (x value
)
4065 ;; note: X must be a variable such that (EQ X (VALUE-OF X)).
4066 ;; note: VALUE must not be a variable.
4067 (if (occurs-in? x value
) (fail))
4069 (integer (unless (variable-possibly-integer? x
) (fail)))
4070 (real (unless (variable-possibly-noninteger-real? x
) (fail)))
4071 (number (unless (variable-possibly-nonreal-number? x
) (fail)))
4072 (boolean (unless (variable-possibly-boolean? x
) (fail)))
4073 (otherwise (unless (variable-possibly-nonboolean-nonnumber? x
) (fail))))
4074 ;; needs work: This is sound only if VALUE does not contain any variables.
4075 (if (eq (variable-enumerated-domain x
) t
)
4076 (if (member value
(variable-enumerated-antidomain x
) :test
#'equal
)
4078 (unless (member value
(variable-enumerated-domain x
) :test
#'equal
)
4080 (if (and (realp value
)
4081 (or (and (variable-lower-bound x
)
4082 (< value
(variable-lower-bound x
)))
4083 (and (variable-upper-bound x
)
4084 (> value
(variable-upper-bound x
)))))
4086 (local (setf (variable-value x
) value
)
4088 (integer (if (variable-possibly-noninteger-real? x
)
4089 (setf (variable-possibly-noninteger-real? x
) nil
))
4090 (if (variable-possibly-nonreal-number? x
)
4091 (setf (variable-possibly-nonreal-number? x
) nil
))
4092 (if (variable-possibly-boolean? x
)
4093 (setf (variable-possibly-boolean? x
) nil
))
4094 (if (variable-possibly-nonboolean-nonnumber? x
)
4095 (setf (variable-possibly-nonboolean-nonnumber? x
) nil
))
4096 (if (or (null (variable-lower-bound x
))
4097 (not (integerp (variable-lower-bound x
)))
4098 (> value
(variable-lower-bound x
)))
4099 (setf (variable-lower-bound x
) value
))
4100 (if (or (null (variable-upper-bound x
))
4101 (not (integerp (variable-upper-bound x
)))
4102 (< value
(variable-upper-bound x
)))
4103 (setf (variable-upper-bound x
) value
)))
4104 (real (if (variable-possibly-integer? x
)
4105 (setf (variable-possibly-integer? x
) nil
))
4106 (if (variable-possibly-nonreal-number? x
)
4107 (setf (variable-possibly-nonreal-number? x
) nil
))
4108 (if (variable-possibly-boolean? x
)
4109 (setf (variable-possibly-boolean? x
) nil
))
4110 (if (variable-possibly-nonboolean-nonnumber? x
)
4111 (setf (variable-possibly-nonboolean-nonnumber? x
) nil
))
4112 (if (or (null (variable-lower-bound x
))
4113 (> value
(variable-lower-bound x
)))
4114 (setf (variable-lower-bound x
) value
))
4115 (if (or (null (variable-upper-bound x
))
4116 (< value
(variable-upper-bound x
)))
4117 (setf (variable-upper-bound x
) value
)))
4118 (number (if (variable-possibly-integer? x
)
4119 (setf (variable-possibly-integer? x
) nil
))
4120 (if (variable-possibly-noninteger-real? x
)
4121 (setf (variable-possibly-noninteger-real? x
) nil
))
4122 (if (variable-possibly-boolean? x
)
4123 (setf (variable-possibly-boolean? x
) nil
))
4124 (if (variable-possibly-nonboolean-nonnumber? x
)
4125 (setf (variable-possibly-nonboolean-nonnumber? x
) nil
)))
4126 (boolean (if (variable-possibly-integer? x
)
4127 (setf (variable-possibly-integer? x
) nil
))
4128 (if (variable-possibly-noninteger-real? x
)
4129 (setf (variable-possibly-noninteger-real? x
) nil
))
4130 (if (variable-possibly-nonreal-number? x
)
4131 (setf (variable-possibly-nonreal-number? x
) nil
))
4132 (if (variable-possibly-nonboolean-nonnumber? x
)
4133 (setf (variable-possibly-nonboolean-nonnumber? x
) nil
)))
4134 (otherwise (if (variable-possibly-integer? x
)
4135 (setf (variable-possibly-integer? x
) nil
))
4136 (if (variable-possibly-noninteger-real? x
)
4137 (setf (variable-possibly-noninteger-real? x
) nil
))
4138 (if (variable-possibly-nonreal-number? x
)
4139 (setf (variable-possibly-nonreal-number? x
) nil
))
4140 (if (variable-possibly-boolean? x
)
4141 (setf (variable-possibly-boolean? x
) nil
))))
4142 (cond ((eq (variable-enumerated-domain x
) t
)
4143 ;; needs work: This is sound only if VALUE does not contain any
4145 (setf (variable-enumerated-domain x
) (list value
))
4146 (setf (variable-enumerated-antidomain x
) '()))
4147 ((not (null (rest (variable-enumerated-domain x
))))
4148 ;; needs work: This is sound only if VALUE does not contain any
4150 (setf (variable-enumerated-domain x
) (list value
)))))
4153 (defun restrict-true! (x)
4154 ;; note: X must be a Boolean variable.
4155 (if (eq (variable-value x
) nil
) (fail))
4156 (when (eq (variable-value x
) x
)
4157 (local (setf (variable-value x
) t
)
4158 (setf (variable-enumerated-domain x
) '(t)))
4161 (defun restrict-false! (x)
4162 ;; note: X must be a Boolean variable.
4163 (if (eq (variable-value x
) t
) (fail))
4164 (when (eq (variable-value x
) x
)
4165 (local (setf (variable-value x
) nil
)
4166 (setf (variable-enumerated-domain x
) '(nil)))
4169 (defun set-enumerated-domain! (x enumerated-domain
)
4170 ;; note: X must be a variable such that (EQ X (VALUE-OF X)).
4171 ;; note: All callers must insure that the new ENUMERATED-DOMAIN is a subset
4173 (if (null enumerated-domain
) (fail))
4176 ((eq (variable-enumerated-domain x
) t
)
4177 (setf (variable-enumerated-domain x
) enumerated-domain
)
4178 (unless (null (variable-enumerated-antidomain x
))
4179 (setf (variable-enumerated-antidomain x
) '()))
4180 (if (and (variable-possibly-boolean? x
)
4181 (not (some #'booleanp enumerated-domain
)))
4182 (setf (variable-possibly-boolean? x
) nil
))
4183 (if (and (variable-possibly-nonboolean-nonnumber? x
)
4184 (not (some #'(lambda (x)
4185 (and (not (booleanp x
)) (not (numberp x
))))
4186 enumerated-domain
)))
4187 (setf (variable-possibly-nonboolean-nonnumber? x
) nil
))
4188 (if (and (variable-possibly-nonreal-number? x
)
4189 (not (some #'(lambda (x) (and (not (realp x
)) (numberp x
)))
4190 enumerated-domain
)))
4191 (setf (variable-possibly-nonreal-number? x
) nil
))
4192 (if (and (variable-possibly-noninteger-real? x
)
4193 (not (some #'(lambda (x) (and (not (integerp x
)) (realp x
)))
4194 enumerated-domain
)))
4195 (setf (variable-possibly-noninteger-real? x
) nil
))
4196 (if (and (variable-possibly-integer? x
)
4197 (not (some #'integerp enumerated-domain
)))
4198 (setf (variable-possibly-integer? x
) nil
))
4199 (if (variable-real? x
)
4200 (let ((lower-bound (reduce #'min enumerated-domain
))
4201 (upper-bound (reduce #'max enumerated-domain
)))
4202 (if (or (null (variable-lower-bound x
))
4203 (> lower-bound
(variable-lower-bound x
)))
4204 (setf (variable-lower-bound x
) lower-bound
))
4205 (if (or (null (variable-upper-bound x
))
4206 (< upper-bound
(variable-upper-bound x
)))
4207 (setf (variable-upper-bound x
) upper-bound
))))
4208 (if (null (rest enumerated-domain
))
4209 (setf (variable-value x
) (first enumerated-domain
)))
4211 ((< (length enumerated-domain
) (length (variable-enumerated-domain x
)))
4212 (setf (variable-enumerated-domain x
) enumerated-domain
)
4213 (if (and (variable-possibly-boolean? x
)
4214 (not (some #'booleanp enumerated-domain
)))
4215 (setf (variable-possibly-boolean? x
) nil
))
4216 (if (and (variable-possibly-nonboolean-nonnumber? x
)
4217 (not (some #'(lambda (x)
4218 (and (not (booleanp x
)) (not (numberp x
))))
4219 enumerated-domain
)))
4220 (setf (variable-possibly-nonboolean-nonnumber? x
) nil
))
4221 (if (and (variable-possibly-nonreal-number? x
)
4222 (not (some #'(lambda (x) (and (not (realp x
)) (numberp x
)))
4223 enumerated-domain
)))
4224 (setf (variable-possibly-nonreal-number? x
) nil
))
4225 (if (and (variable-possibly-noninteger-real? x
)
4226 (not (some #'(lambda (x) (and (not (integerp x
)) (realp x
)))
4227 enumerated-domain
)))
4228 (setf (variable-possibly-noninteger-real? x
) nil
))
4229 (if (and (variable-possibly-integer? x
)
4230 (not (some #'integerp enumerated-domain
)))
4231 (setf (variable-possibly-integer? x
) nil
))
4232 (if (variable-real? x
)
4233 (let ((lower-bound (reduce #'min enumerated-domain
))
4234 (upper-bound (reduce #'max enumerated-domain
)))
4235 (if (or (null (variable-lower-bound x
))
4236 (> lower-bound
(variable-lower-bound x
)))
4237 (setf (variable-lower-bound x
) lower-bound
))
4238 (if (or (null (variable-upper-bound x
))
4239 (< upper-bound
(variable-upper-bound x
)))
4240 (setf (variable-upper-bound x
) upper-bound
))))
4241 (if (null (rest enumerated-domain
))
4242 (setf (variable-value x
) (first enumerated-domain
)))
4246 (defun restrict-enumerated-domain! (x enumerated-domain
)
4247 ;; note: X must be a variable such that (EQ X (VALUE-OF X)).
4248 ;; note: ENUMERATED-DOMAIN must not be a variable.
4249 (unless (typep enumerated-domain
'sequence
) (fail))
4250 (when (every #'ground? enumerated-domain
)
4251 (setf enumerated-domain
4252 (remove-duplicates (map 'list
#'eliminate-variables enumerated-domain
)
4254 (unless (variable-possibly-boolean? x
)
4255 (setf enumerated-domain
(remove-if #'booleanp enumerated-domain
)))
4256 (unless (variable-possibly-nonboolean-nonnumber? x
)
4257 (setf enumerated-domain
4258 (remove-if #'(lambda (x) (and (not (booleanp x
)) (not (numberp x
))))
4259 enumerated-domain
)))
4260 (unless (variable-possibly-nonreal-number? x
)
4261 (setf enumerated-domain
4262 (remove-if #'(lambda (x) (and (not (realp x
)) (numberp x
)))
4263 enumerated-domain
)))
4264 (unless (variable-possibly-noninteger-real? x
)
4265 (setf enumerated-domain
4266 (remove-if #'(lambda (x) (and (not (integerp x
)) (realp x
)))
4267 enumerated-domain
)))
4268 (unless (variable-possibly-integer? x
)
4269 (setf enumerated-domain
(remove-if #'integerp enumerated-domain
)))
4270 (if (variable-upper-bound x
)
4271 (let ((upper-bound (variable-upper-bound x
)))
4272 (setf enumerated-domain
4273 (remove-if #'(lambda (element) (> element upper-bound
))
4274 enumerated-domain
))))
4275 (if (variable-lower-bound x
)
4276 (let ((lower-bound (variable-lower-bound x
)))
4277 (setf enumerated-domain
4278 (remove-if #'(lambda (element) (< element lower-bound
))
4279 enumerated-domain
))))
4280 (setf enumerated-domain
4281 (if (eq (variable-enumerated-domain x
) t
)
4282 (set-difference enumerated-domain
4283 (variable-enumerated-antidomain x
)
4285 (intersection (variable-enumerated-domain x
) enumerated-domain
4287 (if (set-enumerated-domain! x enumerated-domain
) (run-noticers x
))))
4289 (defun restrict-enumerated-antidomain! (x enumerated-antidomain
)
4290 ;; note: X must be a variable such that (EQ X (VALUE-OF X)).
4291 ;; note: ENUMERATED-ANTIDOMAIN must not be a variable.
4292 (unless (typep enumerated-antidomain
'sequence
) (fail))
4293 (when (every #'ground? enumerated-antidomain
)
4294 (setf enumerated-antidomain
4296 (map 'list
#'eliminate-variables enumerated-antidomain
)
4299 ((eq (variable-enumerated-domain x
) t
)
4300 (setf enumerated-antidomain
4301 (union (variable-enumerated-antidomain x
) enumerated-antidomain
4303 (when (> (length enumerated-antidomain
)
4304 (length (variable-enumerated-antidomain x
)))
4305 (local (setf (variable-enumerated-antidomain x
) enumerated-antidomain
))
4307 ((set-enumerated-domain!
4308 x
(set-difference (variable-enumerated-domain x
) enumerated-antidomain
4310 (run-noticers x
)))))
4314 (defun +-rule-up
(z x y
)
4315 (if (and (variable-integer? x
) (variable-integer? y
)) (restrict-integer! z
))
4316 ;; note: We can't assert that Z in not an integer when either X or Y are not
4317 ;; integers since they may be Gaussian integers. But we can if either
4318 ;; X or Y is real. If the Screamer type system could distinguish
4319 ;; Gaussian integers from other complex numbers we could whenever X or
4320 ;; Y was not a Gaussian integer.
4321 (if (and (or (variable-noninteger? x
) (variable-noninteger? y
))
4322 (or (variable-real? x
) (variable-real? y
)))
4323 (restrict-noninteger! z
))
4324 (if (and (variable-real? x
) (variable-real? y
)) (restrict-real! z
))
4326 (if (and (or (variable-nonreal? x
) (variable-nonreal? y
))
4327 (or (variable-real? x
) (variable-real? y
)))
4328 (restrict-nonreal! z
))
4329 (if (and (variable-real? x
) (variable-real? y
) (variable-real? z
))
4332 (infinity-+ (variable-lower-bound x
) (variable-lower-bound y
))
4333 (infinity-+ (variable-upper-bound x
) (variable-upper-bound y
))))
4334 (let ((x (value-of x
))
4337 (if (and (not (variable? x
))
4343 (defun +-rule-down
(z x y
)
4344 ;; note: We can't assert that X and Y are integers when Z is an integer since
4345 ;; Z may be an integer when X and Y are Gaussian integers. But we can
4346 ;; make such an assertion if either X or Y is real. If the Screamer
4347 ;; type system could distinguish Gaussian integers from other complex
4348 ;; numbers we could make such an assertion whenever either X or Y was
4349 ;; not a Gaussian integer.
4350 (if (and (variable-integer? z
) (or (variable-real? x
) (variable-real? y
)))
4351 (restrict-integer! x
))
4353 (if (and (variable-real? z
) (or (variable-real? x
) (variable-real? y
)))
4355 (if (and (variable-real? x
) (variable-real? y
) (variable-real? z
))
4358 (infinity-- (variable-lower-bound z
) (variable-upper-bound y
))
4359 (infinity-- (variable-upper-bound z
) (variable-lower-bound y
))))
4360 (let ((x (value-of x
))
4363 (if (and (not (variable? x
))
4369 (defun /-rule
(z x y
)
4370 (when (and (variable-lower-bound x
) (plusp (variable-lower-bound x
)))
4371 (cond ((and (variable-upper-bound x
) (not (zerop (variable-upper-bound x
))))
4372 (if (variable-lower-bound z
)
4374 ((minusp (variable-lower-bound z
))
4375 (restrict-lower-bound!
4376 y
(/ (variable-lower-bound z
) (variable-lower-bound x
))))
4377 (t (restrict-lower-bound! y
0)
4378 (restrict-lower-bound!
4379 y
(/ (variable-lower-bound z
) (variable-upper-bound x
))))))
4380 (if (variable-upper-bound z
)
4382 ((plusp (variable-upper-bound z
))
4383 (restrict-upper-bound!
4384 y
(/ (variable-upper-bound z
) (variable-lower-bound x
))))
4385 (t (restrict-upper-bound! y
0)
4386 (restrict-upper-bound!
4387 y
(/ (variable-upper-bound z
) (variable-upper-bound x
)))))))
4388 (t (if (variable-lower-bound z
)
4390 ((minusp (variable-lower-bound z
))
4391 (restrict-lower-bound!
4392 y
(/ (variable-lower-bound z
) (variable-lower-bound x
))))
4393 (t (restrict-lower-bound! y
0))))
4394 (if (variable-upper-bound z
)
4396 ((plusp (variable-upper-bound z
))
4397 (restrict-upper-bound!
4398 y
(/ (variable-upper-bound z
) (variable-lower-bound x
))))
4399 (t (restrict-upper-bound! y
0)))))))
4400 (when (and (variable-upper-bound x
) (minusp (variable-upper-bound x
)))
4401 (cond ((and (variable-lower-bound x
) (not (zerop (variable-lower-bound x
))))
4402 (if (variable-upper-bound z
)
4404 ((plusp (variable-upper-bound z
))
4405 (restrict-lower-bound!
4406 y
(/ (variable-upper-bound z
) (variable-upper-bound x
))))
4407 (t (restrict-lower-bound! y
0)
4408 (restrict-lower-bound!
4409 y
(/ (variable-upper-bound z
) (variable-lower-bound x
))))))
4410 (if (variable-lower-bound z
)
4412 ((minusp (variable-lower-bound z
))
4413 (restrict-upper-bound!
4414 y
(/ (variable-lower-bound z
) (variable-upper-bound x
))))
4415 (t (restrict-upper-bound! y
0)
4416 (restrict-upper-bound!
4417 y
(/ (variable-lower-bound z
) (variable-lower-bound x
)))))))
4418 (t (if (variable-upper-bound z
)
4420 ((plusp (variable-upper-bound z
))
4421 (restrict-lower-bound!
4422 y
(/ (variable-upper-bound z
) (variable-upper-bound x
))))
4423 (t (restrict-lower-bound! y
0))))
4424 (if (variable-lower-bound z
)
4426 ((minusp (variable-lower-bound z
))
4427 (restrict-upper-bound!
4428 y
(/ (variable-lower-bound z
) (variable-upper-bound x
))))
4429 (t (restrict-upper-bound! y
0))))))))
4431 (defun *-rule-up
(z x y
)
4432 (if (and (variable-integer? x
) (variable-integer? y
)) (restrict-integer! z
))
4433 ;; note: We can't assert that Z in not an integer when either X or Y are not
4434 ;; integers since they may be Gaussian integers. But we can if either
4435 ;; X or Y is real. If the Screamer type system could distinguish
4436 ;; Gaussian integers from other complex numbers we could whenever X or
4437 ;; Y was not a Gaussian integer.
4438 (if (and (or (variable-noninteger? x
) (variable-noninteger? y
))
4439 (or (variable-real? x
) (variable-real? y
)))
4440 (restrict-noninteger! z
))
4441 (if (and (variable-real? x
) (variable-real? y
)) (restrict-real! z
))
4443 (if (and (or (variable-nonreal? x
) (variable-nonreal? y
))
4444 (or (variable-real? x
) (variable-real? y
)))
4445 (restrict-nonreal! z
))
4446 (if (and (variable-real? x
) (variable-real? y
) (variable-real? z
))
4447 ;; note: Can sometimes do better than the following even when ranges are
4452 (infinity-* (variable-lower-bound x
) (variable-lower-bound y
))
4454 (infinity-* (variable-lower-bound x
) (variable-upper-bound y
))
4456 (infinity-* (variable-upper-bound x
) (variable-lower-bound y
))
4457 (infinity-* (variable-upper-bound x
) (variable-upper-bound y
)))))
4459 (infinity-* (variable-lower-bound x
) (variable-lower-bound y
))
4461 (infinity-* (variable-lower-bound x
) (variable-upper-bound y
))
4463 (infinity-* (variable-upper-bound x
) (variable-lower-bound y
))
4464 (infinity-* (variable-upper-bound x
) (variable-upper-bound y
)))))))
4465 (let ((x (value-of x
))
4468 (if (and (not (variable? x
))
4474 (defun *-rule-down
(z x y
)
4475 ;; note: We can't assert that X and Y are integers when Z is an integer since
4476 ;; Z may be an integer when X and Y are Gaussian integers. But we can
4477 ;; make such an assertion if either X or Y is real. If the Screamer
4478 ;; type system could distinguish Gaussian integers from other complex
4479 ;; numbers we could make such an assertion whenever either X or Y was
4480 ;; not a Gaussian integer.
4481 (if (and (variable-integer? z
) (or (variable-real? x
) (variable-real? y
)))
4482 (restrict-integer! x
))
4484 (if (and (variable-real? z
) (or (variable-real? x
) (variable-real? y
)))
4486 (if (and (variable-real? x
) (variable-real? y
) (variable-real? z
))
4488 (let ((x (value-of x
))
4491 (if (and (not (variable? x
))
4497 (defun min-rule-up (z x y
)
4498 (if (and (variable-integer? x
) (variable-integer? y
)) (restrict-integer! z
))
4501 (infinity-min (variable-lower-bound x
) (variable-lower-bound y
))
4502 (if (variable-upper-bound x
)
4503 (if (variable-upper-bound y
)
4504 (min (variable-upper-bound x
) (variable-upper-bound y
))
4505 (variable-upper-bound x
))
4506 (variable-upper-bound y
)))
4507 (let ((x (value-of x
))
4510 (if (and (not (variable? z
))
4516 (defun min-rule-down (z x y
)
4517 ;; note: The analog of the following for upper bounds, namely restricting
4518 ;; the upper bound of either X or Y to (VARIABLE-UPPER-BOUND Z) is
4519 ;; nondeterministic.
4520 (if (variable-lower-bound z
)
4521 (restrict-lower-bound! x
(variable-lower-bound z
)))
4522 (let ((x (value-of x
))
4525 (if (and (not (variable? z
))
4531 (defun max-rule-up (z x y
)
4532 (if (and (variable-integer? x
) (variable-integer? y
)) (restrict-integer! z
))
4535 (if (variable-lower-bound x
)
4536 (if (variable-lower-bound y
)
4537 (max (variable-lower-bound x
) (variable-lower-bound y
))
4538 (variable-lower-bound x
))
4539 (variable-lower-bound y
))
4540 (infinity-max (variable-upper-bound x
) (variable-upper-bound y
)))
4541 (let ((x (value-of x
))
4544 (if (and (not (variable? z
))
4550 (defun max-rule-down (z x y
)
4551 ;; note: The analog of the following for lower bounds, namely restricting
4552 ;; the lower bound of either X or Y to (VARIABLE-LOWER-BOUND Z) is
4553 ;; nondeterministic.
4554 (if (variable-upper-bound z
)
4555 (restrict-upper-bound! x
(variable-upper-bound z
)))
4556 (let ((x (value-of x
))
4559 (if (and (not (variable? z
))
4567 ;; note: I forget why +-RULE *-RULE MIN-RULE and MAX-RULE must perform the
4568 ;; check in the second COND clause irrespective of whether the first
4569 ;; clause is executed.
4570 ((and (variable-real? x
) (variable-real? y
))
4571 (restrict-bounds! x
(variable-lower-bound y
) (variable-upper-bound y
))
4572 (restrict-bounds! y
(variable-lower-bound x
) (variable-upper-bound x
)))
4573 ((and (not (variable? x
)) (not (variable? y
)) (/= x y
)) (fail))))
4575 (defun <=-rule
(x y
)
4576 (if (variable-lower-bound x
)
4577 (restrict-lower-bound! y
(variable-lower-bound x
)))
4578 (if (variable-upper-bound y
)
4579 (restrict-upper-bound! x
(variable-upper-bound y
))))
4582 (if (variable-lower-bound x
)
4583 (restrict-lower-bound! y
(if (variable-integer? y
)
4584 (1+ (floor (variable-lower-bound x
)))
4585 (variable-lower-bound x
))))
4586 (if (variable-upper-bound y
)
4587 (restrict-upper-bound! x
(if (variable-integer? x
)
4588 (1- (ceiling (variable-upper-bound y
)))
4589 (variable-upper-bound y
))))
4590 (let ((x (value-of x
))
4592 (if (and (not (variable? x
)) (not (variable? y
)) (>= x y
)) (fail))))
4594 (defun /=-rule
(x y
)
4595 ;; note: Got rid of the nondeterministic version of /=-RULE.
4596 (let ((x (value-of x
))
4598 (if (and (not (variable? x
)) (not (variable? y
)) (= x y
)) (fail))))
4600 ;;; Lifted Arithmetic Functions (Two argument optimized)
4603 (assert!-numberpv x
)
4604 (assert!-numberpv y
)
4605 ;; needs work: The first two optimizations below violate CommonLisp type
4606 ;; propagation conventions.
4607 (cond ((and (bound? x
) (zerop (value-of x
))) (value-of y
))
4608 ((and (bound? y
) (zerop (value-of y
))) (value-of x
))
4609 ((and (bound? x
) (bound? y
)) (+ (value-of x
) (value-of y
)))
4610 (t (let ((x (variablize x
))
4614 #'(lambda () (+-rule-up z x y
) (+-rule-down z y x
)) x
)
4616 #'(lambda () (+-rule-up z x y
) (+-rule-down z x y
)) y
)
4618 #'(lambda () (+-rule-down z x y
) (+-rule-down z y x
)) z
)
4622 (assert!-numberpv x
)
4623 (assert!-numberpv y
)
4624 ;; needs work: The first optimization below violates CommonLisp type
4625 ;; propagation conventions.
4626 (cond ((and (bound? y
) (zerop (value-of y
))) (value-of x
))
4627 ((and (bound? x
) (bound? y
)) (- (value-of x
) (value-of y
)))
4628 (t (let ((x (variablize x
))
4632 #'(lambda () (+-rule-down x y z
) (+-rule-down x z y
)) x
)
4634 #'(lambda () (+-rule-up x y z
) (+-rule-down x z y
)) y
)
4636 #'(lambda () (+-rule-up x y z
) (+-rule-down x y z
)) z
)
4640 (assert!-numberpv x
)
4641 (assert!-numberpv y
)
4642 ;; needs work: The first four optimizations below violate CommonLisp type
4643 ;; propagation conventions.
4644 (cond ((and (bound? x
) (zerop (value-of x
))) 0)
4645 ((and (bound? y
) (zerop (value-of y
))) 0)
4646 ((and (bound? x
) (= (value-of x
) 1)) (value-of y
))
4647 ((and (bound? y
) (= (value-of y
) 1)) (value-of x
))
4648 ((and (bound? x
) (bound? y
)) (* (value-of x
) (value-of y
)))
4649 (t (let ((x (variablize x
))
4653 #'(lambda () (*-rule-up z x y
) (*-rule-down z y x
)) x
)
4655 #'(lambda () (*-rule-up z x y
) (*-rule-down z x y
)) y
)
4657 #'(lambda () (*-rule-down z x y
) (*-rule-down z y x
)) z
)
4661 (assert!-numberpv x
)
4662 (assert!-numberpv y
)
4663 ;; needs work: The first three optimizations below violate CommonLisp type
4664 ;; propagation conventions.
4665 (cond ((and (bound? x
) (zerop (value-of x
))) 0)
4666 ((and (bound? y
) (zerop (value-of y
))) (fail))
4667 ((and (bound? y
) (= (value-of y
) 1)) (value-of x
))
4668 ((and (bound? x
) (bound? y
)) (/ (value-of x
) (value-of y
)))
4669 (t (let ((x (variablize x
))
4673 #'(lambda () (*-rule-down x y z
) (*-rule-down x z y
)) x
)
4675 #'(lambda () (*-rule-up x y z
) (*-rule-down x z y
)) y
)
4677 #'(lambda () (*-rule-up x y z
) (*-rule-down x y z
)) z
)
4683 (cond ((known?-
<=v2-internal x y
) (value-of x
))
4684 ((known?-
<=v2-internal y x
) (value-of y
))
4685 (t (let ((x (variablize x
))
4689 #'(lambda () (min-rule-up z x y
) (min-rule-down z y x
)) x
)
4691 #'(lambda () (min-rule-up z x y
) (min-rule-down z x y
)) y
)
4693 #'(lambda () (min-rule-down z x y
) (min-rule-down z y x
)) z
)
4699 (cond ((known?-
<=v2-internal y x
) (value-of x
))
4700 ((known?-
<=v2-internal x y
) (value-of y
))
4701 (t (let ((x (variablize x
))
4705 #'(lambda () (max-rule-up z x y
) (max-rule-down z y x
)) x
)
4707 #'(lambda () (max-rule-up z x y
) (max-rule-down z x y
)) y
)
4709 #'(lambda () (max-rule-down z x y
) (max-rule-down z y x
)) z
)
4712 ;;; Lifted Type Functions (KNOWN? optimized)
4714 (defun known?-integerpv
(x)
4715 (let ((x (value-of x
)))
4718 (variable (variable-integer? x
))
4721 (defun known?-notv-integerpv
(x)
4722 (let ((x (value-of x
)))
4725 (variable (variable-noninteger? x
))
4728 (defun known?-realpv
(x)
4729 (let ((x (value-of x
)))
4732 (variable (variable-real? x
))
4735 (defun known?-notv-realpv
(x)
4736 (let ((x (value-of x
)))
4739 (variable (variable-nonreal? x
))
4742 (defun known?-numberpv
(x)
4743 (let ((x (value-of x
)))
4746 (variable (variable-number? x
))
4749 (defun known?-notv-numberpv
(x)
4750 (let ((x (value-of x
)))
4753 (variable (variable-nonnumber? x
))
4756 (defun known?-booleanpv
(x)
4757 (let ((x (value-of x
)))
4760 (variable (variable-boolean? x
))
4763 (defun known?-notv-booleanpv
(x)
4764 (let ((x (value-of x
)))
4767 (variable (variable-nonboolean? x
))
4770 ;;; Lifted Arithmetic Comparison Functions (Two argument KNOWN? optimized)
4772 (defun known?-
<=v2-variable
(x y
)
4773 (and (variable-upper-bound x
)
4774 (variable-lower-bound y
)
4775 (<= (variable-upper-bound x
) (variable-lower-bound y
))))
4777 (defun known?-
<v2-variable
(x y
)
4778 (and (variable-upper-bound x
)
4779 (variable-lower-bound y
)
4780 (< (variable-upper-bound x
) (variable-lower-bound y
))))
4782 (defun known?-
=v2-variable
(x y
)
4783 (or (and (variable-real? x
)
4785 (known?-
<=v2-variable x y
)
4786 (known?-
<=v2-variable y x
))
4787 (and (not (eq x
(variable-value x
)))
4788 (not (eq y
(variable-value y
)))
4789 (= (variable-value x
) (variable-value y
)))))
4791 (defun known?-
/=v2-variable
(x y
)
4792 (or (and (variable-real? x
)
4794 (or (known?-
<v2-variable x y
) (known?-
<v2-variable y x
)))
4795 (and (not (eq x
(variable-value x
)))
4796 (not (eq y
(variable-value y
)))
4797 (/= (variable-value x
) (variable-value y
)))))
4799 (defun known?-
=v2-internal
(x y
)
4800 (known?-
=v2-variable
(variablize x
) (variablize y
)))
4802 (defun known?-
<=v2-internal
(x y
)
4803 (known?-
<=v2-variable
(variablize x
) (variablize y
)))
4805 (defun known?-
<v2-internal
(x y
)
4806 (known?-
<v2-variable
(variablize x
) (variablize y
)))
4808 (defun known?-
/=v2-internal
(x y
)
4809 (known?-
/=v2-variable
(variablize x
) (variablize y
)))
4811 (defun known?-
=v2
(x y
)
4812 (assert!-numberpv x
)
4813 (assert!-numberpv y
)
4814 (known?-
=v2-internal x y
))
4816 (defun known?-
<=v2
(x y
)
4819 (known?-
<=v2-internal x y
))
4821 (defun known?-
<v2
(x y
)
4824 (known?-
<v2-internal x y
))
4826 (defun known?-
/=v2
(x y
)
4827 (assert!-numberpv x
)
4828 (assert!-numberpv y
)
4829 (known?-
/=v2-internal x y
))
4831 ;;; Lifted Type Functions (ASSERT! optimized)
4833 (defun assert!-integerpv
(x)
4834 (let ((x (value-of x
)))
4837 (variable (restrict-integer! x
))
4838 (otherwise (fail)))))
4840 (defun assert!-notv-integerpv
(x)
4841 (let ((x (value-of x
)))
4844 (variable (restrict-noninteger! x
))
4847 (defun assert!-realpv
(x)
4848 (let ((x (value-of x
)))
4851 (variable (restrict-real! x
))
4852 (otherwise (fail)))))
4854 (defun assert!-notv-realpv
(x)
4855 (let ((x (value-of x
)))
4858 (variable (restrict-nonreal! x
))
4861 (defun assert!-numberpv
(x)
4862 (let ((x (value-of x
)))
4865 (variable (restrict-number! x
))
4866 (otherwise (fail)))))
4868 (defun assert!-notv-numberpv
(x)
4869 (let ((x (value-of x
)))
4872 (variable (restrict-nonnumber! x
))
4875 (defun assert!-booleanpv
(x)
4876 (let ((x (value-of x
)))
4879 (variable (restrict-boolean! x
))
4880 (otherwise (fail)))))
4882 (defun assert!-notv-booleanpv
(x)
4883 (let ((x (value-of x
)))
4886 (variable (restrict-nonboolean! x
))
4889 ;;; Lifted Arithmetic Comparison Functions (Two argument ASSERT! optimized)
4891 (defun assert!-
=v2
(x y
)
4892 (assert!-numberpv x
)
4893 (assert!-numberpv y
)
4894 (let ((x (variablize x
))
4896 (attach-noticer! #'(lambda () (=-rule x y
)) x
)
4897 (attach-noticer! #'(lambda () (=-rule x y
)) y
)))
4899 (defun assert!-
<=v2
(x y
)
4902 (let ((x (variablize x
))
4904 (attach-noticer! #'(lambda () (<=-rule x y
)) x
)
4905 (attach-noticer! #'(lambda () (<=-rule x y
)) y
)))
4907 (defun assert!-
<v2
(x y
)
4910 (let ((x (variablize x
))
4912 (attach-noticer! #'(lambda () (<-rule x y
)) x
)
4913 (attach-noticer! #'(lambda () (<-rule x y
)) y
)))
4915 (defun assert!-
/=v2
(x y
)
4916 (assert!-numberpv x
)
4917 (assert!-numberpv y
)
4918 (let ((x (variablize x
))
4920 ;; note: Got rid of the nondeterministic version that called the
4921 ;; nondeterministic version of /=-RULE.
4922 (attach-noticer! #'(lambda () (/=-rule x y
)) x
)
4923 (attach-noticer! #'(lambda () (/=-rule x y
)) y
)))
4925 ;;; Lifted Type Functions
4927 (defun integerpv (x)
4928 (cond ((known?-integerpv x
) t
)
4929 ((known?-notv-integerpv x
) nil
)
4930 (t (let ((x (variablize x
))
4934 (cond ((variable-integer? x
) (restrict-true! z
))
4935 ((variable-noninteger? x
) (restrict-false! z
))))
4939 (cond ((variable-true? z
) (restrict-integer! x
))
4940 ((variable-false? z
) (restrict-noninteger! x
))))
4945 (cond ((known?-realpv x
) t
)
4946 ((known?-notv-realpv x
) nil
)
4947 (t (let ((x (variablize x
))
4951 (cond ((variable-real? x
) (restrict-true! z
))
4952 ((variable-nonreal? x
) (restrict-false! z
))))
4956 (cond ((variable-true? z
) (restrict-real! x
))
4957 ((variable-false? z
) (restrict-nonreal! x
))))
4962 (cond ((known?-numberpv x
) t
)
4963 ((known?-notv-numberpv x
) nil
)
4964 (t (let ((x (variablize x
))
4968 (cond ((variable-number? x
) (restrict-true! z
))
4969 ((variable-nonnumber? x
) (restrict-false! z
))))
4973 (cond ((variable-true? z
) (restrict-number! x
))
4974 ((variable-false? z
) (restrict-nonnumber! x
))))
4978 (defun booleanpv (x)
4979 (cond ((known?-booleanpv x
) t
)
4980 ((known?-notv-booleanpv x
) nil
)
4981 (t (let ((x (variablize x
))
4985 (cond ((variable-boolean? x
) (restrict-true! z
))
4986 ((variable-nonboolean? x
) (restrict-false! z
))))
4990 (cond ((variable-true? z
) (restrict-boolean! x
))
4991 ((variable-false? z
) (restrict-nonboolean! x
))))
4997 (defun known?-memberv-list-internal
(x y
)
4999 (or (known?-equalv x
(first y
))
5000 (known?-memberv-list-internal x
(rest y
)))))
5002 (defun known?-memberv-list
(x y
)
5004 (cons (or (known?-equalv x
(first y
)) (known?-memberv-list x
(rest y
))))
5006 (if (eq (variable-value y
) y
)
5007 (and (not (eq (variable-enumerated-domain y
) t
))
5009 #'(lambda (element) (known?-memberv-list-internal x element
))
5010 (variable-enumerated-domain y
)))
5011 (known?-memberv-list x
(variable-value y
))))
5014 (defun known?-memberv-internal
(x y
)
5016 (list (known?-memberv-list x y
))
5017 (vector (some #'(lambda (element) (known?-equalv x element
)) y
))
5019 (if (eq (variable-value y
) y
)
5020 (and (not (eq (variable-enumerated-domain y
) t
))
5024 (list (known?-memberv-list-internal x element
))
5025 (vector (some #'(lambda (e) (known?-equalv x e
)) element
))
5027 (variable-enumerated-domain y
)))
5028 (known?-memberv-internal x
(variable-value y
))))
5029 (otherwise (fail))))
5031 (defun known?-memberv
(x y
)
5032 (cond ((and (variable? x
) (not (eq (variable-value x
) x
)))
5033 (known?-memberv
(variable-value x
) y
))
5034 ((and (variable? x
) (not (eq (variable-enumerated-domain x
) t
)))
5035 ;; note: This first alternative is an optimization in case membership
5036 ;; can be determined simply through sharing relationships.
5037 (or (known?-memberv-internal x y
)
5038 (every #'(lambda (element) (known?-memberv-internal element y
))
5039 (variable-enumerated-domain x
))))
5040 (t (known?-memberv-internal x y
))))
5042 (defun known?-notv-memberv-list-internal
(x y
)
5044 (and (known?-notv-equalv x
(first y
))
5045 (known?-notv-memberv-list-internal x
(rest y
)))))
5047 (defun known?-notv-memberv-list
(x y
)
5049 (cons (and (known?-notv-equalv x
(first y
))
5050 (known?-notv-memberv-list x
(rest y
))))
5052 (if (eq (variable-value y
) y
)
5053 (and (not (eq (variable-enumerated-domain y
) t
))
5054 (every #'(lambda (element)
5055 (known?-notv-memberv-list-internal x element
))
5056 (variable-enumerated-domain y
)))
5057 (known?-notv-memberv-list x
(variable-value y
))))
5060 (defun known?-notv-memberv-internal
(x y
)
5062 (list (known?-notv-memberv-list x y
))
5063 (vector (every #'(lambda (element) (known?-notv-equalv x element
)) y
))
5065 (if (eq (variable-value y
) y
)
5066 (and (not (eq (variable-enumerated-domain y
) t
))
5070 (list (known?-notv-memberv-list-internal x element
))
5072 (every #'(lambda (e) (known?-notv-equalv x e
)) element
))
5074 (variable-enumerated-domain y
)))
5075 (known?-notv-memberv-internal x
(variable-value y
))))
5076 (otherwise (fail))))
5078 (defun known?-notv-memberv
(x y
)
5080 ((and (variable? x
) (not (eq (variable-value x
) x
)))
5081 (known?-notv-memberv
(variable-value x
) y
))
5082 ((and (variable? x
) (not (eq (variable-enumerated-domain x
) t
)))
5083 ;; note: This first alternative is an optimization in case membership
5084 ;; can be determined simply through sharing relationships.
5085 (or (known?-notv-memberv-internal x y
)
5086 (every #'(lambda (element) (known?-notv-memberv-internal element y
))
5087 (variable-enumerated-domain x
))))
5088 (t (known?-notv-memberv-internal x y
))))
5090 (defun assert!-memberv-internal
(x y
)
5091 (let ((x (value-of x
)))
5092 (if (known?-notv-memberv x y
) (fail))
5094 (let ((y (value-of y
)))
5095 (unless (variable? y
) (restrict-enumerated-domain! x y
))))))
5097 (defun assert!-memberv
(x y
)
5098 (let ((y (value-of y
)))
5100 (dotimes (i (length y
))
5101 (attach-noticer! #'(lambda () (assert!-memberv-internal x y
))
5103 (attach-noticer! #'(lambda () (assert!-memberv-internal x y
)) y
))))
5105 (defun assert!-notv-memberv-internal
(x y
)
5106 (let ((x (value-of x
)))
5107 (if (known?-memberv x y
) (fail))
5109 (let ((y (value-of y
)))
5110 (unless (variable? y
) (restrict-enumerated-antidomain! x y
))))))
5112 (defun assert!-notv-memberv
(x y
)
5113 (let ((y (value-of y
)))
5115 (dotimes (i (length y
))
5116 (attach-noticer! #'(lambda () (assert!-notv-memberv-internal x y
))
5118 (attach-noticer! #'(lambda () (assert!-notv-memberv-internal x y
)) y
))))
5120 (defun memberv (x y
)
5121 (cond ((known?-memberv x y
) t
)
5122 ((known?-notv-memberv x y
) nil
)
5123 (t (let ((x (variablize x
))
5127 (cond ((known?-memberv x y
) (restrict-true! z
))
5128 ((known?-notv-memberv x y
) (restrict-false! z
))))
5134 (cond ((known?-memberv x y
) (restrict-true! z
))
5135 ((known?-notv-memberv x y
) (restrict-false! z
))))
5139 (cond ((known?-memberv x y
) (restrict-true! z
))
5140 ((known?-notv-memberv x y
) (restrict-false! z
))))
5144 (cond ((variable-true? z
) (assert!-memberv x y
))
5145 ((variable-false? z
) (assert!-notv-memberv x y
))))
5149 ;;; Lifted Arithmetic Comparison Functions (Two argument optimized)
5152 (assert!-numberpv x
)
5153 (assert!-numberpv y
)
5154 (cond ((known?-
=v2-internal x y
) t
)
5155 ((known?-
/=v2-internal x y
) nil
)
5156 (t (let ((x (variablize x
))
5161 (cond ((known?-
=v2-variable x y
) (restrict-true! z
))
5162 ((known?-
/=v2-variable x y
) (restrict-false! z
))))
5166 (cond ((known?-
=v2-variable x y
) (restrict-true! z
))
5167 ((known?-
/=v2-variable x y
) (restrict-false! z
))))
5171 (cond ((variable-true? z
) (assert!-
=v2 x y
))
5172 ((variable-false? z
) (assert!-
/=v2 x y
))))
5179 (cond ((known?-
<=v2-internal x y
) t
)
5180 ((known?-
<v2-internal y x
) nil
)
5181 (t (let ((x (variablize x
))
5186 (cond ((known?-
<=v2-variable x y
) (restrict-true! z
))
5187 ((known?-
<v2-variable y x
) (restrict-false! z
))))
5191 (cond ((known?-
<=v2-variable x y
) (restrict-true! z
))
5192 ((known?-
<v2-variable y x
) (restrict-false! z
))))
5196 (cond ((variable-true? z
) (assert!-
<=v2 x y
))
5197 ((variable-false? z
) (assert!-
<v2 y x
))))
5204 (cond ((known?-
<v2-internal x y
) t
)
5205 ((known?-
<=v2-internal y x
) nil
)
5206 (t (let ((x (variablize x
))
5211 (cond ((known?-
<v2-variable x y
) (restrict-true! z
))
5212 ((known?-
<=v2-variable y x
) (restrict-false! z
))))
5216 (cond ((known?-
<v2-variable x y
) (restrict-true! z
))
5217 ((known?-
<=v2-variable y x
) (restrict-false! z
))))
5221 (cond ((variable-true? z
) (assert!-
<v2 x y
))
5222 ((variable-false? z
) (assert!-
<=v2 y x
))))
5227 (assert!-numberpv x
)
5228 (assert!-numberpv y
)
5229 (cond ((known?-
/=v2-internal x y
) t
)
5230 ((known?-
=v2-internal x y
) nil
)
5231 (t (let ((x (variablize x
))
5236 (cond ((known?-
/=v2-variable x y
) (restrict-true! z
))
5237 ((known?-
=v2-variable x y
) (restrict-false! z
))))
5241 (cond ((known?-
/=v2-variable x y
) (restrict-true! z
))
5242 ((known?-
=v2-variable x y
) (restrict-false! z
))))
5246 (cond ((variable-true? z
) (assert!-
/=v2 x y
))
5247 ((variable-false? z
) (assert!-
=v2 x y
))))
5251 ;;; Lifted NOTV, ANDV and ORV
5254 (assert!-booleanpv x
)
5255 (let ((x (value-of x
)))
5256 (cond ((eq x t
) nil
)
5258 (t (let ((z (a-booleanv)))
5261 (cond ((variable-true? x
) (restrict-false! z
))
5262 ((variable-false? x
) (restrict-true! z
))))
5266 (cond ((variable-true? z
) (restrict-false! x
))
5267 ((variable-false? z
) (restrict-true! x
))))
5271 (defun andv-internal (xs)
5272 (dolist (x xs
) (assert!-booleanpv x
))
5273 (let ((xs (mapcar #'value-of xs
)))
5274 (if (member nil xs
:test
#'eq
)
5276 (let* ((xs (remove t xs
:test
#'eq
))
5277 (count (length xs
)))
5280 ((= count
1) (first xs
))
5281 (t (let ((z (a-booleanv)))
5284 (cond ((variable-true? z
) (dolist (x xs
) (restrict-true! x
)))
5285 ((and (= count
1) (variable-false? z
))
5287 (unless (variable-true? x
) (restrict-false! x
))))))
5291 (attach-noticer!-internal
5293 (cond ((variable-false? x
) (restrict-false! z
))
5295 (local (decf count
))
5296 (cond ((zerop count
) (restrict-true! z
))
5297 ((and (= count
1) (variable-false? z
))
5299 (unless (variable-true? x
)
5300 (restrict-false! x
))))))))
5304 (defun andv (&rest xs
) (andv-internal xs
))
5306 (defun assert!-notv-andv-internal
(xs)
5307 (dolist (x xs
) (assert!-booleanpv x
))
5308 (let ((xs (mapcar #'value-of xs
)))
5309 (unless (member nil xs
:test
#'eq
)
5310 (let* ((xs (remove t xs
:test
#'eq
))
5311 (count (length xs
)))
5312 (cond ((zerop count
) (fail))
5313 ((= count
1) (restrict-false! (first xs
)))
5316 (attach-noticer!-internal
5318 (cond ((variable-false? x
))
5320 (local (decf count
))
5321 (cond ((zerop count
) (fail))
5324 (unless (variable-true? x
)
5325 (restrict-false! x
))))))))
5328 (defun assert!-notv-andv
(&rest xs
) (assert!-notv-andv-internal xs
))
5330 (defun orv-internal (xs)
5331 (dolist (x xs
) (assert!-booleanpv x
))
5332 (let ((xs (mapcar #'value-of xs
)))
5333 (if (member t xs
:test
#'eq
)
5335 (let* ((xs (remove nil xs
:test
#'eq
))
5336 (count (length xs
)))
5339 ((= count
1) (first xs
))
5340 (t (let ((z (a-booleanv)))
5343 (cond ((variable-false? z
)
5344 (dolist (x xs
) (restrict-false! x
)))
5345 ((and (= count
1) (variable-true? z
))
5347 (unless (variable-false? x
) (restrict-true! x
))))))
5351 (attach-noticer!-internal
5353 (cond ((variable-true? x
) (restrict-true! z
))
5354 ((variable-false? x
)
5355 (local (decf count
))
5356 (cond ((zerop count
) (restrict-false! z
))
5357 ((and (= count
1) (variable-true? z
))
5359 (unless (variable-false? x
)
5360 (restrict-true! x
))))))))
5364 (defun orv (&rest xs
) (orv-internal xs
))
5366 (defun assert!-orv-internal
(xs)
5367 (dolist (x xs
) (assert!-booleanpv x
))
5368 (let ((xs (mapcar #'value-of xs
)))
5369 (unless (member t xs
:test
#'eq
)
5370 (let* ((xs (remove nil xs
:test
#'eq
))
5371 (count (length xs
)))
5372 (cond ((zerop count
) (fail))
5373 ((= count
1) (restrict-true! (first xs
)))
5376 (attach-noticer!-internal
5378 (cond ((variable-true? x
))
5379 ((variable-false? x
)
5380 (local (decf count
))
5381 (cond ((zerop count
) (fail))
5384 (unless (variable-false? x
)
5385 (restrict-true! x
))))))))
5388 (defun assert!-orv
(&rest xs
) (assert!-orv-internal xs
))
5390 (defun assert!-clause
(xs ps
)
5391 (dolist (x xs
) (assert!-booleanpv x
))
5392 (let ((xs (mapcar #'value-of xs
)))
5393 (unless (some #'eq xs ps
)
5394 (let (new-xs new-ps
)
5395 (do ((xrest xs
(rest xrest
))
5396 (prest ps
(rest prest
)))
5397 ((or (null xrest
) (null prest
)))
5398 (let ((x (first xrest
))
5400 (unless (eq x
(not p
))
5403 (let ((count (length new-xs
)))
5404 (cond ((zerop count
) (fail))
5407 (restrict-true! (first new-xs
))
5408 (restrict-false! (first new-xs
))))
5409 (t (do ((xrest new-xs
(rest xrest
))
5410 (prest new-ps
(rest prest
)))
5412 (let ((x (first xrest
)))
5413 (attach-noticer!-internal
5416 (cond ((variable-true? x
))
5417 ((variable-false? x
)
5418 (local (decf count
))
5419 (cond ((zerop count
) (fail))
5421 (do ((xrest new-xs
(rest xrest
))
5422 (prest new-ps
(rest prest
)))
5424 (let ((x (first xrest
)))
5428 (restrict-false! x
))))))))))
5430 (cond ((variable-false? x
))
5432 (local (decf count
))
5434 ((zerop count
) (fail))
5436 (do ((xrest new-xs
(rest xrest
))
5437 (prest new-ps
(rest prest
)))
5439 (let ((x (first xrest
)))
5443 (restrict-false! x
)))))))))))
5446 (defun count-trues-internal (xs) (count-if #'identity xs
))
5448 (defun count-trues (&rest xs
) (count-trues-internal xs
))
5450 (defun count-truesv-internal (xs)
5451 (dolist (x xs
) (assert!-booleanpv x
))
5452 (let ((xs (mapcar #'value-of xs
))
5454 (upper (length xs
)))
5456 (cond ((eq x t
) (incf lower
))
5457 ((eq x nil
) (decf upper
))))
5460 (let ((z (an-integer-betweenv lower upper
))
5461 (xs (remove-if #'bound? xs
)))
5464 (if (= upper
(variable-lower-bound z
))
5466 (unless (variable-false? x
) (restrict-true! x
))))
5467 (if (= lower
(variable-upper-bound z
))
5469 (unless (variable-true? x
) (restrict-false! x
)))))
5475 (cond ((variable-false? x
)
5476 (local (decf upper
))
5477 (restrict-upper-bound! z upper
)
5478 (if (= upper
(variable-lower-bound z
))
5480 (unless (variable-false? x
) (restrict-true! x
)))))
5482 (local (incf lower
))
5483 (restrict-lower-bound! z lower
)
5484 (if (= lower
(variable-upper-bound z
))
5486 (unless (variable-true? x
) (restrict-false! x
)))))))
5490 (defun count-truesv (&rest xs
) (count-truesv-internal xs
))
5492 ;;; Lifted FUNCALLV and APPLYV
5494 (defun finite-domain?
(variable)
5495 (let ((variable (value-of variable
)))
5496 (or (not (variable? variable
))
5497 (not (eq (variable-enumerated-domain variable
) t
))
5498 (and (variable-integer? variable
)
5499 (variable-lower-bound variable
)
5500 (variable-upper-bound variable
)))))
5502 ;;; note: SOLUTION, LINEAR-FORCE and STATIC-ORDERING were moved here to be
5503 ;;; before KNOWN?-CONSTRAINT to avoid forward references to
5504 ;;; nondeterministic functions.
5506 (defun solution (x force-function
)
5507 (funcall-nondeterministic
5508 (value-of force-function
) (variables-in (value-of x
)))
5509 (apply-substitution x
))
5511 (defun linear-force (variable)
5512 (let ((variable (value-of variable
)))
5513 (if (variable? variable
)
5516 (cond ((not (eq (variable-enumerated-domain variable
) t
))
5517 (a-member-of (variable-enumerated-domain variable
)))
5518 ((variable-integer? variable
)
5519 (if (variable-lower-bound variable
)
5520 (if (variable-upper-bound variable
)
5522 (variable-lower-bound variable
)
5523 (variable-upper-bound variable
))
5524 (an-integer-above (variable-lower-bound variable
)))
5525 (if (variable-upper-bound variable
)
5526 (an-integer-below (variable-upper-bound variable
))
5528 (t (error "It is only possible to linear force a variable that~%~
5529 has a countable domain"))))))
5530 (value-of variable
))
5532 (defun static-ordering-internal (variables force-function
)
5534 (let ((variable (value-of (first variables
))))
5535 (cond ((variable? variable
)
5536 (funcall-nondeterministic force-function variable
)
5537 (static-ordering-internal variables force-function
))
5538 (t (static-ordering-internal (rest variables
) force-function
))))))
5540 (defun static-ordering (force-function)
5541 ;; note: This closure will heap cons.
5542 (let ((force-function (value-of force-function
)))
5543 #'(lambda (variables) (static-ordering-internal variables force-function
))))
5545 (defun known?-constraint
(f polarity? x
)
5546 (let ((f (value-of f
)))
5548 (error "The current implementation does not allow the first argument~%~
5549 of FUNCALLV or APPLYV to be an unbound variable"))
5550 (unless (functionp f
)
5551 (error "The first argument to FUNCALLV or APPLYV must be a deterministic~%~
5553 (and (every #'finite-domain? x
)
5557 (not (apply f
(solution x
(static-ordering #'linear-force
))))
5558 (apply f
(solution x
(static-ordering #'linear-force
))))
5559 (return-from exit nil
)))
5562 (defun propagate-gfc (predicate polarity? variables unassigned-variable
)
5563 ;; note: UNASSIGNED-VARIABLE must be a variable which is not bound and
5564 ;; all of the VARIABLES except the UNASSIGNED-VARIABLE must be bound.
5565 (let ((unassigned-variable (value-of unassigned-variable
)))
5566 ;; There is no way to propagate a value to a variable that doesn't have an
5567 ;; enumerated domain.
5568 (if (and (not (eq (variable-enumerated-domain unassigned-variable
) t
))
5569 (not (null (rest (variable-enumerated-domain
5570 unassigned-variable
)))))
5571 ;; note: Could do less consing if had LOCAL DELETE-IF-NOT.
5573 (let* ((variable-values (mapcar #'value-of variables
))
5574 (new-enumerated-domain
5580 (mapcar #'(lambda (variable variable-value
)
5581 (if (eq variable unassigned-variable
)
5586 (variable-enumerated-domain unassigned-variable
))
5591 (mapcar #'(lambda (variable variable-value
)
5592 (if (eq variable unassigned-variable
)
5597 (variable-enumerated-domain unassigned-variable
)))))
5598 (if (set-enumerated-domain! unassigned-variable new-enumerated-domain
)
5599 (run-noticers unassigned-variable
))))))
5601 (defun a-tuple (variables variable value
)
5602 (if (null variables
)
5604 (cons (cond ((eq (first variables
) variable
) value
)
5605 ((variable?
(first variables
))
5606 (a-member-of (variable-enumerated-domain (first variables
))))
5607 (t (first variables
)))
5608 (a-tuple (rest variables
) variable value
))))
5610 (defun propagate-ac (predicate polarity? variables
)
5611 (unless (some #'(lambda (variable)
5612 (and (variable? variable
)
5613 (eq (variable-enumerated-domain variable
) t
)))
5615 (dolist (variable variables
)
5616 ;; note: Could do less consing if had LOCAL DELETE-IF-NOT.
5617 (if (variable? variable
)
5618 (let ((new-enumerated-domain
5624 (apply predicate
(a-tuple variables variable value
))))
5625 (variable-enumerated-domain variable
))
5630 (apply predicate
(a-tuple variables variable value
))))
5631 (variable-enumerated-domain variable
)))))
5632 (if (set-enumerated-domain! variable new-enumerated-domain
)
5633 (run-noticers variable
)))))))
5635 (defun assert!-constraint-gfc
(predicate polarity? variables
)
5636 (let ((predicate (value-of predicate
))
5637 (multiple-unassigned-variables? nil
)
5638 (unassigned-variable nil
))
5639 (if (variable? predicate
)
5640 (error "The current implementation does not allow the first argument~%~
5641 of FUNCALLV or APPLYV to be an unbound variable"))
5642 (unless (functionp predicate
)
5643 (error "The first argument to FUNCALLV or APPLYV must be a deterministic~%~
5645 (dolist (variable variables
)
5646 (unless (bound? variable
)
5647 (if unassigned-variable
(setf multiple-unassigned-variables? t
))
5648 (setf unassigned-variable variable
)))
5650 (multiple-unassigned-variables?
5651 ;; The case where two or more variables are unbound
5652 (let ((variables (copy-list variables
)))
5653 (dolist (variable variables
)
5654 (unless (bound? variable
)
5655 (let ((variable variable
))
5660 (let ((unassigned-variable nil
))
5661 (dolist (variable variables
)
5662 (unless (bound? variable
)
5663 (if unassigned-variable
(return-from exit
))
5664 (setf unassigned-variable variable
)))
5665 (if unassigned-variable
5667 predicate polarity? variables unassigned-variable
)
5668 (unless (if polarity?
5669 (apply predicate
(mapcar #'value-of variables
))
5670 (not (apply predicate
5671 (mapcar #'value-of variables
))))
5674 (unassigned-variable
5675 ;; The case where all but one of the variables are bound
5676 (propagate-gfc predicate polarity? variables unassigned-variable
))
5677 ;; The case where all variables are bound
5679 (t (unless (if polarity?
5680 (apply predicate
(mapcar #'value-of variables
))
5681 (not (apply predicate
(mapcar #'value-of variables
))))
5684 (defun assert!-constraint-ac
(predicate polarity? variables
)
5685 (let ((predicate (value-of predicate
)))
5686 (if (variable? predicate
)
5687 (error "The current implementation does not allow the first argument~%~
5688 of FUNCALLV or APPLYV to be an unbound variable"))
5689 (unless (functionp predicate
)
5690 (error "The first argument to FUNCALLV or APPLYV must be a deterministic~%~
5692 (dolist (variable variables
)
5694 #'(lambda () (propagate-ac predicate polarity? variables
))
5696 (propagate-ac predicate polarity? variables
)))
5698 (defun assert!-constraint
(predicate polarity? variables
)
5700 (:gfc
(assert!-constraint-gfc predicate polarity? variables
))
5701 (:ac
(assert!-constraint-ac predicate polarity? variables
))))
5703 (defun known?-funcallv
(f &rest x
) (known?-constraint f t x
))
5705 (defun known?-notv-funcallv
(f &rest x
) (known?-constraint f nil x
))
5707 (defun assert!-funcallv
(f &rest x
) (assert!-constraint f t x
))
5709 (defun assert!-notv-funcallv
(f &rest x
) (assert!-constraint f nil x
))
5711 (defun funcallv (f &rest x
)
5712 (let ((f (value-of f
)))
5714 (error "The current implementation does not allow the first argument~%~
5715 of FUNCALLV to be an unbound variable"))
5716 (unless (functionp f
)
5717 (error "The first argument to FUNCALLV must be a deterministic function"))
5718 (if (every #'bound? x
)
5719 (apply f
(mapcar #'value-of x
))
5720 (let ((z (make-variable)))
5722 #'(lambda (&rest x
) (equal (first x
) (apply f
(rest x
)))) t
(cons z x
))
5723 (dolist (argument x
)
5726 (if (every #'bound? x
)
5727 (assert!-equalv z
(apply f
(mapcar #'value-of x
)))))
5731 (defun arguments-for-applyv (x xs
)
5732 (unless (bound?
(first (last (cons x xs
))))
5733 (error "The current implementation does not allow the last argument to~%~
5734 APPLYV to be an unbound variable"))
5735 (apply #'list
* (mapcar #'value-of
(cons x xs
))))
5737 (defun known?-applyv
(f x
&rest xs
)
5738 (known?-constraint f t
(arguments-for-applyv x xs
)))
5740 (defun known?-notv-applyv
(f x
&rest xs
)
5741 (known?-constraint f nil
(arguments-for-applyv x xs
)))
5743 (defun assert!-applyv
(f x
&rest xs
)
5744 (assert!-constraint f t
(arguments-for-applyv x xs
)))
5746 (defun assert!-notv-applyv
(f x
&rest xs
)
5747 (assert!-constraint f nil
(arguments-for-applyv x xs
)))
5749 (defun applyv (f x
&rest xs
)
5750 (let ((f (value-of f
)))
5752 (error "The current implementation does not allow the first argument~%~
5753 of APPLYV to be an unbound variable"))
5754 (unless (functionp f
)
5755 (error "The first argument to APPLYV must be a deterministic function"))
5756 (let ((arguments (arguments-for-applyv x xs
)))
5757 (if (every #'bound? arguments
)
5758 (apply f
(mapcar #'value-of arguments
))
5759 (let ((z (make-variable)))
5761 #'(lambda (&rest x
) (equal (first x
) (apply f
(rest x
))))
5764 (dolist (argument arguments
)
5767 (if (every #'bound? arguments
)
5768 (assert!-equalv z
(apply f
(mapcar #'value-of arguments
)))))
5774 (defun known?-equalv
(x y
)
5776 (cond ((variable? x
)
5777 (and (not (eq (variable-value x
) x
))
5778 (known?-equalv
(variable-value x
) y
)))
5780 (and (not (eq (variable-value y
) y
))
5781 (known?-equalv x
(variable-value y
))))
5784 (known?-equalv
(car x
) (car y
))
5785 (known?-equalv
(cdr x
) (cdr y
)))))))
5787 (defun assert!-equalv
(x y
)
5789 (cond ((variable? x
)
5790 (cond ((not (eq (variable-value x
) x
))
5791 (assert!-equalv
(variable-value x
) y
))
5793 (if (eq (variable-value y
) y
)
5795 (assert!-equalv x
(variable-value y
))))
5796 (t (restrict-value! x y
))))
5798 (if (eq (variable-value y
) y
)
5799 (restrict-value! y x
)
5800 (assert!-equalv x
(variable-value y
))))
5801 ((and (consp x
) (consp y
))
5802 (assert!-equalv
(car x
) (car y
))
5803 (assert!-equalv
(cdr x
) (cdr y
)))
5806 (defun known?-notv-equalv
(x y
) (one-value (progn (assert!-equalv x y
) nil
) t
))
5808 (defun assert!-notv-equalv
(x y
)
5809 ;; note: Can be made more efficient so that if you later find out that
5810 ;; X and Y are KNOWN?-NUMBERPV you can then ASSERT!-/=V2.
5811 (if (known?-equalv x y
) (fail))
5812 (unless (known?-notv-equalv x y
)
5813 (let ((x (variablize x
))
5815 (attach-noticer! #'(lambda () (if (known?-equalv x y
) (fail))) x
)
5816 (attach-noticer! #'(lambda () (if (known?-equalv x y
) (fail))) y
))))
5819 ;; note: Can be made more efficient and return an AND tree of individual
5820 ;; constraints needed to make EQUALV true. This can be done also for
5821 ;; the KNOWN? and ASSERT! versions.
5822 (cond ((known?-equalv x y
) t
)
5823 ((known?-notv-equalv x y
) nil
)
5824 (t (let ((x (variablize x
))
5829 (cond ((known?-equalv x y
) (restrict-true! z
))
5830 ((known?-notv-equalv x y
) (restrict-false! z
))))
5834 (cond ((known?-equalv x y
) (restrict-true! z
))
5835 ((known?-notv-equalv x y
) (restrict-false! z
))))
5839 (cond ((variable-true? z
) (assert!-equalv x y
))
5840 ((variable-false? z
) (assert!-notv-equalv x y
))))
5844 ;;; Lifted Arithmetic Functions
5846 (defun +v-internal
(xs)
5847 (if (null xs
) 0 (+v2
(first xs
) (+v-internal
(rest xs
)))))
5849 (defun +v
(&rest xs
) (+v-internal xs
))
5851 (defun -v-internal (x xs
)
5852 (if (null xs
) x
(-v-internal (-v2 x
(first xs
)) (rest xs
))))
5854 (defun -v (x &rest xs
) (if (null xs
) (-v2 0 x
) (-v-internal x xs
)))
5856 (defun *v-internal
(xs)
5857 (if (null xs
) 1 (*v2
(first xs
) (*v-internal
(rest xs
)))))
5859 (defun *v
(&rest xs
) (*v-internal xs
))
5861 (defun /v-internal
(x xs
)
5862 (if (null xs
) x
(/v-internal
(/v2 x
(first xs
)) (rest xs
))))
5864 (defun /v
(x &rest xs
) (if (null xs
) (/v2
1 x
) (/v-internal x xs
)))
5866 (defun minv-internal (x xs
)
5867 (if (null xs
) x
(minv-internal (minv2 x
(first xs
)) (rest xs
))))
5869 (defun minv (x &rest xs
) (if (null xs
) x
(minv-internal x xs
)))
5871 (defun maxv-internal (x xs
)
5872 (if (null xs
) x
(maxv-internal (maxv2 x
(first xs
)) (rest xs
))))
5874 (defun maxv (x &rest xs
) (if (null xs
) x
(maxv-internal x xs
)))
5876 ;;; Lifted Arithmetic Comparison Functions (KNOWN? optimized)
5878 (defun known?-
=v-internal
(x xs
)
5881 (and (known?-
=v2 x
(first xs
))
5882 (known?-
=v-internal
(first xs
) (rest xs
)))))
5884 (defun known?-
=v
(x &rest xs
) (known?-
=v-internal x xs
))
5886 (defun known?-
<v-internal
(x xs
)
5889 (and (known?-
<v2 x
(first xs
))
5890 (known?-
<v-internal
(first xs
) (rest xs
)))))
5892 (defun known?-
<v
(x &rest xs
) (known?-
<v-internal x xs
))
5894 (defun known?-
<=v-internal
(x xs
)
5897 (and (known?-
<=v2 x
(first xs
))
5898 (known?-
<=v-internal
(first xs
) (rest xs
)))))
5900 (defun known?-
<=v
(x &rest xs
) (known?-
<=v-internal x xs
))
5902 (defun known?-
>v-internal
(x xs
)
5905 (and (known?-
<v2
(first xs
) x
)
5906 (known?-
>v-internal
(first xs
) (rest xs
)))))
5908 (defun known?-
>v
(x &rest xs
) (known?-
>v-internal x xs
))
5910 (defun known?-
>=v-internal
(x xs
)
5913 (and (known?-
<=v2
(first xs
) x
)
5914 (known?-
>=v-internal
(first xs
) (rest xs
)))))
5916 (defun known?-
>=v
(x &rest xs
) (known?-
>=v-internal x xs
))
5918 (defun known?-
/=v-internal
(x xs
)
5921 (and (known?-
/=v2 x
(first xs
))
5922 (known?-
/=v-internal x
(rest xs
))
5923 (known?-
/=v-internal
(first xs
) (rest xs
)))))
5925 (defun known?-
/=v
(x &rest xs
) (known?-
/=v-internal x xs
))
5927 ;;; Lifted Arithmetic Comparison Functions (ASSERT! optimized)
5929 (defun assert!-
=v-internal
(x xs
)
5931 (assert!-
=v2 x
(first xs
))
5932 (assert!-
=v-internal
(first xs
) (rest xs
))))
5934 (defun assert!-
=v
(x &rest xs
) (assert!-
=v-internal x xs
))
5936 (defun assert!-
<v-internal
(x xs
)
5938 (assert!-
<v2 x
(first xs
))
5939 (assert!-
<v-internal
(first xs
) (rest xs
))))
5941 (defun assert!-
<v
(x &rest xs
) (assert!-
<v-internal x xs
))
5943 (defun assert!-
<=v-internal
(x xs
)
5945 (assert!-
<=v2 x
(first xs
))
5946 (assert!-
<=v-internal
(first xs
) (rest xs
))))
5948 (defun assert!-
<=v
(x &rest xs
) (assert!-
<=v-internal x xs
))
5950 (defun assert!-
>v-internal
(x xs
)
5952 (assert!-
<v2
(first xs
) x
)
5953 (assert!-
>v-internal
(first xs
) (rest xs
))))
5955 (defun assert!-
>v
(x &rest xs
) (assert!-
>v-internal x xs
))
5957 (defun assert!-
>=v-internal
(x xs
)
5959 (assert!-
<=v2
(first xs
) x
)
5960 (assert!-
>=v-internal
(first xs
) (rest xs
))))
5962 (defun assert!-
>=v
(x &rest xs
) (assert!-
>=v-internal x xs
))
5964 (defun assert!-
/=v-internal
(x xs
)
5966 (assert!-
/=v2 x
(first xs
))
5967 (assert!-
/=v-internal x
(rest xs
))
5968 (assert!-
/=v-internal
(first xs
) (rest xs
))))
5970 (defun assert!-
/=v
(x &rest xs
) (assert!-
/=v-internal x xs
))
5972 ;;; Lifted Arithmetic Comparisons Functions
5974 (defun =v-internal
(x xs
)
5977 (andv (=v2 x
(first xs
)) (=v-internal
(first xs
) (rest xs
)))))
5979 (defun =v
(x &rest xs
) (=v-internal x xs
))
5981 (defun <v-internal
(x xs
)
5984 (andv (<v2 x
(first xs
)) (<v-internal
(first xs
) (rest xs
)))))
5986 (defun <v
(x &rest xs
) (<v-internal x xs
))
5988 (defun <=v-internal
(x xs
)
5991 (andv (<=v2 x
(first xs
)) (<=v-internal
(first xs
) (rest xs
)))))
5993 (defun <=v
(x &rest xs
) (<=v-internal x xs
))
5995 (defun >v-internal
(x xs
)
5998 (andv (<v2
(first xs
) x
) (>v-internal
(first xs
) (rest xs
)))))
6000 (defun >v
(x &rest xs
) (>v-internal x xs
))
6002 (defun >=v-internal
(x xs
)
6005 (andv (<=v2
(first xs
) x
) (>=v-internal
(first xs
) (rest xs
)))))
6007 (defun >=v
(x &rest xs
) (>=v-internal x xs
))
6009 (defun /=v-internal
(x xs
)
6012 (andv (/=v2 x
(first xs
))
6013 (/=v-internal x
(rest xs
))
6014 (/=v-internal
(first xs
) (rest xs
)))))
6016 (defun /=v
(x &rest xs
) (/=v-internal x xs
))
6018 ;;; The Optimizer Macros for ASSERT!, KNOWN? and DECIDE
6020 (defun known?-true
(x) (assert!-booleanpv x
) (eq (value-of x
) t
))
6022 (defun known?-false
(x) (assert!-booleanpv x
) (null (value-of x
)))
6024 (defun-compile-time transform-known?
(form polarity?
)
6025 (if (and (consp form
) (null (rest (last form
))))
6027 ((and (eq (first form
) 'notv
)
6028 (= (length form
) 2))
6029 (transform-known?
(second form
) (not polarity?
)))
6030 ((eq (first form
) 'andv
)
6031 (cons (if polarity?
'and
'or
)
6032 (mapcar #'(lambda (form) (transform-known? form polarity?
))
6034 ((eq (first form
) 'orv
)
6035 (cons (if polarity?
'or
'and
)
6036 (mapcar #'(lambda (form) (transform-known? form polarity?
))
6038 ((member (first form
)
6039 '(integerpv realpv numberpv memberv booleanpv
6040 =v
<v
<=v
>v
>=v
/=v funcallv applyv equalv
)
6042 (cons (cdr (assoc (first form
)
6044 '((integerpv . known?-integerpv
)
6045 (realpv . known?-realpv
)
6046 (numberpv . known?-numberpv
)
6047 (memberv . known?-memberv
)
6048 (booleanpv . known?-booleanpv
)
6055 (funcallv . known?-funcallv
)
6056 (applyv . known?-applyv
)
6057 (equalv . known?-equalv
))
6058 '((integerpv . known?-notv-integerpv
)
6059 (realpv . known?-notv-realpv
)
6060 (numberpv . known?-notv-numberpv
)
6061 (memberv . known?-notv-memberv
)
6062 (booleanpv . known?-notv-booleanpv
)
6069 (funcallv . known?-notv-funcallv
)
6070 (applyv . known?-notv-applyv
)
6071 (equalv . known?-notv-equalv
)))
6074 (polarity?
`(known?-true
,form
))
6075 (t `(known?-false
,form
)))
6076 (if polarity?
`(known?-true
,form
) `(known?-false
,form
))))
6078 (defmacro-compile-time known?
(form) (transform-known? form t
))
6080 (defun assert!-true
(x) (assert!-equalv x t
))
6082 (defun assert!-false
(x) (assert!-equalv x nil
))
6084 (defun-compile-time transform-assert
! (form polarity?
)
6085 (if (and (consp form
) (null (rest (last form
))))
6087 ((and (eq (first form
) 'notv
)
6088 (= (length form
) 2))
6089 (transform-assert! (second form
) (not polarity?
)))
6090 ((eq (first form
) 'andv
)
6093 #'(lambda (form) (transform-assert! form polarity?
))
6095 (cond ((null (rest form
)) `(fail))
6096 ((null (rest (rest form
))) `(assert!-false
,(second form
)))
6097 (t `(assert!-notv-andv
,@(rest form
))))))
6098 ((eq (first form
) 'orv
)
6100 (cond ((null (rest form
)) `(fail))
6101 ((null (rest (rest form
))) `(assert!-true
,(second form
)))
6102 (t `(assert!-orv
,@(rest form
))))
6104 #'(lambda (form) (transform-assert! form polarity?
))
6106 ((member (first form
)
6107 '(integerpv realpv numberpv memberv booleanpv
6108 =v
<v
<=v
>v
>=v
/=v funcallv applyv equalv
)
6110 (cons (cdr (assoc (first form
)
6112 '((integerpv . assert
!-integerpv
)
6113 (realpv . assert
!-realpv
)
6114 (numberpv . assert
!-numberpv
)
6115 (memberv . assert
!-memberv
)
6116 (booleanpv . assert
!-booleanpv
)
6123 (funcallv . assert
!-funcallv
)
6124 (applyv . assert
!-applyv
)
6125 (equalv . assert
!-equalv
))
6126 '((integerpv . assert
!-notv-integerpv
)
6127 (realpv . assert
!-notv-realpv
)
6128 (numberpv . assert
!-notv-numberpv
)
6129 (memberv . assert
!-notv-memberv
)
6130 (booleanpv . assert
!-notv-booleanpv
)
6137 (funcallv . assert
!-notv-funcallv
)
6138 (applyv . assert
!-notv-applyv
)
6139 (equalv . assert
!-notv-equalv
)))
6142 (polarity?
`(assert!-true
,form
))
6143 (t `(assert!-false
,form
)))
6144 (if polarity?
`(assert!-true
,form
) `(assert!-false
,form
))))
6146 (defmacro-compile-time assert
! (form) (transform-assert! form t
))
6148 (defun-compile-time transform-decide
(form polarity?
)
6149 (if (and (consp form
) (null (rest (last form
))))
6151 ((and (eq (first form
) 'notv
)
6152 (= (length form
) 2))
6153 (transform-decide (second form
) (not polarity?
)))
6154 ((eq (first form
) 'andv
)
6155 (let ((result (mapcar #'(lambda (form)
6156 (multiple-value-list
6157 (transform-decide form polarity?
)))
6159 (values (reduce #'append
(mapcar #'first result
))
6160 (cons (if polarity?
'progn
'either
)
6161 (mapcar #'second result
))
6162 (cons (if polarity?
'either
'progn
)
6163 (mapcar #'third result
)))))
6164 ((eq (first form
) 'orv
)
6165 (let ((result (mapcar #'(lambda (form)
6166 (multiple-value-list
6167 (transform-decide form polarity?
)))
6169 (values (reduce #'append
(mapcar #'first result
))
6170 (cons (if polarity?
'either
'progn
)
6171 (mapcar #'second result
))
6172 (cons (if polarity?
'progn
'either
)
6173 (mapcar #'third result
)))))
6174 ((member (first form
)
6175 '(integerpv realpv numberpv memberv booleanpv
6176 =v
<v
<=v
>v
>=v
/=v funcallv applyv equalv
)
6178 (let ((arguments (mapcar #'(lambda (argument)
6179 (declare (ignore argument
))
6180 (gensym "ARGUMENT-"))
6182 (values (mapcar #'list arguments
(rest form
))
6183 (cons (cdr (assoc (first form
)
6185 '((integerpv . assert
!-integerpv
)
6186 (realpv . assert
!-realpv
)
6187 (numberpv . assert
!-numberpv
)
6188 (memberv . assert
!-memberv
)
6189 (booleanpv . assert
!-booleanpv
)
6196 (funcallv . assert
!-funcallv
)
6197 (applyv . assert
!-applyv
)
6198 (equalv . assert
!-equalv
))
6199 '((integerpv . assert
!-notv-integerpv
)
6200 (realpv . assert
!-notv-realpv
)
6201 (numberpv . assert
!-notv-numberpv
)
6202 (memberv . assert
!-notv-memberv
)
6203 (booleanpv . assert
!-notv-booleanpv
)
6210 (funcallv . assert
!-notv-funcallv
)
6211 (applyv . assert
!-notv-applyv
)
6212 (equalv . assert
!-notv-equalv
)))
6215 (cons (cdr (assoc (first form
)
6217 '((integerpv . assert
!-notv-integerpv
)
6218 (realpv . assert
!-notv-realpv
)
6219 (numberpv . assert
!-notv-numberpv
)
6220 (memberv . assert
!-notv-memberv
)
6221 (booleanpv . assert
!-notv-booleanpv
)
6228 (funcallv . assert
!-notv-funcallv
)
6229 (applyv . assert
!-notv-applyv
)
6230 (equalv . assert
!-notv-equalv
))
6231 '((integerpv . assert
!-integerpv
)
6232 (realpv . assert
!-realpv
)
6233 (numberpv . assert
!-numberpv
)
6234 (memberv . assert
!-memberv
)
6235 (booleanpv . assert
!-booleanpv
)
6242 (funcallv . assert
!-funcallv
)
6243 (applyv . assert
!-applyv
)
6244 (equalv . assert
!-equalv
)))
6247 (t (let ((argument (gensym "ARGUMENT-")))
6248 (values (list (list argument form
))
6250 `(assert!-true
,argument
)
6251 `(assert!-false
,argument
))
6253 `(assert!-false
,argument
)
6254 `(assert!-true
,argument
))))))
6255 (let ((argument (gensym "ARGUMENT-")))
6257 (list (list argument form
))
6258 (if polarity?
`(assert!-true
,argument
) `(assert!-false
,argument
))
6259 (if polarity?
`(assert!-false
,argument
) `(assert!-true
,argument
))))))
6261 (defmacro-compile-time decide
(form)
6262 (cl:multiple-value-bind
(arguments true false
)
6263 (transform-decide form t
)
6264 `(let ,arguments
(either (progn ,true t
) (progn ,false nil
)))))
6266 ;;; Lifted Generators
6267 ;;; note: The following functions could be handled more efficiently as special
6270 (defun a-booleanv (&optional
(name nil name?
))
6271 (let ((v (if name?
(make-variable name
) (make-variable))))
6272 (assert! (booleanpv v
))
6275 (defun an-integerv (&optional
(name nil name?
))
6276 (let ((v (if name?
(make-variable name
) (make-variable))))
6277 (assert! (integerpv v
))
6280 (defun an-integer-abovev (low &optional
(name nil name?
))
6281 (let ((v (if name?
(make-variable name
) (make-variable))))
6282 (assert! (andv (integerpv v
) (>=v v low
)))
6285 (defun an-integer-belowv (high &optional
(name nil name?
))
6286 (let ((v (if name?
(make-variable name
) (make-variable))))
6287 (assert! (andv (integerpv v
) (<=v v high
)))
6290 (defun an-integer-betweenv (low high
&optional
(name nil name?
))
6291 (let ((v (if name?
(make-variable name
) (make-variable))))
6292 (assert! (andv (integerpv v
) (>=v v low
) (<=v v high
)))
6295 (defun a-realv (&optional
(name nil name?
))
6296 (let ((v (if name?
(make-variable name
) (make-variable))))
6297 (assert! (realpv v
))
6300 (defun a-real-abovev (low &optional
(name nil name?
))
6301 (let ((v (if name?
(make-variable name
) (make-variable))))
6302 (assert! (andv (realpv v
) (>=v v low
)))
6305 (defun a-real-belowv (high &optional
(name nil name?
))
6306 (let ((v (if name?
(make-variable name
) (make-variable))))
6307 (assert! (andv (realpv v
) (<=v v high
)))
6310 (defun a-real-betweenv (low high
&optional
(name nil name?
))
6311 (let ((v (if name?
(make-variable name
) (make-variable))))
6312 (assert! (andv (realpv v
) (>=v v low
) (<=v v high
)))
6315 (defun a-numberv (&optional
(name nil name?
))
6316 (let ((v (if name?
(make-variable name
) (make-variable))))
6317 (assert! (numberpv v
))
6320 (defun a-member-ofv (values &optional
(name nil name?
))
6321 (let ((v (if name?
(make-variable name
) (make-variable))))
6322 (assert! (memberv v values
))
6327 (defun variables-in (x)
6329 (cons (append (variables-in (car x
)) (variables-in (cdr x
))))
6333 ;;; note: SOLUTION and LINEAR-FORCE used to be here but was moved to be before
6334 ;;; KNOWN?-CONSTRAINT to avoid forward references to nondeterministic
6337 (defun divide-and-conquer-force (variable)
6338 (let ((variable (value-of variable
)))
6339 (if (variable? variable
)
6341 ((not (eq (variable-enumerated-domain variable
) t
))
6342 (let ((n (floor (length (variable-enumerated-domain variable
)) 2)))
6343 (set-enumerated-domain!
6345 (either (subseq (variable-enumerated-domain variable
) 0 n
)
6346 (subseq (variable-enumerated-domain variable
) n
)))
6347 (run-noticers variable
)))
6348 ((and (variable-real? variable
)
6349 (variable-lower-bound variable
)
6350 (variable-upper-bound variable
))
6351 (if (variable-integer? variable
)
6352 (let ((midpoint (floor (+ (variable-lower-bound variable
)
6353 (variable-upper-bound variable
))
6355 (either (let ((old-bound (variable-upper-bound variable
)))
6356 (restrict-upper-bound! variable midpoint
)
6357 (if (= old-bound
(variable-upper-bound variable
))
6359 (let ((old-bound (variable-lower-bound variable
)))
6360 (restrict-lower-bound! variable
(1+ midpoint
))
6361 (if (= old-bound
(variable-lower-bound variable
))
6363 (let ((midpoint (/ (+ (variable-lower-bound variable
)
6364 (variable-upper-bound variable
))
6366 (either (let ((old-bound (variable-upper-bound variable
)))
6367 (restrict-upper-bound! variable midpoint
)
6368 (if (= old-bound
(variable-upper-bound variable
))
6370 (let ((old-bound (variable-lower-bound variable
)))
6371 (restrict-lower-bound! variable midpoint
)
6372 (if (= old-bound
(variable-lower-bound variable
))
6374 (t (error "It is only possible to divide and conquer force a~%~
6375 variable that has a countable domain or a finite range")))))
6376 (value-of variable
))
6378 ;;; note: STATIC-ORDERING used to be here but was moved to be before
6379 ;;; KNOWN?-CONSTRAINT to avoid a forward reference to a nondeterministic
6382 (defun domain-size (x)
6383 (let ((x (value-of x
)))
6385 (cons (infinity-* (domain-size (car x
)) (domain-size (cdr x
))))
6387 (cond ((not (eq (variable-enumerated-domain x
) t
))
6388 (length (variable-enumerated-domain x
)))
6389 ((and (variable-lower-bound x
)
6390 (variable-upper-bound x
)
6391 (variable-integer? x
))
6392 (1+ (- (variable-upper-bound x
) (variable-lower-bound x
))))
6396 (defun range-size (x)
6397 (let ((x (value-of x
)))
6401 (variable (and (variable-real? x
)
6402 (variable-lower-bound x
)
6403 (variable-upper-bound x
)
6404 (- (variable-upper-bound x
) (variable-lower-bound x
))))
6407 (defun corrupted?
(variable)
6408 (let* ((lower-bound (variable-lower-bound variable
))
6409 (upper-bound (variable-upper-bound variable
)))
6412 (/= lower-bound upper-bound
)
6413 (let ((midpoint (/ (+ lower-bound upper-bound
) 2)))
6414 (or (= midpoint lower-bound
) (= midpoint upper-bound
))))))
6416 (defun find-best (cost order list
)
6420 (let ((x (value-of x
)))
6421 (if (and (variable? x
) (not (corrupted? x
)))
6422 (let ((cost (funcall cost x
)))
6423 (when (and (not (null cost
))
6424 (or (null best-cost
) (funcall order cost best-cost
)))
6426 (setf best-cost cost
))))))
6429 (defun reorder-internal
6430 (variables cost-function terminate? order force-function
)
6431 (let ((variable (find-best cost-function order variables
)))
6433 (not (funcall terminate?
(funcall cost-function variable
))))
6434 (funcall-nondeterministic force-function
(value-of variable
))
6436 variables cost-function terminate? order force-function
))))
6438 (defun reorder (cost-function terminate? order force-function
)
6439 ;; note: This closure will heap cons.
6440 (let ((cost-function (value-of cost-function
))
6441 (terminate?
(value-of terminate?
))
6442 (order (value-of order
))
6443 (force-function (value-of force-function
)))
6444 #'(lambda (variables)
6446 variables cost-function terminate? order force-function
))))
6448 (defmacro-compile-time best-value
6449 (form1 objective-form
&optional
(form2 nil form2?
))
6450 (let ((bound (gensym "BOUND-"))
6451 (best (gensym "BEST-"))
6452 (objective (gensym "OBJECTIVE-")))
6455 (,objective
(variablize ,objective-form
)))
6458 (if (and ,bound
(<= (variable-upper-bound ,objective
) ,bound
)) (fail)))
6461 (let ((value ,form1
))
6462 (global (setf ,bound
(variable-upper-bound ,objective
))
6463 (setf ,best value
))))
6464 (if ,bound
(list ,best
,bound
) ,(if form2? form2
'(fail))))))
6466 (defun template-internal (template variables
)
6468 ((and (symbolp template
) (char= #\? (aref (string template
) 0)))
6469 (let ((binding (assoc template variables
:test
#'eq
)))
6471 (values (cdr binding
) variables
)
6472 (let ((variable (make-variable template
)))
6473 (values variable
(cons (cons template variable
) variables
))))))
6475 (cl:multiple-value-bind
(car-template car-variables
)
6476 (template-internal (car template
) variables
)
6477 (cl:multiple-value-bind
(cdr-template cdr-variables
)
6478 (template-internal (cdr template
) car-variables
)
6479 (values (cons car-template cdr-template
) cdr-variables
))))
6480 (t (values template variables
))))
6482 (defun template (template)
6483 (template-internal (value-of template
) '()))
6485 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
6486 (setf *screamer?
* nil
))
6488 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
6489 (pushnew :screamer
*features
* :test
#'eq
))
6491 ;;; Tam V'Nishlam Shevah L'El Borei Olam