screamer.lisp

   1 ;;; -*- Mode: LISP; Package: (SCREAMER :USE CL :COLON-MODE :EXTERNAL); Base: 10; Syntax: Ansi-common-lisp -*-
   2
   3 ;;; LaHaShem HaAretz U'Mloah
   4
   5 ;;; Screamer
   6 ;;; A portable efficient implementation of nondeterministic CommonLisp
   7 ;;; Version 3.20
   8 ;;;
   9 ;;; Written by:
  10 ;;;
  11 ;;;   Jeffrey Mark Siskind (Department of Computer Science, University of Toronto)
  12 ;;;   David Allen McAllester (MIT Artificial Intelligence Laboratory)
  13 ;;;
  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.
  17 ;;;
  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:
  24 ;;;
  25 ;;; The above copyright and authorship notice and this permission notice shall be
  26 ;;; included in all copies or substantial portions of the Software.
  27 ;;;
  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.
  34
  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*)
  39
  40 ;;; TTMTTD
  41 ;;;  1. Manual.
  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.
  53 ;;; 10. BEST-VALUE
  54 ;;; 11. Should cache VARIABLE-LOWER-BOUND/VARIABLE-UPPER-BOUND for domain
  55 ;;;     variables.
  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
  60 ;;;     they return.
  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.
  67
  68 ;;; Bugs to fix
  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.
  79
  80 ;;; Limitations
  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.
  95 ;;;     Currently handle:
  96 ;;;       BLOCK
  97 ;;;       FUNCTION
  98 ;;;       GO
  99 ;;;       IF
 100 ;;;       LET
 101 ;;;       LET*
 102 ;;;       MULTIPLE-VALUE-CALL
 103 ;;;       MULTIPLE-VALUE-PROG1
 104 ;;;       PROGN
 105 ;;;       QUOTE
 106 ;;;       RETURN-FROM
 107 ;;;       SETQ
 108 ;;;       TAGBODY
 109 ;;;       THE
 110 ;;;     Probably will never handle:
 111 ;;;       CATCH
 112 ;;;       DECLARE
 113 ;;;       EVAL-WHEN
 114 ;;;       FLET
 115 ;;;       LABELS
 116 ;;;       MACROLET
 117 ;;;       PROGV
 118 ;;;       THROW
 119 ;;;       UNWIND-PROTECT
 120 ;;;    CLtL1 obsolete:
 121 ;;;       COMPILER-LET
 122 ;;;    CLtL2 additions:
 123 ;;;       GENERIC-FLET
 124 ;;;       GENERIC-LABELS
 125 ;;;       LOAD-TIME-VALUE
 126 ;;;       LOCALLY
 127 ;;;       WITH-ADDED-METHODS
 128 ;;;       SYMBOL-MACROLET
 129
 130 ;;; Change Log
 131 ;;; W25Sep91 Qobi
 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.
 137 ;;; W25Sep91 Qobi
 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.
 143 ;;; W25Sep91 Qobi
 144 ;;;  Made SOLUTION walk its argument.
 145 ;;; W25Sep91 Qobi
 146 ;;;  Separated USE-PACKAGE from IN-PACKAGE.
 147 ;;; W25Sep91 Qobi
 148 ;;;  Added *SCREAMER-VERSION*. Set it to 2.1
 149 ;;; H28Sep91 Qobi
 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.
 153 ;;; W2Oct91 Qobi
 154 ;;;  Fixed bug in VARIABLES-IN. Version 2.3.
 155 ;;; R3Oct91 Qobi
 156 ;;;  Added COUNT-FAILURES. Version 2.4.
 157 ;;; S13Oct91 Qobi
 158 ;;;  Added :SCREAMER to *FEATURES* at the request of CGDEMARC. Version 2.5.
 159 ;;; F25Oct91 Qobi
 160 ;;;  Fixed bug with FUTURE-COMMON-LISP on Symbolics with SETF, FUNCTION and
 161 ;;;  LAMBDA. Version 2.6.
 162 ;;; M4Nov91 Qobi
 163 ;;;  Fixed INTEGER-BETWEEN to work correctly with noninteger arguments.
 164 ;;;  Removed SUBST form of Beta-conversion. Version 2.7.
 165 ;;; S1Dec91 Qobi
 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.
 172 ;;;  Added POSSIBLY?
 173 ;;;  Added LOCAL-I/O
 174 ;;;  Version 2.8.
 175 ;;; T11Feb92 Qobi
 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.
 182 ;;;  Version 2.9.
 183 ;;; M16Mar92 Qobi
 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
 191 ;;;  VARIABLE.
 192 ;;;  Enforce non-NIL function names.
 193 ;;;  Added SCREAMER? argument to WALK.
 194 ;;;  Allow FLET/LABELS to bind SETF functions.
 195 ;;;  Version 2.10.
 196 ;;; T17Mar92 Qobi
 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
 200 ;;;  FUNCTION.
 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.
 205 ;;;  Version 2.11.
 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
 228 ;;;  variables.
 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.
 233 ;;;  Version 2.12.
 234 ;;; R30Apr92 Qobi
 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.
 239 ;;;  Version 2.13
 240 ;;; S24May92 Qobi
 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
 246 ;;;  bounds.
 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
 252 ;;;  DEFUN.
 253 ;;;  Version 2.14
 254 ;;; T26May92 Qobi
 255 ;;;  Fixed a bug in the redone dependency calculations.
 256 ;;;  Version 2.15
 257 ;;; R28May92 Qobi
 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.
 261 ;;;  Version 2.16
 262 ;;; S14Jun92 Qobi
 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.
 272 ;;;  Version 2.17
 273 ;;; R18Jun92 Qobi
 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.
 280 ;;;  Version 3.0
 281 ;;; W29Jul92 Qobi
 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.
 286 ;;;  Version 3.1
 287 ;;; W12Aug92 Qobi
 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
 303 ;;;  optimization.
 304 ;;;  Version 3.2
 305 ;;; F21Aug92 Qobi
 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.
 327 ;;;  Version 3.3
 328 ;;; W26Aug92 Qobi
 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.
 337 ;;;  Version 3.4
 338 ;;; F11Sep92 Qobi
 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.
 345 ;;;  Version 3.5
 346 ;;; T27Oct92 Qobi
 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
 355 ;;;  RETURN-FROM.
 356 ;;;  Version 3.6
 357 ;;; W3Nov92 Qobi
 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.
 362 ;;;  Version 3.7
 363 ;;; R12Nov92 Qobi
 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!.
 369 ;;;  Version 3.8
 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!.
 375 ;;;  Version 3.9
 376 ;;; M15Mar93 Qobi
 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.
 380 ;;;  Version 3.10
 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.
 403 ;;;  Version 3.11
 404 ;;; S12Jul93 Qobi
 405 ;;;  To consolidate version skew on version 3.11.
 406 ;;;  Version 3.12
 407 ;;; T20Jul93 Qobi
 408 ;;;  Fixed bug in -V2 (i.e. (-V2 0 <variable>)) by removing bogus special case.
 409 ;;;  Version 3.13
 410 ;;; T27Jul93 Qobi
 411 ;;;  Since ATTACH-NOTICER! now runs the noticer after attaching it removed the
 412 ;;;  cases where the noticers were explicitly run by lifted functions.
 413 ;;;  Version 3.14
 414 ;;; W22Sep93 Qobi
 415 ;;;  Iterate no longer exports FINISH under AKCL since it conflicts with PCL.
 416 ;;;  TERMINATE is a synonym anyway.
 417 ;;;  Version 3.15
 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.
 431 ;;;  Version 3.16
 432 ;;; T26Oct93 Qobi
 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
 435 ;;;  side effect.
 436 ;;;  Version 3.17
 437 ;;; M22Nov93 Qobi
 438 ;;;  Fixed bug in CPS-CONVERT-RETURN-FROM that surfaced due to the previous
 439 ;;;  bug fix.
 440 ;;;  Version 3.18
 441 ;;; M27Dec93 Qobi
 442 ;;;  Fixed bug in WHEN-FAILING so that it now nests.
 443 ;;;  Version 3.19
 444 ;;; T8Mar94 Qobi
 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.
 449 ;;;  Version 3.20
 450
 451 (in-package :cl-user)
 452
 453 (defpackage :screamer
 454   (:shadow :defun :multiple-value-bind :y-or-n-p :variable)
 455   (:use :cl)
 456   (:export :either
 457            :fail
 458            :local
 459            :global
 460            :for-effects
 461            :multiple-value-call-nondeterministic
 462            :one-value
 463            :possibly?
 464            :necessarily?
 465            :all-values
 466            :ith-value
 467            :print-values
 468            :nondeterministic-function?
 469            :funcall-nondeterministic
 470            :apply-nondeterministic
 471            :unwind-trail
 472            :purge
 473            :unwedge-screamer
 474            :local-output
 475            :a-boolean
 476            :an-integer
 477            :an-integer-above
 478            :an-integer-below
 479            :an-integer-between
 480            :a-member-of
 481            :when-failing
 482            :count-failures
 483            :boolean
 484            :booleanp
 485            :make-variable
 486            :numberpv
 487            :realpv
 488            :integerpv
 489            :booleanpv
 490            :memberv
 491            :assert!
 492            :known?
 493            :decide
 494            :=v
 495            :<v
 496            :<=v
 497            :>v
 498            :>=v
 499            :/=v
 500            :a-booleanv
 501            :an-integerv
 502            :an-integer-abovev
 503            :an-integer-belowv
 504            :an-integer-betweenv
 505            :a-realv
 506            :a-real-abovev
 507            :a-real-belowv
 508            :a-real-betweenv
 509            :a-numberv
 510            :a-member-ofv
 511            :notv
 512            :andv
 513            :orv
 514            :count-trues
 515            :count-truesv
 516            :+v
 517            :-v
 518            :*v
 519            :/v
 520            :minv
 521            :maxv
 522            :funcallv
 523            :applyv
 524            :equalv
 525            :bound?
 526            :value-of
 527            :ground?
 528            :apply-substitution
 529            :linear-force
 530            :divide-and-conquer-force
 531            :static-ordering
 532            :domain-size
 533            :range-size
 534            :reorder
 535            :solution
 536            :best-value
 537            :template
 538            :define-screamer-package
 539            :*screamer-version*
 540            :*dynamic-extent?*
 541            :*iscream?*
 542            :*minimum-shrink-ratio*
 543            :*maximum-discretization-range*
 544            :*strategy*))
 545
 546 (in-package :screamer)
 547
 548 (declaim (declaration magic))
 549
 550 (defmacro define-screamer-package (defined-package-name &rest options)
 551   `(defpackage ,defined-package-name
 552      ,@options
 553      (:shadowing-import-from :screamer :defun :multiple-value-bind :y-or-n-p)
 554      (:use :cl :screamer)))
 555
 556 (define-screamer-package :screamer-user)
 557
 558 (defmacro defstruct-compile-time (options &body items)
 559   `(eval-when (:compile-toplevel :load-toplevel :execute)
 560      (defstruct ,options ,@items)))
 561
 562 (defmacro defvar-compile-time (name &optional initial-value documentation)
 563   `(eval-when (:compile-toplevel :load-toplevel :execute)
 564      (defvar ,name ,initial-value ,documentation)))
 565
 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))))
 570
 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)))
 577
 578 (defparameter *screamer-version* "3.20"
 579   "The version of Screamer which is loaded.")
 580
 581 (defvar-compile-time *dynamic-extent?* t
 582   "T to enable the dynamic extent optimization.")
 583
 584 (defvar *iscream?* nil
 585   "T if Screamer is running under ILisp/GNUEmacs with iscream.el loaded.")
 586
 587 (defvar *nondeterministic?* nil "This must be globally NIL.")
 588
 589 (defvar-compile-time *screamer?* nil
 590   "This must be NIL except when defining internal Screamer functions.")
 591
 592 (defvar-compile-time *nondeterministic-context?* nil
 593   "This must be globally NIL.")
 594
 595 (defvar-compile-time *local?* nil "This must be globally NIL.")
 596
 597 (defvar-compile-time *block-tags* '() "This must be globally NIL.")
 598
 599 (defvar-compile-time *tagbody-tags* '() "This must be globally NIL.")
 600
 601 (defvar *trail* (make-array 4096 :adjustable t :fill-pointer 0) "The trail.")
 602
 603 (defvar-compile-time *function-record-table* (make-hash-table :test #'equal)
 604   "The function record table.")
 605
 606 (defvar-compile-time *ordered-lambda-list-keywords*
 607     '(&optional &rest &key &allow-other-keys &aux)
 608   "The allowed lambda list keywords in order.")
 609
 610 (defmacro-compile-time choice-point-internal (form)
 611   ;; note: Is it really better to use VECTOR-PUSH-EXTEND than CONS for the
 612   ;;       trail?
 613   `(catch 'fail
 614      (let ((*nondeterministic?* t))
 615        (unwind-protect ,form
 616          (block nil
 617            (tagbody
 618             loop
 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
 622               ;;       collected.
 623               (setf (aref *trail* (fill-pointer *trail*)) nil)
 624               (go loop)))))))
 625
 626 (defmacro-compile-time choice-point-external (&rest forms)
 627   ;; note: Is it really better to use VECTOR-PUSH-EXTEND than CONS for the
 628   ;;       trail?
 629   `(let ((trail-pointer (fill-pointer *trail*))) ,@forms))
 630
 631 (defmacro-compile-time choice-point (form)
 632   `(choice-point-external (choice-point-internal ,form)))
 633
 634 (defstruct-compile-time function-record
 635   function-name
 636   (lambda-list nil)
 637   (body nil)
 638   (callees nil)
 639   (deterministic? t)
 640   (old-deterministic? nil)
 641   (screamer? *screamer?*))
 642
 643 (defstruct-compile-time (nondeterministic-function
 644                          (:print-function print-nondeterministic-function)
 645                          (:predicate nondeterministic-function?-internal))
 646   function)
 647
 648 (defun-compile-time screamer-error (header &rest args)
 649   (apply
 650    #'error
 651    (concatenate
 652     'string
 653     header
 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.")
 663    args))
 664
 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))
 670     function-record))
 671
 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?
 680                (not (null body))
 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))
 686                        (consp (first body))
 687                        (eq (first (first body)) 'declare))
 688             (return))
 689       (push (first body) declarations)
 690       (pop body))
 691     (values body (reverse declarations) documentation-string)))
 692
 693 (defun-compile-time self-evaluating? (thing)
 694   (and (not (consp thing))
 695        (or (not (symbolp thing))
 696            (null thing)
 697            (eq thing t)
 698            (eq (symbol-package thing) (symbol-package :x)))))
 699
 700 (defun-compile-time quotify (thing)
 701   (if (self-evaluating? thing) thing `',thing))
 702
 703 (defun-compile-time lambda-expression? (form)
 704   (and (consp form)
 705        (eq (first form) 'lambda)
 706        (or (and (null (rest (last form)))
 707                 (>= (length form) 2)
 708                 (listp (second form)))
 709            (error "Invalid syntax for LAMBDA expression: ~S" form))))
 710
 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))))))
 719
 720 (defun-compile-time check-function-name (function-name)
 721   (unless (valid-function-name? function-name)
 722     (error "Invalid function name: ~S" function-name)))
 723
 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)))))))
 728
 729 (defun-compile-time check-lambda-list-internal (lambda-list &optional mode)
 730   (cond
 731     ((null lambda-list))
 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)))
 735          (ecase mode
 736            ((nil)
 737             (unless (symbolp parameter)
 738               (error "Invalid parameter: ~S" parameter)))
 739            (&optional
 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)))
 749            (&rest
 750             (unless (symbolp parameter)
 751               (error "Invalid &REST parameter: ~S" parameter)))
 752            (&key
 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)))
 767            (&aux
 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))))
 776
 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)))
 781     (if rest
 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
 789                                    :test #'eq)))
 790             (error "&REST must be followed by exactly one variable: ~S"
 791                    lambda-list)))))
 792   (let ((allow-other-keys (member '&allow-other-keys lambda-list :test #'eq)))
 793     (if allow-other-keys
 794         (unless (or (null (rest allow-other-keys))
 795                     (member (first (rest allow-other-keys)) lambda-list-keywords
 796                             :test #'eq))
 797           (error "&ALLOW-OTHER-KEYS must not be followed by a parameter: ~S"
 798                  lambda-list))))
 799   (let ((keywords
 800          (remove-if-not #'(lambda (argument)
 801                             (member argument lambda-list-keywords :test #'eq))
 802                         lambda-list)))
 803     (unless (every #'(lambda (keyword)
 804                        (member keyword *ordered-lambda-list-keywords* :test #'eq))
 805                    keywords)
 806       (error "Invalid lambda list keyword: ~S" lambda-list))
 807     (unless (every #'(lambda (x y)
 808                        (member y (member x *ordered-lambda-list-keywords*
 809                                          :test #'eq)
 810                                :test #'eq))
 811                    keywords
 812                    (rest keywords))
 813       (error "Invalid order for lambda list keywords: ~S" lambda-list)))
 814   (check-lambda-list-internal lambda-list))
 815
 816 (defun-compile-time walk-lambda-list-reducing
 817     (map-function reduce-function screamer? partial? nested? lambda-list
 818                   environment &optional mode)
 819   (cond
 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
 823                                 reduce-function
 824                                 screamer?
 825                                 partial?
 826                                 nested?
 827                                 (rest lambda-list)
 828                                 environment
 829                                 (first lambda-list)))
 830     (t (ecase mode
 831          ((nil &rest &allow-other-keys &aux)
 832           (walk-lambda-list-reducing map-function
 833                                      reduce-function
 834                                      screamer?
 835                                      partial?
 836                                      nested?
 837                                      (rest lambda-list)
 838                                      environment
 839                                      mode))
 840          ((&optional &key)
 841           (if (and (consp (first lambda-list))
 842                    (consp (rest (first lambda-list))))
 843               (funcall
 844                reduce-function
 845                (walk map-function reduce-function screamer? partial? nested?
 846                      (second (first lambda-list)) environment)
 847                (walk-lambda-list-reducing map-function
 848                                           reduce-function
 849                                           screamer?
 850                                           partial?
 851                                           nested?
 852                                           (rest lambda-list)
 853                                           environment
 854                                           mode))
 855               (walk-lambda-list-reducing map-function
 856                                          reduce-function
 857                                          screamer?
 858                                          partial?
 859                                          nested?
 860                                          (rest lambda-list)
 861                                          environment
 862                                          mode)))))))
 863
 864 (defun-compile-time walk-lambda-list
 865     (map-function reduce-function screamer? partial? nested? lambda-list
 866                   environment)
 867   (check-lambda-list lambda-list)
 868   (if reduce-function
 869       (funcall
 870        reduce-function
 871        (funcall map-function lambda-list 'lambda-list)
 872        (walk-lambda-list-reducing map-function
 873                                   reduce-function
 874                                   screamer?
 875                                   partial?
 876                                   nested?
 877                                   lambda-list
 878                                   environment))
 879       (funcall map-function lambda-list 'lambda-list)))
 880
 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))
 887   (if reduce-function
 888       (funcall reduce-function
 889                (funcall map-function form 'block)
 890                (reduce reduce-function
 891                        (mapcar #'(lambda (subform)
 892                                    (walk map-function
 893                                          reduce-function
 894                                          screamer?
 895                                          partial?
 896                                          nested?
 897                                          subform
 898                                          environment))
 899                                (rest (rest form)))))
 900       (funcall map-function form 'block)))
 901
 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))
 907   (if reduce-function
 908       (funcall reduce-function
 909                (funcall map-function form 'catch)
 910                (reduce reduce-function
 911                        (mapcar #'(lambda (subform)
 912                                    (walk map-function
 913                                          reduce-function
 914                                          screamer?
 915                                          partial?
 916                                          nested?
 917                                          subform
 918                                          environment))
 919                                (rest form))))
 920       (funcall map-function form 'catch)))
 921
 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
 933                                          :load-top-level
 934                                          :execute
 935                                          compile
 936                                          load
 937                                          evel)
 938                              :test #'eq))
 939                  (second form))
 940     (error "Invalid SITUATION: ~S" form))
 941   (if (member :execute (second form) :test #'eq)
 942       (walk-progn map-function
 943                   reduce-function
 944                   screamer?
 945                   partial?
 946                   nested?
 947                   `(progn ,@(rest (rest form)))
 948                   environment)
 949       (funcall map-function nil 'quote)))
 950
 951 (defun-compile-time walk-flet/labels
 952     (map-function reduce-function screamer? partial? nested? form environment
 953                   form-type)
 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)
 960                           (and (consp binding)
 961                                (null (rest (last binding)))
 962                                (>= (length binding) 2)
 963                                (valid-function-name? (first binding))
 964                                (listp (second binding))))
 965                       (second form)))
 966     (error "Invalid BINDINGS for ~S: ~S" form-type form))
 967   (if reduce-function
 968       (funcall
 969        reduce-function
 970        (funcall map-function form form-type)
 971        (if nested?
 972            (funcall
 973             reduce-function
 974             (reduce
 975              reduce-function
 976              (mapcar
 977               #'(lambda (binding)
 978                   (funcall reduce-function
 979                            (walk-lambda-list map-function
 980                                              reduce-function
 981                                              screamer?
 982                                              partial?
 983                                              nested?
 984                                              (second binding)
 985                                              environment)
 986                            (mapcar
 987                             #'(lambda (subform)
 988                                 (walk map-function
 989                                       reduce-function
 990                                       screamer?
 991                                       partial?
 992                                       nested?
 993                                       subform
 994                                       environment))
 995                             (peal-off-documentation-string-and-declarations
 996                              (rest (rest binding)) t))))
 997               (second form)))
 998             (reduce reduce-function
 999                     (mapcar #'(lambda (subform)
1000                                 (walk map-function
1001                                       reduce-function
1002                                       screamer?
1003                                       partial?
1004                                       nested?
1005                                       subform
1006                                       environment))
1007                             (rest (rest form)))))
1008            (reduce reduce-function
1009                    (mapcar #'(lambda (subform)
1010                                (walk map-function
1011                                      reduce-function
1012                                      screamer?
1013                                      partial?
1014                                      nested?
1015                                      subform
1016                                      environment))
1017                            (rest (rest form))))))
1018       (funcall map-function form form-type)))
1019
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?)
1027              (funcall
1028               reduce-function
1029               (funcall map-function form 'function-lambda)
1030               (funcall
1031                reduce-function
1032                (walk-lambda-list map-function
1033                                  reduce-function
1034                                  screamer?
1035                                  partial?
1036                                  nested?
1037                                  (second (second form))
1038                                  environment)
1039                (reduce
1040                 reduce-function
1041                 (mapcar #'(lambda (subform)
1042                             (walk map-function
1043                                   reduce-function
1044                                   screamer?
1045                                   partial?
1046                                   nested?
1047                                   subform
1048                                   environment))
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))
1053          (cond
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~%~
1058                       macro: ~S"
1059                        form)
1060                 (funcall map-function form 'function-symbol)))
1061            (t (funcall map-function form 'function-setf))))
1062         (t (error "Invalid argument to FUNCTION: ~S" form))))
1063
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))
1070
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))
1076   (if reduce-function
1077       (if (= (length form) 4)
1078           (funcall reduce-function
1079                    (funcall map-function form 'if)
1080                    (funcall reduce-function
1081                             (walk map-function
1082                                   reduce-function
1083                                   screamer?
1084                                   partial?
1085                                   nested?
1086                                   (second form)
1087                                   environment)
1088                             (funcall reduce-function
1089                                      (walk map-function
1090                                            reduce-function
1091                                            screamer?
1092                                            partial?
1093                                            nested?
1094                                            (third form)
1095                                            environment)
1096                                      (walk map-function
1097                                            reduce-function
1098                                            screamer?
1099                                            partial?
1100                                            nested?
1101                                            (fourth form)
1102                                            environment))))
1103           (funcall reduce-function
1104                    (funcall map-function form 'if)
1105                    (funcall reduce-function
1106                             (walk map-function
1107                                   reduce-function
1108                                   screamer?
1109                                   partial?
1110                                   nested?
1111                                   (second form)
1112                                   environment)
1113                             (walk map-function
1114                                   reduce-function
1115                                   screamer?
1116                                   partial?
1117                                   nested?
1118                                   (third form)
1119                                   environment))))
1120       (funcall map-function form 'if)))
1121
1122 (defun-compile-time walk-let/let*
1123     (map-function reduce-function screamer? partial? nested? form environment
1124                   form-type)
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)))))
1137                       (second form)))
1138     (error "Invalid BINDINGS for ~S: ~S" form-type form))
1139   (if reduce-function
1140       (funcall
1141        reduce-function
1142        (funcall map-function form form-type)
1143        (funcall reduce-function
1144                 (reduce reduce-function
1145                         (mapcar #'(lambda (binding)
1146                                     (walk map-function
1147                                           reduce-function
1148                                           screamer?
1149                                           partial?
1150                                           nested?
1151                                           (second binding)
1152                                           environment))
1153                                 (remove-if-not
1154                                  #'(lambda (binding)
1155                                      (and (consp binding)
1156                                           (= (length binding) 2)))
1157                                  (second form))))
1158                 (reduce reduce-function
1159                         (mapcar #'(lambda (subform)
1160                                     (walk map-function
1161                                           reduce-function
1162                                           screamer?
1163                                           partial?
1164                                           nested?
1165                                           subform
1166                                           environment))
1167                                 (peal-off-documentation-string-and-declarations
1168                                  (rest (rest form)))))))
1169       (funcall map-function form form-type)))
1170
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"
1177            form))
1178   (if reduce-function
1179       (funcall reduce-function
1180                (funcall map-function form 'multiple-value-call)
1181                (reduce reduce-function
1182                        (mapcar #'(lambda (subform)
1183                                    (walk map-function
1184                                          reduce-function
1185                                          screamer?
1186                                          partial?
1187                                          nested?
1188                                          subform
1189                                          environment))
1190                                (rest form))))
1191       (funcall map-function form 'multiple-value-call)))
1192
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"
1199            form))
1200   (if reduce-function
1201       (funcall reduce-function
1202                (funcall map-function form 'multiple-value-prog1)
1203                (reduce reduce-function
1204                        (mapcar #'(lambda (subform)
1205                                    (walk map-function
1206                                          reduce-function
1207                                          screamer?
1208                                          partial?
1209                                          nested?
1210                                          subform
1211                                          environment))
1212                                (rest form))))
1213       (funcall map-function form 'multiple-value-prog1)))
1214
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))
1218   (if reduce-function
1219       (funcall reduce-function
1220                (funcall map-function form 'progn)
1221                (reduce reduce-function
1222                        (mapcar #'(lambda (subform)
1223                                    (walk map-function
1224                                          reduce-function
1225                                          screamer?
1226                                          partial?
1227                                          nested?
1228                                          subform
1229                                          environment))
1230                                (rest form))))
1231       (funcall map-function form 'progn)))
1232
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))
1238   (if reduce-function
1239       (funcall reduce-function
1240                (funcall map-function form 'progv)
1241                (funcall reduce-function
1242                         (funcall reduce-function
1243                                  (walk map-function
1244                                        reduce-function
1245                                        screamer?
1246                                        partial?
1247                                        nested?
1248                                        (second form)
1249                                        environment)
1250                                  (walk map-function
1251                                        reduce-function
1252                                        screamer?
1253                                        partial?
1254                                        nested?
1255                                        (third form)
1256                                        environment))
1257                         (reduce reduce-function
1258                                 (mapcar #'(lambda (subform)
1259                                             (walk map-function
1260                                                   reduce-function
1261                                                   screamer?
1262                                                   partial?
1263                                                   nested?
1264                                                   subform
1265                                                   environment))
1266                                         (rest (rest (rest form)))))))
1267       (funcall map-function form 'progv)))
1268
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))
1274
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))
1282   (if reduce-function
1283       (funcall reduce-function
1284                (funcall map-function form 'return-from)
1285                (walk map-function
1286                      reduce-function
1287                      screamer?
1288                      partial?
1289                      nested?
1290                      (if (= (length form) 3) (third form) nil)
1291                      environment))
1292       (funcall map-function form 'return-from)))
1293
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))
1301   (if reduce-function
1302       (funcall reduce-function
1303                (funcall map-function form 'setq)
1304                (reduce reduce-function
1305                        (mapcar #'(lambda (subform)
1306                                    (walk map-function
1307                                          reduce-function
1308                                          screamer?
1309                                          partial?
1310                                          nested?
1311                                          subform
1312                                          environment))
1313                                (every-other (rest (rest form))))))
1314       (funcall map-function form 'setq)))
1315
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)))
1321                  (rest form))
1322     (error "A subforms of a TAGBODY must be symbols, integers or lists: ~S"
1323            form))
1324   (let ((tags (remove-if #'consp (rest form))))
1325     (unless (= (length tags) (length (remove-duplicates tags)))
1326       (error "TAGBODY has duplicate TAGs: ~S" form)))
1327   (if reduce-function
1328       (funcall reduce-function
1329                (funcall map-function form 'tagbody)
1330                (reduce reduce-function
1331                        (mapcar #'(lambda (subform)
1332                                    (walk map-function
1333                                          reduce-function
1334                                          screamer?
1335                                          partial?
1336                                          nested?
1337                                          subform
1338                                          environment))
1339                                (remove-if-not #'consp (rest form)))))
1340       (funcall map-function form 'tagbody)))
1341
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))
1346   (if reduce-function
1347       (funcall reduce-function
1348                (walk map-function
1349                      reduce-function
1350                      screamer?
1351                      partial?
1352                      nested?
1353                      (third form)
1354                      environment)
1355                (funcall map-function form 'the))
1356       (funcall map-function form 'the)))
1357
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))
1363   (if reduce-function
1364       (funcall reduce-function
1365                (funcall map-function form 'throw)
1366                (funcall reduce-function
1367                         (walk map-function
1368                               reduce-function
1369                               screamer?
1370                               partial?
1371                               nested?
1372                               (second form)
1373                               environment)
1374                         (walk map-function
1375                               reduce-function
1376                               screamer?
1377                               partial?
1378                               nested?
1379                               (third form)
1380                               environment)))
1381       (funcall map-function form 'throw)))
1382
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"
1388            form))
1389   (if reduce-function
1390       (funcall
1391        reduce-function
1392        (funcall map-function form 'unwind-protect)
1393        (funcall reduce-function
1394                 (walk map-function
1395                       reduce-function
1396                       screamer?
1397                       partial?
1398                       nested?
1399                       (second form)
1400                       environment)
1401                 (reduce reduce-function
1402                         (mapcar #'(lambda (subform)
1403                                     (walk map-function
1404                                           reduce-function
1405                                           screamer?
1406                                           partial?
1407                                           nested?
1408                                           subform
1409                                           environment))
1410                                 (rest (rest form))))))
1411       (funcall map-function form 'unwind-protect)))
1412
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)
1432                                    (walk map-function
1433                                          reduce-function
1434                                          screamer?
1435                                          partial?
1436                                          nested?
1437                                          subform
1438                                          environment))
1439                                (rest form))))
1440       (funcall map-function form 'for-effects)))
1441
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))
1447   (if *local?*
1448       (if reduce-function
1449           (funcall reduce-function
1450                    (funcall map-function form 'local-setf)
1451                    (reduce reduce-function
1452                            (mapcar #'(lambda (subform)
1453                                        (walk map-function
1454                                              reduce-function
1455                                              screamer?
1456                                              partial?
1457                                              nested?
1458                                              subform
1459                                              environment))
1460                                    (every-other (rest (rest form))))))
1461           (funcall map-function form 'local-setf))
1462       (walk map-function
1463             reduce-function
1464             screamer?
1465             partial?
1466             nested?
1467             (let ((*macroexpand-hook* #'funcall))
1468               (macroexpand-1 form environment))
1469             environment)))
1470
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"
1478            form))
1479   (if reduce-function
1480       (funcall reduce-function
1481                (funcall map-function form 'multiple-value-call-nondeterministic)
1482                (reduce reduce-function
1483                        (mapcar #'(lambda (subform)
1484                                    (walk map-function
1485                                          reduce-function
1486                                          screamer?
1487                                          partial?
1488                                          nested?
1489                                          subform
1490                                          environment))
1491                                (rest form))))
1492       (funcall map-function form 'multiple-value-call-nondeterministic)))
1493
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))
1499
1500 (defun-compile-time walk-macro-call
1501     (map-function reduce-function screamer? partial? nested? form environment)
1502   (if reduce-function
1503       (funcall reduce-function
1504                (funcall map-function form 'macro-call)
1505                (walk map-function
1506                      reduce-function
1507                      screamer?
1508                      partial?
1509                      nested?
1510                      (let ((*macroexpand-hook* #'funcall))
1511                        (macroexpand-1 form environment))
1512                      environment))
1513       (walk map-function
1514             reduce-function
1515             screamer?
1516             partial?
1517             nested?
1518             (let ((*macroexpand-hook* #'funcall))
1519               (macroexpand-1 form environment))
1520             environment)))
1521
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))
1526   (cond
1527     ((lambda-expression? (first form))
1528      (if reduce-function
1529          (funcall
1530           reduce-function
1531           (funcall map-function form 'lambda-call)
1532           (funcall
1533            reduce-function
1534            (reduce reduce-function
1535                    (mapcar #'(lambda (subform)
1536                                (walk map-function
1537                                      reduce-function
1538                                      screamer?
1539                                      partial?
1540                                      nested?
1541                                      subform
1542                                      environment))
1543                            (rest form)))
1544            (funcall
1545             reduce-function
1546             (walk-lambda-list map-function
1547                               reduce-function
1548                               screamer?
1549                               partial?
1550                               nested?
1551                               (second (first form))
1552                               environment)
1553             (reduce reduce-function
1554                     (mapcar #'(lambda (subform)
1555                                 (walk map-function
1556                                       reduce-function
1557                                       screamer?
1558                                       partial?
1559                                       nested?
1560                                       subform
1561                                       environment))
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))
1567          (if reduce-function
1568              (funcall reduce-function
1569                       (funcall map-function form 'symbol-call)
1570                       (reduce reduce-function
1571                               (mapcar #'(lambda (subform)
1572                                           (walk map-function
1573                                                 reduce-function
1574                                                 screamer?
1575                                                 partial?
1576                                                 nested?
1577                                                 subform
1578                                                 environment))
1579                                       (rest form))))
1580              (funcall map-function form 'symbol-call))
1581          (if reduce-function
1582              (funcall reduce-function
1583                       (funcall map-function form 'setf-call)
1584                       (reduce reduce-function
1585                               (mapcar #'(lambda (subform)
1586                                           (walk map-function
1587                                                 reduce-function
1588                                                 screamer?
1589                                                 partial?
1590                                                 nested?
1591                                                 subform
1592                                                 environment))
1593                                       (rest form))))
1594              (funcall map-function form 'setf-call))))
1595     (t (error "CAR of form ~S is not a valid function" form))))
1596
1597 ;;; Possible FORM-TYPEs
1598 ;;;  Other:
1599 ;;;   LAMBDA-LIST VARIABLE
1600 ;;;  Special forms:
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:
1609 ;;;   FULL
1610 ;;;  Other:
1611 ;;;   MACRO-CALL LAMBDA-CALL SYMBOL-CALL SETF-CALL
1612
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
1616   ;;             CLtL2.
1617   (cond
1618     ((self-evaluating? form) (funcall map-function form 'quote))
1619     ((symbolp form) (funcall map-function form 'variable))
1620     ((eq (first form) 'block)
1621      (walk-block
1622       map-function reduce-function screamer? partial? nested? form environment))
1623     ((eq (first form) 'catch)
1624      (walk-catch
1625       map-function reduce-function screamer? partial? nested? form environment))
1626     ((eq (first form) 'eval-when)
1627      (walk-eval-when
1628       map-function reduce-function screamer? partial? nested? form environment))
1629     ((eq (first form) 'flet)
1630      (walk-flet/labels
1631       map-function reduce-function screamer? partial? nested? form environment
1632       'flet))
1633     ((eq (first form) 'function)
1634      (walk-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
1639               environment))
1640     ((eq (first form) 'labels)
1641      (walk-flet/labels
1642       map-function reduce-function screamer? partial? nested? form environment
1643       'labels))
1644     ((eq (first form) 'let)
1645      (walk-let/let*
1646       map-function reduce-function screamer? partial? nested? form environment
1647       'let))
1648     ((eq (first form) 'let*)
1649      (walk-let/let*
1650       map-function reduce-function screamer? partial? nested? form environment
1651       'let*))
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)
1655            environment))
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)
1663      (walk-progn
1664       map-function reduce-function screamer? partial? nested? form environment))
1665     ((eq (first form) 'progv)
1666      (walk-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)
1670      (walk-return-from
1671       map-function reduce-function screamer? partial? nested? form environment))
1672     ((eq (first form) 'setq)
1673      (walk-setq
1674       map-function reduce-function screamer? partial? nested? form environment))
1675     ((eq (first form) 'tagbody)
1676      (walk-tagbody
1677       map-function reduce-function screamer? partial? nested? form environment))
1678     ((eq (first form) 'the)
1679      (walk-the
1680       map-function reduce-function screamer? partial? nested? form environment))
1681     ((eq (first form) 'throw)
1682      (walk-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))
1688      (walk-for-effects
1689       map-function reduce-function screamer? partial? nested? form environment))
1690     ((and screamer? (eq (first form) 'setf))
1691      (walk-setf
1692       map-function reduce-function screamer? partial? nested? form environment))
1693     ((and screamer? (eq (first form) 'local))
1694      (let ((*local?* t))
1695        (walk-progn
1696         map-function reduce-function screamer? partial? nested? form
1697         environment)))
1698     ((and screamer? (eq (first form) 'global))
1699      (let ((*local?* nil))
1700        (walk-progn
1701         map-function reduce-function screamer? partial? nested? form
1702         environment)))
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))
1709      (walk-macro-call
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
1715         environment))))
1716
1717 (defun-compile-time process-subforms (function form form-type environment)
1718   (case form-type
1719     (lambda-list (error "This shouldn't happen"))
1720     ((variable go) form)
1721     ((eval-when)
1722      (cons (first form)
1723            (cons (second form)
1724                  (mapcar #'(lambda (subform)
1725                              (funcall function subform environment))
1726                          (rest (rest form))))))
1727     ((flet labels)
1728      `(,(first form)
1729         ,(mapcar
1730           #'(lambda (binding)
1731               (cl:multiple-value-bind (body declarations documentation-string)
1732                   (peal-off-documentation-string-and-declarations
1733                    (rest (rest binding)) t)
1734                 `(,(first binding)
1735                    ;; needs work: To process subforms of lambda list.
1736                    ,(second binding)
1737                    ,@(if documentation-string (list documentation-string))
1738                    ,@declarations
1739                    ,@(mapcar
1740                       #'(lambda (subform) (funcall function subform environment))
1741                       body))))
1742           (second form))
1743         ,@(mapcar
1744            #'(lambda (subform) (funcall function subform environment))
1745            (rest (rest form)))))
1746     ((let let*)
1747      (cl:multiple-value-bind (body declarations)
1748          (peal-off-documentation-string-and-declarations (rest (rest form)))
1749        `(,(first form)
1750           ,(mapcar
1751             #'(lambda (binding)
1752                 (if (and (consp binding) (= (length binding) 2))
1753                     `(,(first binding)
1754                        ,(funcall function (second binding) environment))
1755                     binding))
1756             (second form))
1757           ,@declarations
1758           ,@(mapcar
1759              #'(lambda (subform) (funcall function subform environment)) body))))
1760     (progn
1761       `(progn ,@(mapcar
1762                  #'(lambda (subform) (funcall function subform environment))
1763                  (rest form))))
1764     (quote (quotify form))
1765     (the `(the ,(second form) ,(funcall function (third form) environment)))
1766     (macro-call (error "This shouldn't happen"))
1767     (lambda-call
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))
1774            ,@declarations
1775            ,@(mapcar #'(lambda (subform) (funcall function subform environment))
1776                      body))
1777          ,@(mapcar
1778             #'(lambda (subform) (funcall function subform environment))
1779             (rest form)))))
1780     (otherwise
1781      (cons (first form)
1782            (mapcar #'(lambda (subform) (funcall function subform environment))
1783                    (rest form))))))
1784
1785 (defun-compile-time deterministic? (form environment)
1786   (walk
1787    #'(lambda (form form-type)
1788        (case 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
1793          (otherwise t)))
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))
1797    t
1798    nil
1799    nil
1800    form
1801    environment))
1802
1803 (defun-compile-time deterministic-lambda-list? (lambda-list environment)
1804   (walk-lambda-list
1805    #'(lambda (form form-type)
1806        (case 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
1811          (otherwise t)))
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))
1815    t
1816    nil
1817    nil
1818    lambda-list
1819    environment))
1820
1821 (defun-compile-time needs-substitution? (form environment)
1822   (walk
1823    #'(lambda (form form-type)
1824        (case form-type
1825          (function-lambda
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))))
1838          (setq *local?*)
1839          (local-setf t)
1840          (otherwise nil)))
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) '()))
1844    t
1845    nil
1846    t
1847    form
1848    environment))
1849
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) '()))
1858         t
1859         nil
1860         nil
1861         form
1862         environment))
1863
1864 (defun-compile-time form-callees (form environment)
1865   (walk #'(lambda (form form-type)
1866             (case form-type
1867               ((function-symbol function-setf) (list (second form)))
1868               ((symbol-call setf-call) (list (first form)))
1869               (otherwise '())))
1870         #'(lambda (&optional (x nil x?) y)
1871             (if x? (union x y :test #'equal) '()))
1872         t
1873         nil
1874         t
1875         form
1876         environment))
1877
1878 (defun-compile-time callees (function-name)
1879   (function-record-callees (get-function-record function-name)))
1880
1881 (defun-compile-time indirect-callees-internal (function-names callees)
1882   (if (null function-names)
1883       callees
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)))))))
1891
1892 (defun-compile-time indirect-callees (function-name)
1893   (indirect-callees-internal (callees function-name) '()))
1894
1895 (defun-compile-time callers (function-name)
1896   (let ((callers '())
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)))
1905     callers))
1906
1907 (defun-compile-time indirect-callers-internal (function-names callers)
1908   (if (null function-names)
1909       callers
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)))))))
1917
1918 (defun-compile-time indirect-callers (function-name)
1919   (indirect-callers-internal (callers function-name) '()))
1920
1921 (defun-compile-time expand-local-setf (pairs environment)
1922   (if (null pairs)
1923       '(progn)
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))
1930                     (,d ,access-form))
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))))))))
1936
1937 (defun-compile-time expand-local-setq (pairs environment)
1938   (if (null pairs)
1939       '(progn)
1940       (let ((d (gensym "DUMMY-")))
1941         `(let ((,d ,(first pairs)))
1942            (trail #'(lambda () (setq ,(first pairs) ,d)))
1943            ,@(if (null (rest (rest pairs)))
1944                  (list `(setq
1945                          ,(first pairs)
1946                          ,(perform-substitutions (second pairs) environment)))
1947                  (list `(setq
1948                          ,(first pairs)
1949                          ,(perform-substitutions (second pairs) environment))
1950                        (expand-local-setq (rest (rest pairs)) environment)))))))
1951
1952 (defun-compile-time perform-substitutions (form environment)
1953   (if (needs-substitution? form environment)
1954       (walk
1955        #'(lambda (form form-type)
1956            (case 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*)))
1961                       (process-subforms
1962                        #'perform-substitutions form form-type environment)))
1963              (function-lambda
1964               (unless (deterministic-lambda-list?
1965                        (second (second form)) environment)
1966                 (screamer-error
1967                  "Cannot (currently) handle a LAMDBA expression with~%~
1968               nondeterministic initializations forms for~%~
1969               &OPTIONAL and &AUX parameters: ~S"
1970                  form))
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))
1975                            body)
1976                     ;; needs work: To process subforms of lambda list.
1977                     `#'(lambda ,(second (second form))
1978                          ,@(if documentation-string (list documentation-string))
1979                          ,@declarations
1980                          ,@(mapcar
1981                             #'(lambda (subform)
1982                                 (perform-substitutions subform environment))
1983                             body))
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
1989                         :function
1990                         ;; needs work: To process subforms of lambda list.
1991                         #'(lambda (,continuation ,@(second (second form)))
1992                             ,@(if documentation-string (list documentation-string))
1993                             ,@declarations
1994                             ,continuation ;ignore
1995                             ,(cps-convert-progn body
1996                                                 continuation
1997                                                 '()
1998                                                 t
1999                                                 environment)))))))
2000              ((function-symbol function-setf)
2001               (if (function-record-deterministic?
2002                    (get-function-record (second form)))
2003                   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"))
2014              (return-from
2015               (let ((tag (assoc (second form) *block-tags* :test #'eq))
2016                     (value (perform-substitutions
2017                             (if (= (length form) 3) (third form) nil)
2018                             environment)))
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))))
2025              (setq (if *local?*
2026                        (expand-local-setq (rest form) environment)
2027                        (process-subforms
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)))
2032                                      *tagbody-tags*)))
2033                         (process-subforms
2034                          #'perform-substitutions form form-type environment)))
2035              (for-effects (perform-substitutions
2036                            (let ((*macroexpand-hook* #'funcall))
2037                              (macroexpand-1 form environment))
2038                            environment))
2039              (local-setf (perform-substitutions
2040                           (expand-local-setf (rest form) environment)
2041                           environment))
2042              (macro-call (error "This shouldn't happen"))
2043              (otherwise (process-subforms
2044                          #'perform-substitutions form form-type environment))))
2045        nil
2046        t
2047        nil
2048        nil
2049        form
2050        environment)
2051       form))
2052
2053 (defun-compile-time is-magic-declaration? (form)
2054   (and (consp form)
2055        (eq (first form) 'declare)
2056        (consp (rest form))
2057        (consp (second form))
2058        (eq (first (second form)) 'magic)))
2059
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)))))
2070
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)))))
2076
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)"))
2087   (cond
2088     ((symbolp continuation)
2089      (if value?
2090          (if (null types)
2091              (if (consp form)
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
2097              ;;       types.
2098              `(funcall ,continuation (the (and ,@types) ,form)))
2099          `(progn ,form (funcall ,continuation))))
2100     ((symbolp (second continuation))
2101      (if value?
2102          (if (null types)
2103              (if (consp form)
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
2109              ;;       types.
2110              `(,(second continuation) (the (and ,@types) ,form)))
2111          `(progn ,form (,(second continuation)))))
2112     (t (if value?
2113            (progn
2114              (if (null (second (second continuation)))
2115                  (error "Please report this bug; This shouldn't happen (B)"))
2116              (cond
2117                ((eq (first (second (second continuation))) '&rest)
2118                 (if (null types)
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)
2128                          (not
2129                           (and (eq (first form) 'function)
2130                                (null (rest (last form)))
2131                                (= (length form) 2)
2132                                (symbolp (second form)))))
2133                     (and (symbolp form) (symbol-package form))
2134                     (symbol-package (magic-continuation-argument continuation)))
2135                 (if (null types)
2136                     `(let ((,(magic-continuation-argument continuation) ,form))
2137                        ,@(if (and *dynamic-extent?* (is-magic-continuation? form))
2138                              `((declare
2139                                 (dynamic-extent
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)))
2145                        (declare
2146                         (type (and ,@types)
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
2155                (t (if (null types)
2156                       (subst form
2157                              (magic-continuation-argument continuation)
2158                              ;; Peal off LAMBDA, arguments, and DECLARE.
2159                              `(progn ,@(rest (rest (rest (second continuation)))))
2160                              :test #'eq)
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)))))
2165                              :test #'eq)))))
2166            (progn
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))))))))))
2171
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
2184     ;;       didn't.
2185     `#'(lambda (&rest ,dummy-argument)
2186          (declare (magic)
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)))))))))
2192
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))))))
2200
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
2206      `#'(lambda (,c)
2207           (declare (magic))
2208           ,(cps-convert-progn body c types value? environment))
2209      '()
2210      continuation
2211      t)))
2212
2213 (defun-compile-time cps-convert-if (antecedent
2214                                     consequent
2215                                     alternate
2216                                     continuation
2217                                     types
2218                                     value?
2219                                     environment)
2220   (let ((c (gensym "CONTINUATION-"))
2221         (dummy-argument (gensym "DUMMY-"))
2222         (other-arguments (gensym "OTHER-")))
2223     (possibly-beta-reduce-funcall
2224      `#'(lambda (,c)
2225           (declare (magic))
2226           ,(cps-convert
2227             antecedent
2228             `#'(lambda (&optional ,dummy-argument &rest ,other-arguments)
2229                  (declare (magic)
2230                           (ignore ,other-arguments))
2231                  (if ,dummy-argument
2232                      ,(cps-convert consequent c types value? environment)
2233                      ,(cps-convert alternate c types value? environment)))
2234             '()
2235             t
2236             environment))
2237      '()
2238      continuation
2239      t)))
2240
2241 (defun-compile-time cps-convert-let (bindings
2242                                      body
2243                                      declarations
2244                                      continuation
2245                                      types
2246                                      value?
2247                                      environment
2248                                      &optional
2249                                      new-bindings)
2250   (if (null bindings)
2251       `(let ,new-bindings
2252          ,@declarations
2253          ,(cps-convert-progn body continuation types value? environment))
2254       (let* ((binding (first bindings))
2255              (binding-variable
2256               (if (symbolp binding) binding (first binding)))
2257              (binding-form
2258               (if (and (consp binding) (= (length binding) 2))
2259                   (second binding)
2260                   nil))
2261              (dummy-argument (gensym "DUMMY-"))
2262              (other-arguments (gensym "OTHER-")))
2263         (cps-convert
2264          binding-form
2265          `#'(lambda (&optional ,dummy-argument &rest ,other-arguments)
2266               (declare (magic)
2267                        (ignore ,other-arguments))
2268               ,(cps-convert-let (rest bindings)
2269                                 body
2270                                 declarations
2271                                 continuation
2272                                 types
2273                                 value?
2274                                 environment
2275                                 (cons (list binding-variable dummy-argument)
2276                                       new-bindings)))
2277          '()
2278          t
2279          environment))))
2280
2281 (defun-compile-time cps-convert-let* (bindings
2282                                       body
2283                                       declarations
2284                                       continuation
2285                                       types
2286                                       value?
2287                                       environment)
2288   (if (null bindings)
2289       (if (null declarations)
2290           (cps-convert-progn body continuation types value? environment)
2291           `(let ()
2292              ,@declarations
2293              ,(cps-convert-progn body continuation types value? environment)))
2294       (let* ((binding (first bindings))
2295              (binding-variable
2296               (if (symbolp binding) binding (first binding)))
2297              (binding-form
2298               (if (and (consp binding) (= (length binding) 2))
2299                   (second binding)
2300                   nil))
2301              (other-arguments (gensym "OTHER-")))
2302         (cps-convert
2303          binding-form
2304          `#'(lambda (&optional ,binding-variable &rest ,other-arguments)
2305               (declare (magic)
2306                        (ignore ,other-arguments))
2307               ,(cps-convert-let* (rest bindings)
2308                                  body
2309                                  declarations
2310                                  continuation
2311                                  types
2312                                  value?
2313                                  environment))
2314          '()
2315          t
2316          environment))))
2317
2318 (defun-compile-time cps-convert-multiple-value-call-internal
2319     (nondeterministic? function forms continuation types value? environment
2320                        &optional arguments)
2321   (if (null forms)
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))
2326             ,function
2327             (append ,@(reverse arguments)))
2328           (possibly-beta-reduce-funcall
2329            continuation
2330            types
2331            `(apply ,function (append ,@(reverse arguments)))
2332            value?))
2333       (let ((dummy-argument (gensym "DUMMY-")))
2334         (cps-convert
2335          (first forms)
2336          `#'(lambda (&rest ,dummy-argument)
2337               (declare (magic))
2338               ,(cps-convert-multiple-value-call-internal
2339                 nondeterministic? function (rest forms) continuation types value?
2340                 environment (cons dummy-argument arguments)))
2341          nil
2342          t
2343          environment))))
2344
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-")))
2349     (cps-convert
2350      function
2351      `#'(lambda (&optional ,dummy-argument &rest ,other-arguments)
2352           (declare (magic)
2353                    (ignore ,other-arguments))
2354           ,(cps-convert-multiple-value-call-internal
2355             nondeterministic? dummy-argument forms continuation types value?
2356             environment))
2357      nil
2358      t
2359      environment)))
2360
2361 (defun-compile-time cps-convert-multiple-value-prog1
2362     (form forms continuation types value? environment)
2363   (if value?
2364       (let ((dummy-argument (gensym "DUMMY-")))
2365         (cps-convert
2366          form
2367          `#'(lambda (&rest ,dummy-argument)
2368               (declare (magic))
2369               ,(cps-convert-progn
2370                 forms
2371                 `#'(lambda ()
2372                      (declare (magic))
2373                      (possibly-beta-reduce-funcall
2374                       continuation types `(values-list ,dummy-argument) t))
2375                 nil
2376                 nil
2377                 environment))
2378          types
2379          t
2380          environment))
2381       (cps-convert-progn (cons form forms) continuation types nil environment)))
2382
2383 (defun-compile-time cps-convert-progn
2384     (body continuation types value? environment)
2385   (cond
2386     ((null body) (possibly-beta-reduce-funcall continuation types nil value?))
2387     ((null (rest body))
2388      (cps-convert (first body) continuation types value? environment))
2389     (t (cps-convert
2390         (first body)
2391         `#'(lambda ()
2392              (declare (magic))
2393              ,(cps-convert-progn
2394                (rest body) continuation types value? environment))
2395         '()
2396         nil
2397         environment))))
2398
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
2409         ;;       FOR-EFFECTS.
2410         (let ((dummy-argument (gensym "DUMMY-")))
2411           (cps-convert
2412            result
2413            `#'(lambda (&rest ,dummy-argument)
2414                 (declare (magic))
2415                 (return-from ,name (values-list ,dummy-argument)))
2416            '()
2417            t
2418            environment)))))
2419
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-")))
2426         (cps-convert
2427          (second arguments)
2428          `#'(lambda (&optional ,dummy-argument &rest ,other-arguments)
2429               (declare (magic)
2430                        (ignore ,other-arguments)
2431                        ,@(if (and (null (rest (rest arguments)))
2432                                   (not (null types)))
2433                              `((type (and ,@types) ,dummy-argument))))
2434               ,(if (null (rest (rest arguments)))
2435                    (possibly-beta-reduce-funcall
2436                     continuation
2437                     types
2438                     `(setq ,(first arguments) ,dummy-argument)
2439                     value?)
2440                    `(progn (setq ,(first arguments) ,dummy-argument)
2441                            ,(cps-convert-setq
2442                              (rest (rest arguments))
2443                              continuation
2444                              types
2445                              value?
2446                              environment))))
2447          (if (null (rest (rest arguments))) types '())
2448          t
2449          environment))))
2450
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!
2455     (dolist (form body)
2456       (if (consp form)
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
2467       ;;             CommonLisp.
2468       `(labels ,(mapcar
2469                  #'(lambda (segment)
2470                      (let ((next (rest (member segment segments :test #'eq))))
2471                        `(,(first segment)
2472                           (&optional ,dummy-argument &rest ,other-arguments)
2473                           (declare (ignore ,dummy-argument ,other-arguments))
2474                           ,(cps-convert-progn
2475                             (reverse (rest segment))
2476                             (if next `#',(first (first next)) continuation)
2477                             (if next '() types)
2478                             (or next value?)
2479                             environment))))
2480                  (rest segments))
2481          ,(let ((next (rest segments)))
2482                (cps-convert-progn
2483                 (reverse (rest (first segments)))
2484                 (if next `#',(first (first next)) continuation)
2485                 (if next '() types)
2486                 (or next value?)
2487                 environment))))))
2488
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)
2498           (cps-convert
2499            (second arguments)
2500            `#'(lambda (&optional ,dummy-argument &rest ,other-arguments)
2501                 (declare (magic)
2502                          (ignore ,other-arguments)
2503                          ,@(if (and (null (rest (rest arguments)))
2504                                     (not (null types)))
2505                                `((type (and ,@types) ,dummy-argument))))
2506                 (let* (,@(mapcar #'list vars vals) (,d ,access-form))
2507                   (unwind-protect
2508                        ,(if (null (rest (rest arguments)))
2509                             (possibly-beta-reduce-funcall
2510                              continuation
2511                              types
2512                              (subst dummy-argument (first stores) store-form)
2513                              value?)
2514                             `(progn ,(subst
2515                                       dummy-argument
2516                                       (first stores)
2517                                       store-form)
2518                                     ,(cps-convert-local-setf/setq
2519                                       (rest (rest arguments))
2520                                       continuation
2521                                       types
2522                                       value?
2523                                       environment)))
2524                     ,(subst d (first stores) store-form))))
2525            (if (null (rest (rest arguments))) types '())
2526            t
2527            environment)))))
2528
2529 (defun-compile-time cps-convert-call (function-name
2530                                       arguments
2531                                       continuation
2532                                       types
2533                                       value?
2534                                       environment
2535                                       &optional
2536                                       dummy-arguments)
2537   ;; needs work: TYPES is never actually used here.
2538   (if (null arguments)
2539       (let ((c (gensym "CONTINUATION-")))
2540         (possibly-beta-reduce-funcall
2541          `#'(lambda (,c)
2542               (declare (magic))
2543               (,(cps-convert-function-name function-name)
2544                 ,c
2545                 ,@(reverse dummy-arguments)))
2546          '()
2547          (if value? continuation (void-continuation continuation))
2548          t))
2549       (let ((dummy-argument (gensym "DUMMY-"))
2550             (other-arguments (gensym "OTHER-")))
2551         (cps-convert
2552          (first arguments)
2553          `#'(lambda (&optional ,dummy-argument &rest ,other-arguments)
2554               (declare (magic)
2555                        (ignore ,other-arguments))
2556               ,(cps-convert-call
2557                 function-name
2558                 (rest arguments)
2559                 continuation
2560                 types
2561                 value?
2562                 environment
2563                 (cons dummy-argument dummy-arguments)))
2564          '()
2565          t
2566          environment))))
2567
2568 (defun-compile-time cps-non-convert-call (function-name
2569                                           arguments
2570                                           continuation
2571                                           types
2572                                           value?
2573                                           environment
2574                                           &optional
2575                                           dummy-arguments)
2576   (if (null arguments)
2577       (possibly-beta-reduce-funcall
2578        continuation
2579        types
2580        (if (not (null types))
2581            `(the (and ,@types) (,function-name ,@(reverse dummy-arguments)))
2582            `(,function-name ,@(reverse dummy-arguments)))
2583        value?)
2584       (let ((dummy-argument (gensym "DUMMY-"))
2585             (other-arguments (gensym "OTHER-")))
2586         (cps-convert
2587          (first arguments)
2588          `#'(lambda (&optional ,dummy-argument &rest ,other-arguments)
2589               (declare (magic)
2590                        (ignore ,other-arguments))
2591               ,(cps-non-convert-call
2592                 function-name
2593                 (rest arguments)
2594                 continuation
2595                 types
2596                 value?
2597                 environment
2598                 (cons dummy-argument dummy-arguments)))
2599          '()
2600          t
2601          environment))))
2602
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
2609                  continuation
2610                  types
2611                  (perform-substitutions form environment)
2612                  value?)
2613                 (case form-type
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)
2618                                             (rest (rest form))
2619                                             continuation
2620                                             types
2621                                             value?
2622                                             environment))
2623                   ((function-lambda function-symbol function-setf)
2624                    (possibly-beta-reduce-funcall
2625                     continuation
2626                     types
2627                     (perform-substitutions form environment)
2628                     value?))
2629                   (go (error "This shouldn't happen"))
2630                   (if (cps-convert-if (second form)
2631                                       (third form)
2632                                       (if (null (rest (rest (rest form))))
2633                                           nil
2634                                           (fourth form))
2635                                       continuation
2636                                       types
2637                                       value?
2638                                       environment))
2639                   (let (cl:multiple-value-bind (body declarations)
2640                            (peal-off-documentation-string-and-declarations
2641                             (rest (rest form)))
2642                          (cps-convert-let
2643                           (second form)
2644                           body
2645                           declarations
2646                           continuation
2647                           types
2648                           value?
2649                           environment)))
2650                   (let* (cl:multiple-value-bind (body declarations)
2651                             (peal-off-documentation-string-and-declarations
2652                              (rest (rest form)))
2653                           (cps-convert-let*
2654                            (second form)
2655                            body
2656                            declarations
2657                            continuation
2658                            types
2659                            value?
2660                            environment)))
2661                   (multiple-value-call
2662                       (cps-convert-multiple-value-call
2663                        nil
2664                        (second form)
2665                        (rest (rest form))
2666                        continuation
2667                        types
2668                        value?
2669                        environment))
2670                   (multiple-value-prog1
2671                       (cps-convert-multiple-value-prog1
2672                        (second form)
2673                        (rest (rest form))
2674                        continuation
2675                        types
2676                        value?
2677                        environment))
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
2683                                 (second form)
2684                                 (if (= (length form) 2) nil (third form))
2685                                 environment))
2686                   (setq (if *local?*
2687                             (cps-convert-local-setf/setq
2688                              (rest form) continuation types value? environment)
2689                             (cps-convert-setq
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)
2694                                     continuation
2695                                     (cons (second form) types)
2696                                     value?
2697                                     environment))
2698                   (for-effects (possibly-beta-reduce-funcall
2699                                 continuation types form value?))
2700                   (local-setf
2701                    (cps-convert-local-setf/setq
2702                     (rest form) continuation types value? environment))
2703                   (multiple-value-call-nondeterministic
2704                    (cps-convert-multiple-value-call
2705                     t
2706                     (second form)
2707                     (rest (rest form))
2708                     continuation
2709                     types
2710                     value?
2711                     environment))
2712                   (macro-call (error "This shouldn't happen"))
2713                   (lambda-call
2714                    (unless (deterministic-lambda-list?
2715                             (second (first form)) environment)
2716                      (screamer-error
2717                       "Cannot (currently) handle a LAMDBA expression with~%~
2718                    nondeterministic initializations forms for~%~
2719                    &OPTIONAL and &AUX parameters: ~S"
2720                       form))
2721                    (unless (every
2722                             #'(lambda (argument)
2723                                 (and (symbolp argument)
2724                                      (not (member argument lambda-list-keywords
2725                                                   :test #'eq))))
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~%~
2730                          symbols: ~S"
2731                             form))
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"
2737                             form))
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.
2743                      (cps-convert-let
2744                       (mapcar #'list (second (first form)) (rest form))
2745                       body
2746                       declarations
2747                       continuation
2748                       types
2749                       value?
2750                       environment)))
2751                   ((symbol-call setf-call)
2752                    (if (function-record-deterministic?
2753                         (get-function-record (first form)))
2754                        (cps-non-convert-call (first form)
2755                                              (rest form)
2756                                              continuation
2757                                              types
2758                                              value?
2759                                              environment)
2760                        (cps-convert-call (first form)
2761                                          (rest form)
2762                                          continuation
2763                                          types
2764                                          value?
2765                                          environment)))
2766                   (otherwise
2767                    (screamer-error
2768                     "Cannot (currently) handle the special form ~S inside a~%~
2769                   nondeterministic context."
2770                     (first form))))))
2771         nil
2772         t
2773         nil
2774         nil
2775         form
2776         environment))
2777
2778 (defun-compile-time declare-deterministic (function-name)
2779   (setf (function-record-deterministic? (get-function-record function-name)) t))
2780
2781 (defun-compile-time declare-nondeterministic (function-name)
2782   (setf (function-record-deterministic? (get-function-record function-name))
2783         nil))
2784
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.
2788   (reduce
2789    #'union
2790    (mapcar #'(lambda (form) (form-callees form environment))
2791            (peal-off-documentation-string-and-declarations body t))
2792    :initial-value '()))
2793
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)))
2799
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)))))
2809
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))))
2818
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))
2831                      ,@declarations
2832                      ,@(mapcar #'(lambda (form)
2833                                    (perform-substitutions form environment))
2834                                body))
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))
2841                      ,@declarations
2842                      (declare
2843                       (ignore
2844                        ,@(reduce
2845                           #'append
2846                           (mapcar
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)))
2853                                    (list argument)))
2854                            (set-difference
2855                             lambda-list
2856                             lambda-list-keywords
2857                             :test #'eq)))))
2858                      (screamer-error
2859                       "Function ~S is a nondeterministic function. As such, it~%~
2860                   must be called only from a nondeterministic context."
2861                       ',function-name))
2862                   `(cl:defun ,(cps-convert-function-name function-name)
2863                        (,continuation ,@lambda-list)
2864                      ,@(if documentation-string (list documentation-string))
2865                      ,@declarations
2866                      ,continuation      ;ignore
2867                      ,(cps-convert-progn body continuation '() t environment))
2868                   `(declare-nondeterministic ',function-name)))))))
2869
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?
2903                                               function-record))
2904                                         (not (function-record-old-deterministic?
2905                                               function-record))))))
2906                          (callees caller)))
2907               (setf definitions
2908                     (append (function-definition caller environment)
2909                             definitions)))))
2910       ;; note: This is so that macroexpand without compile doesn't get out of
2911       ;;       sync.
2912       (dolist (function-record function-records)
2913         (setf (function-record-deterministic? function-record)
2914               (function-record-old-deterministic? function-record)))
2915       definitions)))
2916
2917 ;;; The protocol
2918
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
2940         ;;       sync.
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)))))
2956
2957 (defmacro-compile-time either (&body expressions)
2958   "Nondeterministically evaluates and returns the value of one of its
2959 EXPRESSIONS. It sets up a choice point and evaluates the first
2960 EXPRESSION returning its result. Whenever backtracking proceeds to
2961 this choice point, the next EXPRESSION is evaluated and its result
2962 returned. When no more EXPRESSIONS remain, the current choice point is
2963 removed and backtracking continues to the next most recent choice
2964 point. As an optimization, the choice point created for this
2965 expression is removed before the evaluation of the last EXPRESSION so
2966 that a failure during the evaluation of the last expression will
2967 backtrack directly to the parent choice point of the EITHER
2968 expression. EITHER takes any number of arguments. With no arguments,
2969 \(EITHER) is equivalent to \(FAIL) and is thus deterministic. With one
2970 argument, \(EITHER EXPRESSION) is equivalent to expression itself and
2971 is thus deterministic only when EXPRESSION is deterministic. Either is
2972 a special form, not a function. It is an error for the expression
2973 #'EITHER to appear in a program. Thus \(FUNCALL #'EITHER ...) or
2974 \(APPLY #'EITHER ...) are in error and will yield unpredictable
2975 results. With two or more argument it is nondeterministic and can only
2976 appear in a nondeterministic context."
2977   ;; FIXME: ref to operators providing nondeterministic contexts
2978   (cond ((not expressions)
2979          '(fail))
2980         ((not (rest expressions))
2981          (first expressions))
2982         (t
2983          `(if (a-boolean)
2984               ,(first expressions)
2985               (either ,@(rest expressions))))))
2986
2987 (defmacro-compile-time local (&body expressions &environment environment)
2988   "Evaluates EXPRESSIONS in the same fashion as PROGN except that all
2989 SETF and SETQ expressions lexically nested in its body result in local
2990 side effects which are undone upon backtracking. Note that this
2991 affects only side effects introduced explicitly via SETF and SETQ.
2992 Side effects introduced by Common Lisp builtin in functions such as
2993 RPLACA are always global. Furthermore, it affects only occurrences of
2994 SETF and SETQ which appear textually nested in the body of the LOCAL
2995 expression -- not those appearing in functions called from the body.
2996 LOCAL and GLOBAL expressions may be nested inside one another. The
2997 nearest surrounding declaration determines whether or not a given SETF
2998 or SETQ results in a local or global side effect. Side effects default
2999 to be global when there is no surrounding LOCAL or GLOBAL expression.
3000 Local side effects can appear both in deterministic as well as
3001 nondeterministic contexts though different techniques are used to
3002 implement the trailing of prior values for restoration upon
3003 backtracking. In nondeterministic contexts, LOCAL as well as SETF are
3004 treated as special forms rather than macros. This should be completely
3005 transparent to the user."
3006   (let ((*local?* t))
3007     `(progn ,@(mapcar
3008                #'(lambda (form) (perform-substitutions form environment))
3009                expressions))))
3010
3011 (defmacro-compile-time global (&body expressions &environment environment)
3012   "Evaluates EXPRESSIONS in the same fashion as PROGN except that all
3013 SETF and SETQ expressions lexically nested in its body result in
3014 global side effects which are not undone upon backtracking. Note that
3015 this affects only side effects introduced explicitly via SETF and
3016 SETQ. Side effects introduced by Common Lisp builtin functions such as
3017 RPLACA are always global anyway. Furthermore, it affects only
3018 occurrences of SETF and SETQ which appear textually nested in the body
3019 of the GLOBAL expression -- not those appearing in functions called
3020 from the body. LOCAL and GLOBAL expressions may be nested inside one
3021 another. The nearest surrounding declaration determines whether or not
3022 a given SETF or SETQ results in a local or global side effect. Side
3023 effects default to be global when there is no surrounding LOCAL or
3024 GLOBAL expression. Global side effects can appear both in
3025 deterministic as well as nondeterministic contexts. In
3026 nondeterministic contexts, GLOBAL as well as SETF are treated as
3027 special forms rather than macros. This should be completely
3028 transparent to the user."
3029   (let ((*local?* nil))
3030     `(progn ,@(mapcar
3031                #'(lambda (form) (perform-substitutions form environment))
3032                expressions))))
3033
3034 (defmacro-compile-time for-effects (&body forms &environment environment)
3035   `(choice-point
3036     ,(let ((*nondeterministic-context?* t))
3037           (cps-convert-progn forms '#'fail nil nil environment))))
3038
3039 (defmacro-compile-time one-value (expression &optional (default-expression '(fail)))
3040   "Returns the first value of a nondeterministic expression.
3041 EXPRESSION is evaluated, deterministically returning only its first
3042 nondeterministic value, if any. No further execution of EXPRESSION is
3043 attempted after it successfully returns one value. If EXPRESSION does
3044 not return any nondeterministic values \(i.e. it fails) then
3045 DEFAULT-EXPRESSION is evaluated and its value returned instead.
3046 DEFAULT-EXPRESSION defaults to \(FAIL) if not present. Local side
3047 effects performed by EXPRESSION are undone when ONE-VALUE returns. On
3048 the other hand, local side effects performed by DEFAULT-EXPRESSION are
3049 not undone when ONE-VALUE returns. A ONE-VALUE expression can appear
3050 in both deterministic and nondeterministic contexts. Irrespective of
3051 what context the ONE-VALUE expression appears in, EXPRESSION is always
3052 in a nondeterministic context, while DEFAULT-EXPRESSION is in whatever
3053 context the ONE-VALUE expression appears. A ONE-VALUE expression is
3054 nondeterministic if DEFAULT-EXPRESSION is present and is
3055 nondeterministic, otherwise it is deterministic. If DEFAULT-EXPRESSION
3056 is present and nondeterministic, and if EXPRESSION fails, then it is
3057 possible to backtrack into the DEFAULT-EXPRESSION and for the
3058 ONE-VALUE expression to nondeterministically return multiple times.
3059 ONE-VALUE is analogous to the cut primitive \(!) in Prolog."
3060   `(block one-value
3061      (for-effects (return-from one-value ,expression))
3062      ,default-expression))
3063
3064 (defmacro-compile-time possibly? (&body forms)
3065   `(one-value (let ((value (progn ,@forms))) (unless value (fail)) value) nil))
3066
3067 (defmacro-compile-time necessarily? (&body forms)
3068   `(let ((result t))
3069      (one-value
3070       (let ((value (progn ,@forms)))
3071         (when value (setf result value) (fail))
3072         value)
3073       result)))
3074
3075 (defmacro-compile-time all-values (&body expressions)
3076   "Evaluates EXPRESSIONS \(wrapped in an implicit PROGN) and returns a
3077 list of all of the nondeterministic values returned by the last
3078 EXPRESSION. These values are produced by repeatedly evaluating the
3079 body and backtracking to produce the next value, until the body fails
3080 and yields no further values. Accordingly, local side effects
3081 performed by the body while producing each value are undone before
3082 attempting to produce subsequent values, and all local side effects
3083 performed by the body are undone upon exit from ALL-VALUES. Returns
3084 the list containing NIL if there are no EXPRESSIONS. An ALL-VALUES
3085 expression can appear in both deterministic and nondeterministic
3086 contexts. Irrespective of what context the ALL-VALUES expression
3087 appears in, the EXPRESSIONS are always in a nondeterministic context.
3088 An ALL-VALUES expression itself is always deterministic. ALL-VALUES is
3089 analogous to the bagof primitive in Prolog."
3090   (let ((values (gensym "VALUES"))
3091         (last-value-cons (gensym "LAST-VALUE-CONS")))
3092     `(let ((,values '())
3093            (,last-value-cons nil))
3094        (for-effects
3095          (let ((value (progn ,@expressions)))
3096            (global (if (null ,values)
3097                        (setf ,last-value-cons (list value)
3098                              ,values ,last-value-cons)
3099                        (setf (rest ,last-value-cons) (list value)
3100                              ,last-value-cons (rest ,last-value-cons))))))
3101        ,values)))
3102
3103 (defmacro-compile-time ith-value (i expression &optional (default-expression '(fail)))
3104   "Returns the Ith value of a nondeterministic expression. EXPRESSION
3105 is evaluated, deterministically returning only its Ith
3106 nondeterministic value, if any. I must be an integer. The first
3107 nondeterministic value returned by EXPRESSION is numbered zero, the
3108 second one, etc. The Ith value is produced by repeatedly evaluating
3109 EXPRESSION, backtracking through and discarding the first I values and
3110 deterministically returning the next value produced. No further
3111 execution of EXPRESSION is attempted after it successfully returns the
3112 desired value. If EXPRESSION fails before returning both the I values
3113 to be discarded, as well as the desired Ith value, then
3114 DEFAULT-EXPRESSION is evaluated and its value returned instead.
3115 DEFAULT-EXPRESSION defaults to \(FAIL) if not present. Local side
3116 effects performed by EXPRESSION are undone when ITH-VALUE returns. On
3117 the other hand, local side effects performed by DEFAULT-EXPRESSION and
3118 by I are not undone when ITH-VALUE returns. An ITH-VALUE expression
3119 can appear in both deterministic and nondeterministic contexts.
3120 Irrespective of what context the ITH-VALUE expression appears in,
3121 EXPRESSION is always in a nondeterministic context, while
3122 DEFAULT-EXPRESSION and I are in whatever context the ITH-VALUE
3123 expression appears. An ITH-VALUE expression is nondeterministic if
3124 DEFAULT-EXPRESSION is present and is nondeterministic, or if I is
3125 nondeterministic. Otherwise it is deterministic. If DEFAULT-EXPRESSION
3126 is present and nondeterministic, and if EXPRESSION fails, then it is
3127 possible to backtrack into the DEFAULT-EXPRESSION and for the
3128 ITH-VALUE expression to nondeterministically return multiple times. If
3129 I is nondeterministic then the ITH-VALUE expression operates
3130 nondeterministically on each value of I. In this case, backtracking
3131 for each value of EXPRESSION and DEFAULT-EXPRESSION is nested in, and
3132 restarted for, each backtrack of I."
3133   (let ((counter (gensym "I")))
3134     `(block ith-value
3135        (let ((,counter (value-of ,i)))
3136          (for-effects (let ((value ,expression))
3137                         (if (zerop ,counter)
3138                             (return-from ith-value value)
3139                             (decf ,counter))))
3140          ,default-expression))))
3141
3142 (defun trail (function)
3143   ;; note: Is it really better to use VECTOR-PUSH-EXTEND than CONS for the
3144   ;;       trail?
3145   (if *nondeterministic?* (vector-push-extend function *trail* 1024)))
3146
3147 (defun y-or-n-p
3148     (&optional (format-string nil format-string?) &rest format-args)
3149   (cond
3150     (*iscream?*
3151      (let ((query (if format-string?
3152                       (format nil "~A (Y or N): "
3153                               (apply #'format nil format-string format-args))
3154                       "(Y or N): ")))
3155        (emacs-eval '(y-or-n-p-begin))
3156        (unwind-protect
3157             (tagbody
3158              loop
3159                (format *query-io* "~%~A" query)
3160                (let ((char (read-char *query-io*)))
3161                  (when (or (char= char #\y) (char= char #\Y))
3162                    (format *query-io* "Y")
3163                    (return-from y-or-n-p t))
3164                  (when (or (char= char #\n) (char= char #\N))
3165                    (format *query-io* "N")
3166                    (return-from y-or-n-p nil)))
3167                (format *query-io* "Please type a single character, Y or N")
3168                (go loop))
3169          (emacs-eval '(y-or-n-p-end)))))
3170     (format-string? (apply #'cl:y-or-n-p format-string format-args))
3171     (t (cl:y-or-n-p))))
3172
3173 (defmacro-compile-time print-values (&body expressions)
3174   "Evaluates EXPRESSIONS \(wrapped in an implicit PROGN) and prints
3175 each of the nondeterministic values returned by the last EXPRESSION in
3176 succession \(using PRINT). After each value is printed, the user is
3177 queried as to whether or not further values are desired. These values
3178 are produced by repeatedly evaluating the body and backtracking to
3179 produce the next value, until either the user indicates that no
3180 further values are desired or until the body fails and yields no
3181 further values. Accordingly, local side effects performed by the body
3182 while producing each value are undone after printing each value,
3183 before attempting to produce subsequent values, and all local side
3184 effects performed by the body are undone upon exit from PRINT-VALUES,
3185 either because there are no further values or because the user
3186 declines to produce further values. A PRINT-VALUES expression can
3187 appear in both deterministic and nondeterministic contexts.
3188 Irrespective of what context the PRINT-VALUES expression appears in,
3189 the EXPRESSIONS are always in a nondeterministic context. A
3190 PRINT-VALUES expression itself is always deterministic and always
3191 returns NIL. PRINT-VALUES is analogous to the standard top-level user
3192 interface in Prolog."
3193   ;; FIXME: Documentation lies: does not always return NIL.
3194   `(catch 'succeed
3195      (for-effects
3196        (let ((value (progn ,@expressions)))
3197          (print value)
3198          (unless (y-or-n-p "Do you want another solution?")
3199            (throw 'succeed value))))))
3200
3201 ;;; note: Should have way of having a stream of values.
3202
3203 (eval-when (:compile-toplevel :load-toplevel :execute) (setf *screamer?* t))
3204
3205 (defun print-nondeterministic-function
3206     (nondeterministic-function stream print-level)
3207   (declare (ignore print-level))
3208   (format stream "#<~A ~S>"
3209           'nondeterministic
3210           (nondeterministic-function-function nondeterministic-function)))
3211
3212 (eval-when (:compile-toplevel :load-toplevel :execute)
3213   (declare-nondeterministic 'a-boolean))
3214
3215 (cl:defun a-boolean ()
3216   (screamer-error
3217    "A-BOOLEAN is a nondeterministic function. As such, it must be called only~%~
3218    from a nondeterministic context."))
3219
3220 (cl:defun a-boolean-nondeterministic (continuation)
3221   (choice-point (funcall continuation t))
3222   (funcall continuation nil))
3223
3224 (defun fail ()
3225   "Backtracks to the most recent choise point. Equivalent to
3226 \(EITHER). Note that FAIL is deterministic function and thus it is
3227 permissible to reference #'FAIL, and write \(FUNCALL #'FAIL) or
3228 \(APPLY #'FAIL). In nondeterministic contexts, the expression \(FAIL)
3229 is optimized to generate inline backtracking code."
3230   ;; FIXME: Since we export FAIL, throwing to it is probably a bad idea.
3231   ;; ...better throw to %FAIL.
3232   (throw 'fail nil))
3233
3234 (defmacro-compile-time when-failing ((&body failing-forms) &body forms)
3235   (let ((old-fail (gensym "FAIL-")))
3236     `(let ((,old-fail #'fail))
3237        (unwind-protect
3238             (progn (setf (symbol-function 'fail)
3239                          #'(lambda () ,@failing-forms (funcall ,old-fail)))
3240                    ,@forms)
3241          (setf (symbol-function 'fail) ,old-fail)))))
3242
3243 (defmacro-compile-time count-failures (&body forms)
3244   (let ((values (gensym "VALUES-")))
3245     `(let ((failure-count 0))
3246        (when-failing ((incf failure-count))
3247          (let ((,values (multiple-value-list (progn ,@forms))))
3248            (format t "Failures         = ~10<~;~d~>" failure-count)
3249            (values-list ,values))))))
3250
3251 (defun nondeterministic-function? (x)
3252   "Returns T if X is a nondeterministic function object and NIL
3253 otherwise. Nondeterministic function objects can be produced in two
3254 ways. First, the special form \(FUNCTION FOO) \(i.e. #'FOO) will
3255 \(deterministically) evaluate to a nondeterministic function object if
3256 FOO names a nondeterministic function defined by DEFUN. Second, the
3257 special form \(FUNCTION \(LAMBDA \(...) ...)) \(i.e. #'\(lambda \(...)
3258 ...)) will \(deterministically) evaluate to a nondeterministic function
3259 object if the body of the lambda expression contains a
3260 nondeterministic expression."
3261   ;; FIXME: Is the above really true? What about FDEFINITION,
3262   ;; SYMBOL-FUNCTION, or #'X where X is defined by FLET or LABELS?
3263   (nondeterministic-function?-internal (value-of x)))
3264
3265 (eval-when (:compile-toplevel :load-toplevel :execute)
3266   (declare-nondeterministic 'funcall-nondeterministic))
3267
3268 (cl:defun funcall-nondeterministic (function &rest arguments)
3269   "Analogous to the Common Lisp built-in function FUNCALL except that
3270 it accepts both ordinary Common Lisp \(deterministic) function objects
3271 as well as nondeterministic function objects for function. You must
3272 use FUNCALL-NONDETERMINISTIC to funcall a nondeterministic function
3273 object. A runtime error will be signalled if you attempt to funcall a
3274 nondeterministic function object with FUNCALL. You can use
3275 FUNCALL-NONDETERMINISTIC to funcall either a deterministic or
3276 nondeterministic function object though even if all of the arguments
3277 to FUNCALL-NONDETERMINISTIC are deterministic and FUNCTION is a
3278 deterministic function object, the call expression will still be
3279 nondeterministic \(with presumably a single value), since it is
3280 impossible to determine at compile time that a given call to
3281 FUNCALL-NONDETERMINISTIC will be passed only deterministic function
3282 objects for function."
3283   (declare (ignore function arguments))
3284   (screamer-error
3285    "FUNCALL-NONDETERMINISTIC is a nondeterministic function. As such, it~%~
3286    must be called only from a nondeterministic context."))
3287
3288 (cl:defun funcall-nondeterministic-nondeterministic
3289     (continuation function &rest arguments)
3290   (let ((function (value-of function)))
3291     (if (nondeterministic-function? function)
3292         (apply (nondeterministic-function-function function)
3293                continuation
3294                arguments)
3295         (funcall continuation (apply function arguments)))))
3296
3297 (eval-when (:compile-toplevel :load-toplevel :execute)
3298   (declare-nondeterministic 'apply-nondeterministic))
3299
3300 (cl:defun apply-nondeterministic (function argument &rest arguments)
3301   "Analogous to the Common Lisp built-in function APPLY except that it
3302 accepts both ordinary Common Lisp \(deterministic) function objects as
3303 well as nondeterministic function objects for function. You must use
3304 APPLY-NONDETERMINISTIC to apply a nondeterministic function object. A
3305 runtime error will be signalled if you attempt to apply a
3306 nondeterministic function object with APPLY. You can use
3307 APPLY-NONDETERMINISTIC to apply either a deterministic or
3308 nondeterministic function object though even if all of the arguments
3309 to APPLY-NONDETERMINISTIC are deterministic and function is a
3310 deterministic function object, the call expression will still be
3311 nondeterministic \(with presumably a single value), since it is
3312 impossible to determine at compile time that a given call to
3313 APPLY-NONDETERMINISTIC will be passed only deterministic function
3314 objects for function."
3315   (declare (ignore function argument arguments))
3316   (screamer-error
3317    "APPLY-NONDETERMINISTIC is a nondeterministic function. As such, it must~%~
3318    be called only from a nondeterministic context."))
3319
3320 (cl:defun apply-nondeterministic-nondeterministic
3321     (continuation function argument &rest arguments)
3322   (let ((function (value-of function)))
3323     (if (nondeterministic-function? function)
3324         ;; note: I don't know how to avoid the consing here.
3325         (apply (nondeterministic-function-function function)
3326                continuation
3327                (apply #'list* (cons argument arguments)))
3328         (funcall continuation (apply function argument arguments)))))
3329
3330 (defmacro-compile-time multiple-value-bind
3331     (variables form &body body &environment environment)
3332   (if (every #'(lambda (form) (deterministic? form environment))
3333              (peal-off-documentation-string-and-declarations body))
3334       `(cl:multiple-value-bind ,variables ,form ,@body)
3335       (let ((other-arguments (gensym "OTHER-")))
3336         `(multiple-value-call-nondeterministic
3337           #'(lambda (&optional ,@variables &rest ,other-arguments)
3338               (declare (ignore ,other-arguments))
3339               ,@body)
3340           ,form))))
3341
3342 (defun unwind-trail ()
3343   (tagbody
3344    loop
3345      (if (zerop (fill-pointer *trail*)) (return-from unwind-trail))
3346      (funcall (vector-pop *trail*))
3347      ;; note: This is to allow the trail closures to be garbage collected.
3348      (setf (aref *trail* (fill-pointer *trail*)) nil)
3349      (go loop)))
3350
3351 (defun purge (function-name)
3352   "Removes any information about FUNCTION-NAME from Screamer's
3353 who-calls database."
3354   (remhash (value-of function-name) *function-record-table*)
3355   t)
3356
3357 (defun unwedge-screamer ()
3358   "Removes any information about all user defined functions from
3359 Screamer's who-calls database."
3360   (maphash #'(lambda (function-name function-record)
3361                (unless (function-record-screamer? function-record)
3362                  (remhash function-name *function-record-table*)))
3363            *function-record-table*)
3364   t)
3365
3366 ;;; note: These optimized versions of AN-INTEGER, AN-INTEGER-ABOVE,
3367 ;;;       AN-INTEGER-BELOW, AN-INTEGER-BETWEEN and A-MEMBER-OF have different
3368 ;;;       failure behavior as far as WHEN-FAILING is concerned than the
3369 ;;;       original purely Screamer versions. This is likely to affect only
3370 ;;;       failure counts generated by COUNT-FAILURES. A small price to pay for
3371 ;;;       tail recursion optimization.
3372
3373 (eval-when (:compile-toplevel :load-toplevel :execute)
3374   (declare-nondeterministic 'an-integer))
3375
3376 (cl:defun an-integer ()
3377   (screamer-error
3378    "AN-INTEGER is a nondeterministic function. As such, it must be called~%~
3379    only from a nondeterministic context."))
3380
3381 (cl:defun an-integer-nondeterministic (continuation)
3382   (choice-point-external
3383    (choice-point-internal (funcall continuation 0))
3384    (let ((i 1))
3385      (loop (choice-point-internal (funcall continuation i))
3386        (choice-point-internal (funcall continuation (- i)))
3387        (incf i)))))
3388
3389 (eval-when (:compile-toplevel :load-toplevel :execute)
3390   (declare-nondeterministic 'an-integer-above))
3391
3392 (cl:defun an-integer-above (low)
3393   (declare (ignore low))
3394   (screamer-error
3395    "AN-INTEGER-ABOVE is a nondeterministic function. As such, it must be~%~
3396    called only from a nondeterministic context."))
3397
3398 (cl:defun an-integer-above-nondeterministic (continuation low)
3399   (let ((low (ceiling (value-of low))))
3400     (choice-point-external
3401      (let ((i low))
3402        (loop (choice-point-internal (funcall continuation i))
3403          (incf i))))))
3404
3405 (eval-when (:compile-toplevel :load-toplevel :execute)
3406   (declare-nondeterministic 'an-integer-below))
3407
3408 (cl:defun an-integer-below (high)
3409   (declare (ignore high))
3410   (screamer-error
3411    "AN-INTEGER-BELOW is a nondeterministic function. As such, it must be~%~
3412    called only from a nondeterministic context."))
3413
3414 (cl:defun an-integer-below-nondeterministic (continuation high)
3415   (let ((high (floor (value-of high))))
3416     (choice-point-external
3417      (let ((i high))
3418        (loop (choice-point-internal (funcall continuation i))
3419          (decf i))))))
3420
3421 (eval-when (:compile-toplevel :load-toplevel :execute)
3422   (declare-nondeterministic 'an-integer-between))
3423
3424 (cl:defun an-integer-between (low high)
3425   "Nondeterministically returns an integer in the closed interval
3426 [LOW, HIGH]. The results are returned in ascending order. LOW and HIGH
3427 must be integers. Fails if the interval does not contain any
3428 integers."
3429   (declare (ignore low high))
3430   (screamer-error
3431    "AN-INTEGER-BETWEEN is a nondeterministic function. As such, it must be~%~
3432    called only from a nondeterministic context."))
3433
3434 (cl:defun an-integer-between-nondeterministic (continuation low high)
3435   (let ((low (ceiling (value-of low)))
3436         (high (floor (value-of high))))
3437     (unless (> low high)
3438       (choice-point-external
3439        (do ((i low (1+ i))) ((= i high))
3440          (choice-point-internal (funcall continuation i))))
3441       (funcall continuation high))))
3442
3443 (eval-when (:compile-toplevel :load-toplevel :execute)
3444   (declare-nondeterministic 'a-member-of))
3445
3446 (cl:defun a-member-of (sequence)
3447   "Nondeterministically returns an element of SEQUENCE. The elements
3448 are returned in the order that they appear in SEQUENCE. SEQUENCE must
3449 be either a list or a vector."
3450   (declare (ignore sequence))
3451   (screamer-error
3452    "A-MEMBER-OF is a nondeterministic function. As such, it must be called~%~
3453    only from a nondeterministic context."))
3454
3455 (cl:defun a-member-of-nondeterministic (continuation sequence)
3456   (let ((sequence (value-of sequence)))
3457     (cond
3458       ((listp sequence)
3459        (unless (null sequence)
3460          (choice-point-external
3461           (loop (if (null (rest sequence)) (return))
3462             (choice-point-internal (funcall continuation (first sequence)))
3463             (setf sequence (value-of (rest sequence)))))
3464          (funcall continuation (first sequence))))
3465       ((vectorp sequence)
3466        (let ((n (1- (length sequence))))
3467          (unless (zerop n)
3468            (choice-point-external
3469             (dotimes (i n)
3470               (choice-point-internal (funcall continuation (aref sequence i)))))
3471            (funcall continuation (aref sequence n)))))
3472       (t (error "SEQUENCE must be a sequence")))))
3473
3474 ;;; note: The following two functions work only when Screamer is running under
3475 ;;;       ILisp/GNUEmacs with iscream.el loaded.
3476
3477 (defun emacs-eval (expression)
3478   (unless *iscream?*
3479     (error "Cannot do EMACS-EVAL unless Screamer is running under~%~
3480           ILisp/GNUEmacs with iscream.el loaded."))
3481   (format *terminal-io* "~A~A~A"
3482           (format nil "~A" (code-char 27))
3483           (string-downcase (format nil "~A" expression))
3484           (format nil "~A" (code-char 29))))
3485
3486 (defmacro-compile-time local-output (&body forms)
3487   `(progn
3488      (unless *iscream?*
3489        (error "Cannot do LOCAL-OUTPUT unless Screamer is running under~%~
3490             ILisp/GNUEmacs with iscream.el loaded."))
3491      (trail #'(lambda () (emacs-eval '(pop-end-marker))))
3492      (emacs-eval '(push-end-marker))
3493      ,@forms))
3494
3495 ;;; Constraints
3496
3497 (defvar *name* 0 "The counter for anonymous names.")
3498
3499 (defvar *minimum-shrink-ratio* 1e-2
3500   "Ignore propagations which reduce the range of a variable by less than this
3501    ratio.")
3502
3503 (defvar *maximum-discretization-range* 20
3504   "Discretize integer variables whose range is not greater than this number.
3505    Discretize all integer variables if NIL.
3506    Must be an integer or NIL.")
3507
3508 (defvar *strategy* :gfc
3509   "Strategy to use for FUNCALLV and APPLYV: either :GFC or :AC")
3510
3511 ;;; note: Enable this to use CLOS instead of DEFSTRUCT for variables.
3512 #+(or)
3513 (eval-when (:compile-toplevel :load-toplevel :execute)
3514   (pushnew :screamer-clos *features* :test #'eq))
3515
3516 #-screamer-clos
3517 (defstruct-compile-time (variable (:print-function print-variable)
3518                                   (:predicate variable?)
3519                                   (:constructor make-variable-internal))
3520   name
3521   (noticers nil)
3522   (enumerated-domain t)
3523   (enumerated-antidomain nil)
3524   value
3525   (possibly-integer? t)
3526   (possibly-noninteger-real? t)
3527   (possibly-nonreal-number? t)
3528   (possibly-boolean? t)
3529   (possibly-nonboolean-nonnumber? t)
3530   (lower-bound nil)
3531   (upper-bound nil))
3532
3533 #+screamer-clos
3534 (defclass variable ()
3535   ((name :accessor variable-name :initarg :name)
3536    (noticers :accessor variable-noticers :initform nil)
3537    (enumerated-domain :accessor variable-enumerated-domain :initform t)
3538    (enumerated-antidomain :accessor variable-enumerated-antidomain
3539                           :initform nil)
3540    (value :accessor variable-value)
3541    (possibly-integer? :accessor variable-possibly-integer? :initform t)
3542    (possibly-noninteger-real? :accessor variable-possibly-noninteger-real?
3543                               :initform t)
3544    (possibly-nonreal-number? :accessor variable-possibly-nonreal-number?
3545                              :initform t)
3546    (possibly-boolean? :accessor variable-possibly-boolean? :initform t)
3547    (possibly-nonboolean-nonnumber?
3548     :accessor variable-possibly-nonboolean-nonnumber?
3549     :initform t)
3550    (lower-bound :accessor variable-lower-bound :initform nil)
3551    (upper-bound :accessor variable-upper-bound :initform nil)))
3552
3553 #+screamer-clos
3554 (defmethod print-object ((variable variable) stream)
3555   (print-variable variable stream nil))
3556
3557 #+screamer-clos
3558 (defun-compile-time variable? (thing) (typep thing 'variable))
3559
3560 (defun booleanp (x) (typep x 'boolean))
3561
3562 (defun infinity-min (x y) (and x y (min x y)))
3563
3564 (defun infinity-max (x y) (and x y (max x y)))
3565
3566 (defun infinity-+ (x y) (and x y (+ x y)))
3567
3568 (defun infinity-- (x y) (and x y (- x y)))
3569
3570 (defun infinity-* (x y) (and x y (* x y)))
3571
3572 (defun contains-variables? (x)
3573   (typecase x
3574     (cons (or (contains-variables? (car x)) (contains-variables? (cdr x))))
3575     (variable t)
3576     (otherwise nil)))
3577
3578 (defun eliminate-variables (x)
3579   (if (contains-variables? x)
3580       (if (consp x)
3581           (cons (eliminate-variables (car x)) (eliminate-variables (cdr x)))
3582           (eliminate-variables (variable-value x)))
3583       x))
3584
3585 (defun print-variable (x stream print-level)
3586   (declare (ignore print-level))
3587   (let ((x (value-of x)))
3588     (cond
3589       ((variable? x)
3590        (if (and (not (eq (variable-enumerated-domain x) t))
3591                 (not (null (variable-enumerated-antidomain x))))
3592            (error "This shouldn't happen"))
3593        (format stream "[~S" (variable-name x))
3594        (format stream "~A"
3595                (cond ((variable-boolean? x) " Boolean")
3596                      ((variable-integer? x) " integer")
3597                      ((variable-real? x)
3598                       (if (variable-noninteger? x) " noninteger-real" " real"))
3599                      ((variable-number? x)
3600                       (cond ((variable-nonreal? x) " nonreal-number")
3601                             ((variable-noninteger? x) " noninteger-number")
3602                             (t " number")))
3603                      ((variable-nonnumber? x) " nonnumber")
3604                      ((variable-nonreal? x) " nonreal")
3605                      ((variable-noninteger? x) " noninteger")
3606                      (t "")))
3607        (if (variable-real? x)
3608            (if (variable-lower-bound x)
3609                (if (variable-upper-bound x)
3610                    (format stream " ~D:~D"
3611                            (variable-lower-bound x) (variable-upper-bound x))
3612                    (format stream " ~D:" (variable-lower-bound x)))
3613                (if (variable-upper-bound x)
3614                    (format stream " :~D" (variable-upper-bound x)))))
3615        (if (and (not (eq (variable-enumerated-domain x) t))
3616                 (not (variable-boolean? x)))
3617            (format stream " enumerated-domain:~S"
3618                    (variable-enumerated-domain x)))
3619        (if (not (null (variable-enumerated-antidomain x)))
3620            (format stream " enumerated-antidomain:~S"
3621                    (variable-enumerated-antidomain x)))
3622        (format stream "]"))
3623       (t (format stream "~S" x)))))
3624
3625 (defun make-variable (&optional (name nil name?))
3626   "Creates and returns a new variable. Variables are assigned a name
3627 which is only used to identify the variable when it is printed. If the
3628 parameter NAME is given then it is assigned as the name of the
3629 variable. Otherwise, a unique name is assigned. The parameter NAME can
3630 be any Lisp object."
3631   (let ((variable
3632          #-screamer-clos
3633           (make-variable-internal :name (if name? name (incf *name*)))
3634           #+screamer-clos
3635           (make-instance 'variable :name (if name? name (incf *name*)))))
3636     (setf (variable-value variable) variable)
3637     variable))
3638
3639 (defun variable-integer? (x)
3640   (and (not (variable-possibly-boolean? x))
3641        (not (variable-possibly-nonboolean-nonnumber? x))
3642        (not (variable-possibly-nonreal-number? x))
3643        (not (variable-possibly-noninteger-real? x))
3644        (variable-possibly-integer? x)))
3645
3646 (defun variable-noninteger? (x)
3647   (and (or (variable-possibly-boolean? x)
3648            (variable-possibly-nonboolean-nonnumber? x)
3649            (variable-possibly-nonreal-number? x)
3650            (variable-possibly-noninteger-real? x))
3651        (not (variable-possibly-integer? x))))
3652
3653 (defun variable-real? (x)
3654   (and (not (variable-possibly-boolean? x))
3655        (not (variable-possibly-nonboolean-nonnumber? x))
3656        (not (variable-possibly-nonreal-number? x))
3657        (or (variable-possibly-noninteger-real? x)
3658            (variable-possibly-integer? x))))
3659
3660 (defun variable-nonreal? (x)
3661   (and (or (variable-possibly-boolean? x)
3662            (variable-possibly-nonboolean-nonnumber? x)
3663            (variable-possibly-nonreal-number? x))
3664        (not (variable-possibly-noninteger-real? x))
3665        (not (variable-possibly-integer? x))))
3666
3667 (defun variable-number? (x)
3668   (and (not (variable-possibly-boolean? x))
3669        (not (variable-possibly-nonboolean-nonnumber? x))
3670        (or (variable-possibly-nonreal-number? x)
3671            (variable-possibly-noninteger-real? x)
3672            (variable-possibly-integer? x))))
3673
3674 (defun variable-nonnumber? (x)
3675   (and (or (variable-possibly-boolean? x)
3676            (variable-possibly-nonboolean-nonnumber? x))
3677        (not (variable-possibly-nonreal-number? x))
3678        (not (variable-possibly-noninteger-real? x))
3679        (not (variable-possibly-integer? x))))
3680
3681 (defun variable-boolean? (x)
3682   (and (variable-possibly-boolean? x)
3683        (not (variable-possibly-nonboolean-nonnumber? x))
3684        (not (variable-possibly-nonreal-number? x))
3685        (not (variable-possibly-noninteger-real? x))
3686        (not (variable-possibly-integer? x))))
3687
3688 (defun variable-nonboolean? (x)
3689   (and (not (variable-possibly-boolean? x))
3690        (or (variable-possibly-nonboolean-nonnumber? x)
3691            (variable-possibly-nonreal-number? x)
3692            (variable-possibly-noninteger-real? x)
3693            (variable-possibly-integer? x))))
3694
3695 (defun variable-true? (x) (eq (variable-value x) t))
3696
3697 (defun variable-false? (x) (null (variable-value x)))
3698
3699 (defun value-of (x)
3700   (tagbody
3701    loop
3702      (if (or (not (variable? x))
3703              #+screamer-clos (not (slot-boundp x 'value))
3704              (eq (variable-value x) x))
3705          (return-from value-of x))
3706      (setf x (variable-value x))
3707      (go loop)))
3708
3709 (defun variablize (x)
3710   (if (variable? x)
3711       (tagbody
3712        loop
3713          (if (or (not (variable? (variable-value x)))
3714                  (eq (variable-value x) x))
3715              (return-from variablize x))
3716          (setf x (variable-value x))
3717          (go loop))
3718       (let ((y (make-variable))) (restrict-value! y x) y)))
3719
3720 (defun bound? (x) (not (variable? (value-of x))))
3721
3722 (defun ground? (x)
3723   (let ((x (value-of x)))
3724     (and (not (variable? x))
3725          (or (not (consp x)) (and (ground? (car x)) (ground? (cdr x)))))))
3726
3727 (defun apply-substitution (x)
3728   (let ((x (value-of x)))
3729     (if (consp x)
3730         (cons (apply-substitution (car x)) (apply-substitution (cdr x)))
3731         x)))
3732
3733 (defun occurs-in? (x value)
3734   ;; note: X must be a variable such that (EQ X (VALUE-OF X)).
3735   ;; note: Will loop if VALUE is circular.
3736   (cond
3737     ((eq x value) t)
3738     ((and (variable? value) (not (eq value (variable-value value))))
3739      (occurs-in? x (variable-value value)))
3740     ((consp value) (or (occurs-in? x (car value)) (occurs-in? x (cdr value))))
3741     (t nil)))
3742
3743 (defun attach-noticer!-internal (noticer x)
3744   ;; note: Will loop if X is circular.
3745   (typecase x
3746     (cons (attach-noticer!-internal noticer (car x))
3747           (attach-noticer!-internal noticer (cdr x)))
3748     (variable (if (eq x (variable-value x))
3749                   ;; note: I can't remember why this check for duplication is
3750                   ;;       here.
3751                   (unless (member noticer (variable-noticers x) :test #'eq)
3752                     ;; note: This can't be a PUSH because of the Lucid screw.
3753                     (local (setf (variable-noticers x)
3754                                  (cons noticer (variable-noticers x)))))
3755                   (attach-noticer!-internal noticer (variable-value x))))))
3756
3757 (defun attach-noticer! (noticer x)
3758   (attach-noticer!-internal noticer x)
3759   (funcall noticer))
3760
3761 (defun run-noticers (x)
3762   (dolist (noticer (variable-noticers x)) (funcall noticer)))
3763
3764 ;;; Restrictions
3765
3766 (defun restrict-integer! (x)
3767   ;; note: X must be a variable.
3768   (unless (variable-possibly-integer? x) (fail))
3769   (if (or (eq (variable-value x) x) (not (variable? (variable-value x))))
3770       (let ((run? nil))
3771         (when (variable-possibly-noninteger-real? x)
3772           (local (setf (variable-possibly-noninteger-real? x) nil))
3773           (setf run? t))
3774         (when (variable-possibly-nonreal-number? x)
3775           (local (setf (variable-possibly-nonreal-number? x) nil))
3776           (setf run? t))
3777         (when (variable-possibly-boolean? x)
3778           (local (setf (variable-possibly-boolean? x) nil))
3779           (setf run? t))
3780         (when (variable-possibly-nonboolean-nonnumber? x)
3781           (local (setf (variable-possibly-nonboolean-nonnumber? x) nil))
3782           (setf run? t))
3783         (when (and (variable-lower-bound x)
3784                    (not (integerp (variable-lower-bound x))))
3785           (if (and (variable-upper-bound x)
3786                    (< (variable-upper-bound x)
3787                       (ceiling (variable-lower-bound x))))
3788               (fail))
3789           (local (setf (variable-lower-bound x)
3790                        (ceiling (variable-lower-bound x))))
3791           (setf run? t))
3792         (when (and (variable-upper-bound x)
3793                    (not (integerp (variable-upper-bound x))))
3794           (if (and (variable-lower-bound x)
3795                    (> (variable-lower-bound x)
3796                       (floor (variable-upper-bound x))))
3797               (fail))
3798           (local (setf (variable-upper-bound x) (floor (variable-upper-bound x))))
3799           (setf run? t))
3800         (when run?
3801           (cond ((eq (variable-enumerated-domain x) t)
3802                  (if (and (variable-lower-bound x)
3803                           (variable-upper-bound x)
3804                           (or (null *maximum-discretization-range*)
3805                               (<= (- (variable-upper-bound x)
3806                                      (variable-lower-bound x))
3807                                   *maximum-discretization-range*)))
3808                      (set-enumerated-domain!
3809                       x (all-values (an-integer-between
3810                                      (variable-lower-bound x)
3811                                      (variable-upper-bound x))))))
3812                 ((not (every #'integerp (variable-enumerated-domain x)))
3813                  ;; note: Could do less consing if had LOCAL DELETE-IF.
3814                  ;;       This would also allow checking list only once.
3815                  (set-enumerated-domain!
3816                   x (remove-if-not #'integerp (variable-enumerated-domain x)))))
3817           (run-noticers x)))))
3818
3819 (defun restrict-noninteger! (x)
3820   ;; note: X must be a variable.
3821   (unless (or (variable-possibly-noninteger-real? x)
3822               (variable-possibly-nonreal-number? x)
3823               (variable-possibly-boolean? x)
3824               (variable-possibly-nonboolean-nonnumber? x))
3825     (fail))
3826   (when (and (or (eq (variable-value x) x) (not (variable? (variable-value x))))
3827              (variable-possibly-integer? x))
3828     (local (setf (variable-possibly-integer? x) nil))
3829     (if (and (not (eq (variable-enumerated-domain x) t))
3830              (some #'integerp (variable-enumerated-domain x)))
3831         ;; note: Could do less consing if had LOCAL DELETE-IF.
3832         ;;       This would also allow checking list only once.
3833         (set-enumerated-domain!
3834          x (remove-if #'integerp (variable-enumerated-domain x))))
3835     (run-noticers x)))
3836
3837 (defun restrict-real! (x)
3838   ;; note: X must be a variable.
3839   (unless (or (variable-possibly-integer? x)
3840               (variable-possibly-noninteger-real? x))
3841     (fail))
3842   (if (or (eq (variable-value x) x) (not (variable? (variable-value x))))
3843       (let ((run? nil))
3844         (when (variable-possibly-nonreal-number? x)
3845           (local (setf (variable-possibly-nonreal-number? x) nil))
3846           (setf run? t))
3847         (when (variable-possibly-boolean? x)
3848           (local (setf (variable-possibly-boolean? x) nil))
3849           (setf run? t))
3850         (when (variable-possibly-nonboolean-nonnumber? x)
3851           (local (setf (variable-possibly-nonboolean-nonnumber? x) nil))
3852           (setf run? t))
3853         (when run?
3854           (if (and (not (eq (variable-enumerated-domain x) t))
3855                    (not (every #'realp (variable-enumerated-domain x))))
3856               ;; note: Could do less consing if had LOCAL DELETE-IF.
3857               ;;       This would also allow checking list only once.
3858               (set-enumerated-domain!
3859                x (remove-if-not #'realp (variable-enumerated-domain x))))
3860           (run-noticers x)))))
3861
3862 (defun restrict-nonreal! (x)
3863   ;; note: X must be a variable.
3864   (unless (or (variable-possibly-nonreal-number? x)
3865               (variable-possibly-boolean? x)
3866               (variable-possibly-nonboolean-nonnumber? x))
3867     (fail))
3868   (if (or (eq (variable-value x) x) (not (variable? (variable-value x))))
3869       (let ((run? nil))
3870         (when (variable-possibly-integer? x)
3871           (local (setf (variable-possibly-integer? x) nil))
3872           (setf run? t))
3873         (when (variable-possibly-noninteger-real? x)
3874           (local (setf (variable-possibly-noninteger-real? x) nil))
3875           (setf run? t))
3876         (when run?
3877           (if (and (not (eq (variable-enumerated-domain x) t))
3878                    (some #'realp (variable-enumerated-domain x)))
3879               ;; note: Could do less consing if had LOCAL DELETE-IF.
3880               ;;       This would also allow checking list only once.
3881               (set-enumerated-domain!
3882                x (remove-if #'realp (variable-enumerated-domain x))))
3883           (run-noticers x)))))
3884
3885 (defun restrict-number! (x)
3886   ;; note: X must be a variable.
3887   (unless (or (variable-possibly-integer? x)
3888               (variable-possibly-noninteger-real? x)
3889               (variable-possibly-nonreal-number? x))
3890     (fail))
3891   (if (or (eq (variable-value x) x) (not (variable? (variable-value x))))
3892       (let ((run? nil))
3893         (when (variable-possibly-boolean? x)
3894           (local (setf (variable-possibly-boolean? x) nil))
3895           (setf run? t))
3896         (when (variable-possibly-nonboolean-nonnumber? x)
3897           (local (setf (variable-possibly-nonboolean-nonnumber? x) nil))
3898           (setf run? t))
3899         (when run?
3900           (if (and (not (eq (variable-enumerated-domain x) t))
3901                    (not (every #'numberp (variable-enumerated-domain x))))
3902               ;; note: Could do less consing if had LOCAL DELETE-IF.
3903               ;;       This would also allow checking list only once.
3904               (set-enumerated-domain!
3905                x (remove-if-not #'numberp (variable-enumerated-domain x))))
3906           (run-noticers x)))))
3907
3908 (defun restrict-nonnumber! (x)
3909   ;; note: X must be a variable.
3910   (unless (or (variable-possibly-boolean? x)
3911               (variable-possibly-nonboolean-nonnumber? x))
3912     (fail))
3913   (if (or (eq (variable-value x) x) (not (variable? (variable-value x))))
3914       (let ((run? nil))
3915         (when (variable-possibly-integer? x)
3916           (local (setf (variable-possibly-integer? x) nil))
3917           (setf run? t))
3918         (when (variable-possibly-noninteger-real? x)
3919           (local (setf (variable-possibly-noninteger-real? x) nil))
3920           (setf run? t))
3921         (when (variable-possibly-nonreal-number? x)
3922           (local (setf (variable-possibly-nonreal-number? x) nil))
3923           (setf run? t))
3924         (when run?
3925           (if (and (not (eq (variable-enumerated-domain x) t))
3926                    (some #'numberp (variable-enumerated-domain x)))
3927               ;; note: Could do less consing if had LOCAL DELETE-IF.
3928               ;;       This would also allow checking list only once.
3929               (set-enumerated-domain!
3930                x (remove-if #'numberp (variable-enumerated-domain x))))
3931           (run-noticers x)))))
3932
3933 (defun restrict-boolean! (x)
3934   ;; note: X must be a variable.
3935   (unless (variable-possibly-boolean? x) (fail))
3936   (if (or (eq (variable-value x) x) (not (variable? (variable-value x))))
3937       (let ((run? nil))
3938         (when (variable-possibly-integer? x)
3939           (local (setf (variable-possibly-integer? x) nil))
3940           (setf run? t))
3941         (when (variable-possibly-noninteger-real? x)
3942           (local (setf (variable-possibly-noninteger-real? x) nil))
3943           (setf run? t))
3944         (when (variable-possibly-nonreal-number? x)
3945           (local (setf (variable-possibly-nonreal-number? x) nil))
3946           (setf run? t))
3947         (when (variable-possibly-nonboolean-nonnumber? x)
3948           (local (setf (variable-possibly-nonboolean-nonnumber? x) nil))
3949           (setf run? t))
3950         (when run?
3951           (cond
3952             ((eq (variable-enumerated-domain x) t)
3953              (local
3954                (cond
3955                  ((member t (variable-enumerated-antidomain x) :test #'eq)
3956                   (cond ((member nil (variable-enumerated-antidomain x) :test #'eq)
3957                          (fail))
3958                         (t (setf (variable-enumerated-domain x) '(nil))
3959                            (setf (variable-enumerated-antidomain x) '())
3960                            (setf (variable-value x) nil))))
3961                  ((member nil (variable-enumerated-antidomain x) :test #'eq)
3962                   (setf (variable-enumerated-domain x) '(t))
3963                   (setf (variable-enumerated-antidomain x) '())
3964                   (setf (variable-value x) t))
3965                  (t (setf (variable-enumerated-domain x) '(t nil))
3966                     (unless (null (variable-enumerated-antidomain x))
3967                       (setf (variable-enumerated-antidomain x) '()))))))
3968             ((not (every #'booleanp (variable-enumerated-domain x)))
3969              ;; note: Could do less consing if had LOCAL DELETE-IF.
3970              ;;       This would also allow checking list only once.
3971              (set-enumerated-domain!
3972               x (remove-if-not #'booleanp (variable-enumerated-domain x)))))
3973           (run-noticers x)))))
3974
3975 (defun restrict-nonboolean! (x)
3976   ;; note: X must be a variable.
3977   (unless (or (variable-possibly-integer? x)
3978               (variable-possibly-noninteger-real? x)
3979               (variable-possibly-nonreal-number? x)
3980               (variable-possibly-nonboolean-nonnumber? x))
3981     (fail))
3982   (when (and (or (eq (variable-value x) x) (not (variable? (variable-value x))))
3983              (variable-possibly-boolean? x))
3984     (local (setf (variable-possibly-boolean? x) nil))
3985     (cond ((eq (variable-enumerated-domain x) t)
3986            (local (setf (variable-enumerated-antidomain x)
3987                         (adjoin t
3988                                 (adjoin nil (variable-enumerated-antidomain x)
3989                                         :test #'eq)
3990                                 :test #'eq))))
3991           ((some #'booleanp (variable-enumerated-domain x))
3992            ;; note: Could do less consing if had LOCAL DELETE-IF.
3993            ;;       This would also allow checking list only once.
3994            (set-enumerated-domain!
3995             x (remove-if #'booleanp (variable-enumerated-domain x)))))
3996     (run-noticers x)))
3997
3998 (defun restrict-lower-bound! (x lower-bound)
3999   ;; note: X must be a variable.
4000   ;; note: LOWER-BOUND must be a real constant.
4001   (if (variable-integer? x) (setf lower-bound (ceiling lower-bound)))
4002   (when (and (or (eq (variable-value x) x) (not (variable? (variable-value x))))
4003              (or (not (variable-lower-bound x))
4004                  (> lower-bound (variable-lower-bound x))))
4005     (if (and (variable-upper-bound x) (< (variable-upper-bound x) lower-bound))
4006         (fail))
4007     (when (or (not (variable-lower-bound x))
4008               (not (variable-upper-bound x))
4009               (>= (/ (- lower-bound (variable-lower-bound x))
4010                      (- (variable-upper-bound x) (variable-lower-bound x)))
4011                   *minimum-shrink-ratio*))
4012       (local (setf (variable-lower-bound x) lower-bound))
4013       (cond ((eq (variable-enumerated-domain x) t)
4014              (if (and lower-bound
4015                       (variable-upper-bound x)
4016                       (variable-integer? x)
4017                       (or (null *maximum-discretization-range*)
4018                           (<= (- (variable-upper-bound x) lower-bound)
4019                               *maximum-discretization-range*)))
4020                  (set-enumerated-domain!
4021                   x (all-values (an-integer-between lower-bound
4022                                                     (variable-upper-bound x))))))
4023             ((some #'(lambda (element) (< element lower-bound))
4024                    (variable-enumerated-domain x))
4025              ;; note: Could do less consing if had LOCAL DELETE-IF.
4026              ;;       This would also allow checking list only once.
4027              (set-enumerated-domain!
4028               x (remove-if #'(lambda (element) (< element lower-bound))
4029                            (variable-enumerated-domain x)))))
4030       (run-noticers x))))
4031
4032 (defun restrict-upper-bound! (x upper-bound)
4033   ;; note: X must be a variable.
4034   ;; note: UPPER-BOUND must be a real constant.
4035   (when (variable-integer? x)
4036     (setf upper-bound (floor upper-bound)))
4037   (when (and (or (eq (variable-value x) x) (not (variable? (variable-value x))))
4038              (or (not (variable-upper-bound x))
4039                  (< upper-bound (variable-upper-bound x))))
4040     (when (and (variable-lower-bound x) (> (variable-lower-bound x) upper-bound))
4041       (fail))
4042     (when (or (not (variable-lower-bound x))
4043               (not (variable-upper-bound x))
4044               (>= (/ (- (variable-upper-bound x) upper-bound)
4045                      (- (variable-upper-bound x) (variable-lower-bound x)))
4046                   *minimum-shrink-ratio*))
4047       (local (setf (variable-upper-bound x) upper-bound))
4048       (cond ((eq (variable-enumerated-domain x) t)
4049              (when (and (variable-lower-bound x)
4050                         upper-bound
4051                         (variable-integer? x)
4052                         (or (null *maximum-discretization-range*)
4053                             (<= (- upper-bound (variable-lower-bound x))
4054                                 *maximum-discretization-range*)))
4055                (set-enumerated-domain!
4056                 x (all-values (an-integer-between (variable-lower-bound x)
4057                                                   upper-bound)))))
4058             ((some #'(lambda (element) (> element upper-bound))
4059                    (variable-enumerated-domain x))
4060              ;; note: Could do less consing if had LOCAL DELETE-IF.
4061              ;;       This would also allow checking list only once.
4062              (set-enumerated-domain!
4063               x (remove-if #'(lambda (element) (> element upper-bound))
4064                            (variable-enumerated-domain x)))))
4065       (run-noticers x))))
4066
4067 (defun restrict-bounds! (x lower-bound upper-bound)
4068   ;; note: X must be a variable.
4069   ;; note: LOWER-BOUND and UPPER-BOUND must be real constants.
4070   (when (variable-integer? x)
4071     (if lower-bound (setf lower-bound (ceiling lower-bound)))
4072     (if upper-bound (setf upper-bound (floor upper-bound))))
4073   (if (or (eq (variable-value x) x) (not (variable? (variable-value x))))
4074       (let ((run? nil))
4075         (when (and lower-bound
4076                    (or (not (variable-lower-bound x))
4077                        (> lower-bound (variable-lower-bound x))))
4078           (if (and (variable-upper-bound x)
4079                    (< (variable-upper-bound x) lower-bound))
4080               (fail))
4081           (when (or (not (variable-lower-bound x))
4082                     (not (variable-upper-bound x))
4083                     (>= (/ (- lower-bound (variable-lower-bound x))
4084                            (- (variable-upper-bound x) (variable-lower-bound x)))
4085                         *minimum-shrink-ratio*))
4086             (local (setf (variable-lower-bound x) lower-bound))
4087             (setf run? t)))
4088         (when (and upper-bound
4089                    (or (not (variable-upper-bound x))
4090                        (< upper-bound (variable-upper-bound x))))
4091           (if (and (variable-lower-bound x)
4092                    (> (variable-lower-bound x) upper-bound))
4093               (fail))
4094           (when (or (not (variable-lower-bound x))
4095                     (not (variable-upper-bound x))
4096                     (>= (/ (- (variable-upper-bound x) upper-bound)
4097                            (- (variable-upper-bound x) (variable-lower-bound x)))
4098                         *minimum-shrink-ratio*))
4099             (local (setf (variable-upper-bound x) upper-bound))
4100             (setf run? t)))
4101         (when run?
4102           (cond ((eq (variable-enumerated-domain x) t)
4103                  (if (and (variable-lower-bound x)
4104                           (variable-upper-bound x)
4105                           (variable-integer? x)
4106                           (or (null *maximum-discretization-range*)
4107                               (<= (- (variable-upper-bound x)
4108                                      (variable-lower-bound x))
4109                                   *maximum-discretization-range*)))
4110                      (set-enumerated-domain!
4111                       x (all-values (an-integer-between
4112                                      (variable-lower-bound x)
4113                                      (variable-upper-bound x))))))
4114                 ((or (and lower-bound
4115                           (some #'(lambda (element) (< element lower-bound))
4116                                 (variable-enumerated-domain x)))
4117                      (and upper-bound
4118                           (some #'(lambda (element) (> element upper-bound))
4119                                 (variable-enumerated-domain x))))
4120                  ;; note: Could do less consing if had LOCAL DELETE-IF.
4121                  ;;       This would also allow checking list only once.
4122                  (set-enumerated-domain!
4123                   x (remove-if #'(lambda (element)
4124                                    (or (and lower-bound (< element lower-bound))
4125                                        (and upper-bound (> element upper-bound))))
4126                                (variable-enumerated-domain x)))))
4127           (run-noticers x)))))
4128
4129 (defun share! (x y)
4130   ;; note: X and Y must be variables such that (EQ X (VALUE-OF X)) and
4131   ;;       (EQ Y (VALUE-OF Y)).
4132   (let ((run? nil)
4133         (y-lower-bound? nil)
4134         (y-upper-bound? nil)
4135         (x-lower-bound (variable-lower-bound x))
4136         (x-upper-bound (variable-upper-bound x))
4137         (y-lower-bound (variable-lower-bound y))
4138         (y-upper-bound (variable-upper-bound y)))
4139     (cond ((and (variable-integer? y) (not (variable-integer? x)))
4140            (if x-lower-bound (setf x-lower-bound (ceiling x-lower-bound)))
4141            (if x-upper-bound (setf x-upper-bound (floor x-upper-bound))))
4142           ((and (not (variable-integer? y)) (variable-integer? x))
4143            (when (and y-lower-bound (not (integerp y-lower-bound)))
4144              (setf y-lower-bound (ceiling y-lower-bound))
4145              (setf y-lower-bound? t))
4146            (when (and y-upper-bound (not (integerp y-upper-bound)))
4147              (setf y-upper-bound (floor y-upper-bound))
4148              (setf y-upper-bound? t))))
4149     (when (and (not (variable-possibly-integer? x))
4150                (variable-possibly-integer? y))
4151       (local (setf (variable-possibly-integer? y) nil))
4152       (setf run? t))
4153     (when (and (not (variable-possibly-noninteger-real? x))
4154                (variable-possibly-noninteger-real? y))
4155       (local (setf (variable-possibly-noninteger-real? y) nil))
4156       (setf run? t))
4157     (when (and (not (variable-possibly-nonreal-number? x))
4158                (variable-possibly-nonreal-number? y))
4159       (local (setf (variable-possibly-nonreal-number? y) nil))
4160       (setf run? t))
4161     (when (and (not (variable-possibly-boolean? x))
4162                (variable-possibly-boolean? y))
4163       (local (setf (variable-possibly-boolean? y) nil))
4164       (setf run? t))
4165     (when (and (not (variable-possibly-nonboolean-nonnumber? x))
4166                (variable-possibly-nonboolean-nonnumber? y))
4167       (local (setf (variable-possibly-nonboolean-nonnumber? y) nil))
4168       (setf run? t))
4169     (unless (or (variable-possibly-integer? y)
4170                 (variable-possibly-noninteger-real? y)
4171                 (variable-possibly-nonreal-number? y)
4172                 (variable-possibly-boolean? y)
4173                 (variable-possibly-nonboolean-nonnumber? y))
4174       (fail))
4175     (cond ((and x-lower-bound
4176                 (or (not y-lower-bound) (> x-lower-bound y-lower-bound)))
4177            (local (setf (variable-lower-bound y) x-lower-bound))
4178            (setf run? t))
4179           (y-lower-bound?
4180            (local (setf (variable-lower-bound y) y-lower-bound))
4181            (setf run? t)))
4182     (cond ((and x-upper-bound
4183                 (or (not y-upper-bound) (< x-upper-bound y-upper-bound)))
4184            (local (setf (variable-upper-bound y) x-upper-bound))
4185            (setf run? t))
4186           (y-upper-bound?
4187            (local (setf (variable-upper-bound y) y-upper-bound))
4188            (setf run? t)))
4189     (unless (or (null (variable-lower-bound y))
4190                 (null (variable-upper-bound y))
4191                 (< (variable-lower-bound y) (variable-upper-bound y)))
4192       (fail))
4193     (if run?
4194         (let ((lower-bound (variable-lower-bound y))
4195               (upper-bound (variable-upper-bound y)))
4196           (if (eq (variable-enumerated-domain y) t)
4197               (if (and lower-bound
4198                        upper-bound
4199                        (variable-integer? y)
4200                        (or (null *maximum-discretization-range*)
4201                            (<= (- upper-bound lower-bound)
4202                                *maximum-discretization-range*)))
4203                   (set-enumerated-domain!
4204                    y (all-values (an-integer-between lower-bound upper-bound))))
4205               (if lower-bound
4206                   (if upper-bound
4207                       (if (some #'(lambda (element)
4208                                     (or (< element lower-bound)
4209                                         (> element upper-bound)))
4210                                 (variable-enumerated-domain y))
4211                           ;; note: Could do less consing if had LOCAL DELETE-IF.
4212                           ;;       This would also allow checking list only once.
4213                           (set-enumerated-domain!
4214                            y (remove-if #'(lambda (element)
4215                                             (or (< element lower-bound)
4216                                                 (> element upper-bound)))
4217                                         (variable-enumerated-domain y))))
4218                       (if (some #'(lambda (element) (< element lower-bound))
4219                                 (variable-enumerated-domain y))
4220                           ;; note: Could do less consing if had LOCAL DELETE-IF.
4221                           ;;       This would also allow checking list only once.
4222                           (set-enumerated-domain!
4223                            y (remove-if #'(lambda (element)
4224                                             (< element lower-bound))
4225                                         (variable-enumerated-domain y)))))
4226                   (if upper-bound
4227                       (if (some #'(lambda (element) (> element upper-bound))
4228                                 (variable-enumerated-domain y))
4229                           ;; note: Could do less consing if had LOCAL DELETE-IF.
4230                           ;;       This would also allow checking list only once.
4231                           (set-enumerated-domain!
4232                            y (remove-if #'(lambda (element)
4233                                             (> element upper-bound))
4234                                         (variable-enumerated-domain y)))))))))
4235     (local (let* ((enumerated-domain
4236                    (cond
4237                      ((eq (variable-enumerated-domain x) t)
4238                       (if (eq (variable-enumerated-domain y) t)
4239                           t
4240                           (set-difference (variable-enumerated-domain y)
4241                                           (variable-enumerated-antidomain x)
4242                                           :test #'equal)))
4243                      ((eq (variable-enumerated-domain y) t)
4244                       (set-difference (variable-enumerated-domain x)
4245                                       (variable-enumerated-antidomain y)
4246                                       :test #'equal))
4247                      (t (intersection (variable-enumerated-domain x)
4248                                       (variable-enumerated-domain y)
4249                                       :test #'equal))))
4250                   (enumerated-antidomain
4251                    (if (eq enumerated-domain t)
4252                        (union (variable-enumerated-antidomain x)
4253                               (variable-enumerated-antidomain y)
4254                               :test #'equal)
4255                        '())))
4256              (if (null enumerated-domain) (fail))
4257              (if (and (not (eq enumerated-domain t))
4258                       (or (eq (variable-enumerated-domain y) t)
4259                           (< (length enumerated-domain)
4260                              (length (variable-enumerated-domain y)))))
4261                  (setf (variable-enumerated-domain y) enumerated-domain))
4262              (if (if (eq enumerated-domain t)
4263                      (> (length enumerated-antidomain)
4264                         (length (variable-enumerated-antidomain y)))
4265                      (not (null (variable-enumerated-antidomain y))))
4266                  (setf (variable-enumerated-antidomain y) enumerated-antidomain)))
4267            (setf (variable-noticers y)
4268                  (append (variable-noticers y) (variable-noticers x)))
4269            (setf (variable-noticers x) '())
4270            (setf (variable-value x) y))
4271     (run-noticers y)))
4272
4273 (defun restrict-value! (x value)
4274   ;; note: X must be a variable such that (EQ X (VALUE-OF X)).
4275   ;; note: VALUE must not be a variable.
4276   (if (occurs-in? x value) (fail))
4277   (typecase value
4278     (integer (unless (variable-possibly-integer? x) (fail)))
4279     (real (unless (variable-possibly-noninteger-real? x) (fail)))
4280     (number (unless (variable-possibly-nonreal-number? x) (fail)))
4281     (boolean (unless (variable-possibly-boolean? x) (fail)))
4282     (otherwise (unless (variable-possibly-nonboolean-nonnumber? x) (fail))))
4283   ;; needs work: This is sound only if VALUE does not contain any variables.
4284   (if (eq (variable-enumerated-domain x) t)
4285       (if (member value (variable-enumerated-antidomain x) :test #'equal)
4286           (fail))
4287       (unless (member value (variable-enumerated-domain x) :test #'equal)
4288         (fail)))
4289   (if (and (realp value)
4290            (or (and (variable-lower-bound x)
4291                     (< value (variable-lower-bound x)))
4292                (and (variable-upper-bound x)
4293                     (> value (variable-upper-bound x)))))
4294       (fail))
4295   (local (setf (variable-value x) value)
4296          (typecase value
4297            (integer (if (variable-possibly-noninteger-real? x)
4298                         (setf (variable-possibly-noninteger-real? x) nil))
4299                     (if (variable-possibly-nonreal-number? x)
4300                         (setf (variable-possibly-nonreal-number? x) nil))
4301                     (if (variable-possibly-boolean? x)
4302                         (setf (variable-possibly-boolean? x) nil))
4303                     (if (variable-possibly-nonboolean-nonnumber? x)
4304                         (setf (variable-possibly-nonboolean-nonnumber? x) nil))
4305                     (if (or (null (variable-lower-bound x))
4306                             (not (integerp (variable-lower-bound x)))
4307                             (> value (variable-lower-bound x)))
4308                         (setf (variable-lower-bound x) value))
4309                     (if (or (null (variable-upper-bound x))
4310                             (not (integerp (variable-upper-bound x)))
4311                             (< value (variable-upper-bound x)))
4312                         (setf (variable-upper-bound x) value)))
4313            (real (if (variable-possibly-integer? x)
4314                      (setf (variable-possibly-integer? x) nil))
4315                  (if (variable-possibly-nonreal-number? x)
4316                      (setf (variable-possibly-nonreal-number? x) nil))
4317                  (if (variable-possibly-boolean? x)
4318                      (setf (variable-possibly-boolean? x) nil))
4319                  (if (variable-possibly-nonboolean-nonnumber? x)
4320                      (setf (variable-possibly-nonboolean-nonnumber? x) nil))
4321                  (if (or (null (variable-lower-bound x))
4322                          (> value (variable-lower-bound x)))
4323                      (setf (variable-lower-bound x) value))
4324                  (if (or (null (variable-upper-bound x))
4325                          (< value (variable-upper-bound x)))
4326                      (setf (variable-upper-bound x) value)))
4327            (number (if (variable-possibly-integer? x)
4328                        (setf (variable-possibly-integer? x) nil))
4329                    (if (variable-possibly-noninteger-real? x)
4330                        (setf (variable-possibly-noninteger-real? x) nil))
4331                    (if (variable-possibly-boolean? x)
4332                        (setf (variable-possibly-boolean? x) nil))
4333                    (if (variable-possibly-nonboolean-nonnumber? x)
4334                        (setf (variable-possibly-nonboolean-nonnumber? x) nil)))
4335            (boolean (if (variable-possibly-integer? x)
4336                         (setf (variable-possibly-integer? x) nil))
4337                     (if (variable-possibly-noninteger-real? x)
4338                         (setf (variable-possibly-noninteger-real? x) nil))
4339                     (if (variable-possibly-nonreal-number? x)
4340                         (setf (variable-possibly-nonreal-number? x) nil))
4341                     (if (variable-possibly-nonboolean-nonnumber? x)
4342                         (setf (variable-possibly-nonboolean-nonnumber? x) nil)))
4343            (otherwise (if (variable-possibly-integer? x)
4344                           (setf (variable-possibly-integer? x) nil))
4345                       (if (variable-possibly-noninteger-real? x)
4346                           (setf (variable-possibly-noninteger-real? x) nil))
4347                       (if (variable-possibly-nonreal-number? x)
4348                           (setf (variable-possibly-nonreal-number? x) nil))
4349                       (if (variable-possibly-boolean? x)
4350                           (setf (variable-possibly-boolean? x) nil))))
4351          (cond ((eq (variable-enumerated-domain x) t)
4352                 ;; needs work: This is sound only if VALUE does not contain any
4353                 ;;             variables.
4354                 (setf (variable-enumerated-domain x) (list value))
4355                 (setf (variable-enumerated-antidomain x) '()))
4356                ((not (null (rest (variable-enumerated-domain x))))
4357                 ;; needs work: This is sound only if VALUE does not contain any
4358                 ;;             variables.
4359                 (setf (variable-enumerated-domain x) (list value)))))
4360   (run-noticers x))
4361
4362 (defun restrict-true! (x)
4363   ;; note: X must be a Boolean variable.
4364   (if (eq (variable-value x) nil) (fail))
4365   (when (eq (variable-value x) x)
4366     (local (setf (variable-value x) t)
4367            (setf (variable-enumerated-domain x) '(t)))
4368     (run-noticers x)))
4369
4370 (defun restrict-false! (x)
4371   ;; note: X must be a Boolean variable.
4372   (if (eq (variable-value x) t) (fail))
4373   (when (eq (variable-value x) x)
4374     (local (setf (variable-value x) nil)
4375            (setf (variable-enumerated-domain x) '(nil)))
4376     (run-noticers x)))
4377
4378 (defun set-enumerated-domain! (x enumerated-domain)
4379   ;; note: X must be a variable such that (EQ X (VALUE-OF X)).
4380   ;; note: All callers must insure that the new ENUMERATED-DOMAIN is a subset
4381   ;;       of the old one.
4382   (if (null enumerated-domain) (fail))
4383   (local
4384     (cond
4385       ((eq (variable-enumerated-domain x) t)
4386        (setf (variable-enumerated-domain x) enumerated-domain)
4387        (unless (null (variable-enumerated-antidomain x))
4388          (setf (variable-enumerated-antidomain x) '()))
4389        (if (and (variable-possibly-boolean? x)
4390                 (not (some #'booleanp enumerated-domain)))
4391            (setf (variable-possibly-boolean? x) nil))
4392        (if (and (variable-possibly-nonboolean-nonnumber? x)
4393                 (not (some #'(lambda (x)
4394                                (and (not (booleanp x)) (not (numberp x))))
4395                            enumerated-domain)))
4396            (setf (variable-possibly-nonboolean-nonnumber? x) nil))
4397        (if (and (variable-possibly-nonreal-number? x)
4398                 (not (some #'(lambda (x) (and (not (realp x)) (numberp x)))
4399                            enumerated-domain)))
4400            (setf (variable-possibly-nonreal-number? x) nil))
4401        (if (and (variable-possibly-noninteger-real? x)
4402                 (not (some #'(lambda (x) (and (not (integerp x)) (realp x)))
4403                            enumerated-domain)))
4404            (setf (variable-possibly-noninteger-real? x) nil))
4405        (if (and (variable-possibly-integer? x)
4406                 (not (some #'integerp enumerated-domain)))
4407            (setf (variable-possibly-integer? x) nil))
4408        (if (variable-real? x)
4409            (let ((lower-bound (reduce #'min enumerated-domain))
4410                  (upper-bound (reduce #'max enumerated-domain)))
4411              (if (or (null (variable-lower-bound x))
4412                      (> lower-bound (variable-lower-bound x)))
4413                  (setf (variable-lower-bound x) lower-bound))
4414              (if (or (null (variable-upper-bound x))
4415                      (< upper-bound (variable-upper-bound x)))
4416                  (setf (variable-upper-bound x) upper-bound))))
4417        (if (null (rest enumerated-domain))
4418            (setf (variable-value x) (first enumerated-domain)))
4419        t)
4420       ((< (length enumerated-domain) (length (variable-enumerated-domain x)))
4421        (setf (variable-enumerated-domain x) enumerated-domain)
4422        (if (and (variable-possibly-boolean? x)
4423                 (not (some #'booleanp enumerated-domain)))
4424            (setf (variable-possibly-boolean? x) nil))
4425        (if (and (variable-possibly-nonboolean-nonnumber? x)
4426                 (not (some #'(lambda (x)
4427                                (and (not (booleanp x)) (not (numberp x))))
4428                            enumerated-domain)))
4429            (setf (variable-possibly-nonboolean-nonnumber? x) nil))
4430        (if (and (variable-possibly-nonreal-number? x)
4431                 (not (some #'(lambda (x) (and (not (realp x)) (numberp x)))
4432                            enumerated-domain)))
4433            (setf (variable-possibly-nonreal-number? x) nil))
4434        (if (and (variable-possibly-noninteger-real? x)
4435                 (not (some #'(lambda (x) (and (not (integerp x)) (realp x)))
4436                            enumerated-domain)))
4437            (setf (variable-possibly-noninteger-real? x) nil))
4438        (if (and (variable-possibly-integer? x)
4439                 (not (some #'integerp enumerated-domain)))
4440            (setf (variable-possibly-integer? x) nil))
4441        (if (variable-real? x)
4442            (let ((lower-bound (reduce #'min enumerated-domain))
4443                  (upper-bound (reduce #'max enumerated-domain)))
4444              (if (or (null (variable-lower-bound x))
4445                      (> lower-bound (variable-lower-bound x)))
4446                  (setf (variable-lower-bound x) lower-bound))
4447              (if (or (null (variable-upper-bound x))
4448                      (< upper-bound (variable-upper-bound x)))
4449                  (setf (variable-upper-bound x) upper-bound))))
4450        (if (null (rest enumerated-domain))
4451            (setf (variable-value x) (first enumerated-domain)))
4452        t)
4453       (t nil))))
4454
4455 (defun restrict-enumerated-domain! (x enumerated-domain)
4456   ;; note: X must be a variable such that (EQ X (VALUE-OF X)).
4457   ;; note: ENUMERATED-DOMAIN must not be a variable.
4458   (unless (typep enumerated-domain 'sequence) (fail))
4459   (when (every #'ground? enumerated-domain)
4460     (setf enumerated-domain
4461           (remove-duplicates (map 'list #'eliminate-variables enumerated-domain)
4462                              :test #'equal))
4463     (unless (variable-possibly-boolean? x)
4464       (setf enumerated-domain (remove-if #'booleanp enumerated-domain)))
4465     (unless (variable-possibly-nonboolean-nonnumber? x)
4466       (setf enumerated-domain
4467             (remove-if #'(lambda (x) (and (not (booleanp x)) (not (numberp x))))
4468                        enumerated-domain)))
4469     (unless (variable-possibly-nonreal-number? x)
4470       (setf enumerated-domain
4471             (remove-if #'(lambda (x) (and (not (realp x)) (numberp x)))
4472                        enumerated-domain)))
4473     (unless (variable-possibly-noninteger-real? x)
4474       (setf enumerated-domain
4475             (remove-if #'(lambda (x) (and (not (integerp x)) (realp x)))
4476                        enumerated-domain)))
4477     (unless (variable-possibly-integer? x)
4478       (setf enumerated-domain (remove-if #'integerp enumerated-domain)))
4479     (if (variable-upper-bound x)
4480         (let ((upper-bound (variable-upper-bound x)))
4481           (setf enumerated-domain
4482                 (remove-if #'(lambda (element) (> element upper-bound))
4483                            enumerated-domain))))
4484     (if (variable-lower-bound x)
4485         (let ((lower-bound (variable-lower-bound x)))
4486           (setf enumerated-domain
4487                 (remove-if #'(lambda (element) (< element lower-bound))
4488                            enumerated-domain))))
4489     (setf enumerated-domain
4490           (if (eq (variable-enumerated-domain x) t)
4491               (set-difference enumerated-domain
4492                               (variable-enumerated-antidomain x)
4493                               :test #'equal)
4494               (intersection (variable-enumerated-domain x) enumerated-domain
4495                             :test #'equal)))
4496     (if (set-enumerated-domain! x enumerated-domain) (run-noticers x))))
4497
4498 (defun restrict-enumerated-antidomain! (x enumerated-antidomain)
4499   ;; note: X must be a variable such that (EQ X (VALUE-OF X)).
4500   ;; note: ENUMERATED-ANTIDOMAIN must not be a variable.
4501   (unless (typep enumerated-antidomain 'sequence) (fail))
4502   (when (every #'ground? enumerated-antidomain)
4503     (setf enumerated-antidomain
4504           (remove-duplicates
4505            (map 'list #'eliminate-variables enumerated-antidomain)
4506            :test #'equal))
4507     (cond
4508       ((eq (variable-enumerated-domain x) t)
4509        (setf enumerated-antidomain
4510              (union (variable-enumerated-antidomain x) enumerated-antidomain
4511                     :test #'equal))
4512        (when (> (length enumerated-antidomain)
4513                 (length (variable-enumerated-antidomain x)))
4514          (local (setf (variable-enumerated-antidomain x) enumerated-antidomain))
4515          (run-noticers x)))
4516       ((set-enumerated-domain!
4517         x (set-difference (variable-enumerated-domain x) enumerated-antidomain
4518                           :test #'equal))
4519        (run-noticers x)))))
4520
4521 ;;; Rules
4522
4523 (defun +-rule-up (z x y)
4524   (if (and (variable-integer? x) (variable-integer? y)) (restrict-integer! z))
4525   ;; note: We can't assert that Z in not an integer when either X or Y are not
4526   ;;       integers since they may be Gaussian integers. But we can if either
4527   ;;       X or Y is real. If the Screamer type system could distinguish
4528   ;;       Gaussian integers from other complex numbers we could whenever X or
4529   ;;       Y was not a Gaussian integer.
4530   (if (and (or (variable-noninteger? x) (variable-noninteger? y))
4531            (or (variable-real? x) (variable-real? y)))
4532       (restrict-noninteger! z))
4533   (if (and (variable-real? x) (variable-real? y)) (restrict-real! z))
4534   ;; note: Ditto.
4535   (if (and (or (variable-nonreal? x) (variable-nonreal? y))
4536            (or (variable-real? x) (variable-real? y)))
4537       (restrict-nonreal! z))
4538   (if (and (variable-real? x) (variable-real? y) (variable-real? z))
4539       (restrict-bounds!
4540        z
4541        (infinity-+ (variable-lower-bound x) (variable-lower-bound y))
4542        (infinity-+ (variable-upper-bound x) (variable-upper-bound y))))
4543   (let ((x (value-of x))
4544         (y (value-of y))
4545         (z (value-of z)))
4546     (if (and (not (variable? x))
4547              (not (variable? y))
4548              (not (variable? z))
4549              (/= z (+ x y)))
4550         (fail))))
4551
4552 (defun +-rule-down (z x y)
4553   ;; note: We can't assert that X and Y are integers when Z is an integer since
4554   ;;       Z may be an integer when X and Y are Gaussian integers. But we can
4555   ;;       make such an assertion if either X or Y is real. If the Screamer
4556   ;;       type system could distinguish Gaussian integers from other complex
4557   ;;       numbers we could make such an assertion whenever either X or Y was
4558   ;;       not a Gaussian integer.
4559   (if (and (variable-integer? z) (or (variable-real? x) (variable-real? y)))
4560       (restrict-integer! x))
4561   ;; note: Ditto.
4562   (if (and (variable-real? z) (or (variable-real? x) (variable-real? y)))
4563       (restrict-real! x))
4564   (if (and (variable-real? x) (variable-real? y) (variable-real? z))
4565       (restrict-bounds!
4566        x
4567        (infinity-- (variable-lower-bound z) (variable-upper-bound y))
4568        (infinity-- (variable-upper-bound z) (variable-lower-bound y))))
4569   (let ((x (value-of x))
4570         (y (value-of y))
4571         (z (value-of z)))
4572     (if (and (not (variable? x))
4573              (not (variable? y))
4574              (not (variable? z))
4575              (/= z (+ x y)))
4576         (fail))))
4577
4578 (defun /-rule (z x y)
4579   (when (and (variable-lower-bound x) (plusp (variable-lower-bound x)))
4580     (cond ((and (variable-upper-bound x) (not (zerop (variable-upper-bound x))))
4581            (if (variable-lower-bound z)
4582                (cond
4583                  ((minusp (variable-lower-bound z))
4584                   (restrict-lower-bound!
4585                    y (/ (variable-lower-bound z) (variable-lower-bound x))))
4586                  (t (restrict-lower-bound! y 0)
4587                     (restrict-lower-bound!
4588                      y (/ (variable-lower-bound z) (variable-upper-bound x))))))
4589            (if (variable-upper-bound z)
4590                (cond
4591                  ((plusp (variable-upper-bound z))
4592                   (restrict-upper-bound!
4593                    y (/ (variable-upper-bound z) (variable-lower-bound x))))
4594                  (t (restrict-upper-bound! y 0)
4595                     (restrict-upper-bound!
4596                      y (/ (variable-upper-bound z) (variable-upper-bound x)))))))
4597           (t (if (variable-lower-bound z)
4598                  (cond
4599                    ((minusp (variable-lower-bound z))
4600                     (restrict-lower-bound!
4601                      y (/ (variable-lower-bound z) (variable-lower-bound x))))
4602                    (t (restrict-lower-bound! y 0))))
4603              (if (variable-upper-bound z)
4604                  (cond
4605                    ((plusp (variable-upper-bound z))
4606                     (restrict-upper-bound!
4607                      y (/ (variable-upper-bound z) (variable-lower-bound x))))
4608                    (t (restrict-upper-bound! y 0)))))))
4609   (when (and (variable-upper-bound x) (minusp (variable-upper-bound x)))
4610     (cond ((and (variable-lower-bound x) (not (zerop (variable-lower-bound x))))
4611            (if (variable-upper-bound z)
4612                (cond
4613                  ((plusp (variable-upper-bound z))
4614                   (restrict-lower-bound!
4615                    y (/ (variable-upper-bound z) (variable-upper-bound x))))
4616                  (t (restrict-lower-bound! y 0)
4617                     (restrict-lower-bound!
4618                      y (/ (variable-upper-bound z) (variable-lower-bound x))))))
4619            (if (variable-lower-bound z)
4620                (cond
4621                  ((minusp (variable-lower-bound z))
4622                   (restrict-upper-bound!
4623                    y (/ (variable-lower-bound z) (variable-upper-bound x))))
4624                  (t (restrict-upper-bound! y 0)
4625                     (restrict-upper-bound!
4626                      y (/ (variable-lower-bound z) (variable-lower-bound x)))))))
4627           (t (if (variable-upper-bound z)
4628                  (cond
4629                    ((plusp (variable-upper-bound z))
4630                     (restrict-lower-bound!
4631                      y (/ (variable-upper-bound z) (variable-upper-bound x))))
4632                    (t (restrict-lower-bound! y 0))))
4633              (if (variable-lower-bound z)
4634                  (cond
4635                    ((minusp (variable-lower-bound z))
4636                     (restrict-upper-bound!
4637                      y (/ (variable-lower-bound z) (variable-upper-bound x))))
4638                    (t (restrict-upper-bound! y 0))))))))
4639
4640 (defun *-rule-up (z x y)
4641   (if (and (variable-integer? x) (variable-integer? y)) (restrict-integer! z))
4642   ;; note: We can't assert that Z in not an integer when either X or Y are not
4643   ;;       integers since they may be Gaussian integers. But we can if either
4644   ;;       X or Y is real. If the Screamer type system could distinguish
4645   ;;       Gaussian integers from other complex numbers we could whenever X or
4646   ;;       Y was not a Gaussian integer.
4647   (if (and (or (variable-noninteger? x) (variable-noninteger? y))
4648            (or (variable-real? x) (variable-real? y)))
4649       (restrict-noninteger! z))
4650   (if (and (variable-real? x) (variable-real? y)) (restrict-real! z))
4651   ;; note: Ditto.
4652   (if (and (or (variable-nonreal? x) (variable-nonreal? y))
4653            (or (variable-real? x) (variable-real? y)))
4654       (restrict-nonreal! z))
4655   (if (and (variable-real? x) (variable-real? y) (variable-real? z))
4656       ;; note: Can sometimes do better than the following even when ranges are
4657       ;;       not finite.
4658       (restrict-bounds!
4659        z
4660        (infinity-min
4661         (infinity-* (variable-lower-bound x) (variable-lower-bound y))
4662         (infinity-min
4663          (infinity-* (variable-lower-bound x) (variable-upper-bound y))
4664          (infinity-min
4665           (infinity-* (variable-upper-bound x) (variable-lower-bound y))
4666           (infinity-* (variable-upper-bound x) (variable-upper-bound y)))))
4667        (infinity-max
4668         (infinity-* (variable-lower-bound x) (variable-lower-bound y))
4669         (infinity-max
4670          (infinity-* (variable-lower-bound x) (variable-upper-bound y))
4671          (infinity-max
4672           (infinity-* (variable-upper-bound x) (variable-lower-bound y))
4673           (infinity-* (variable-upper-bound x) (variable-upper-bound y)))))))
4674   (let ((x (value-of x))
4675         (y (value-of y))
4676         (z (value-of z)))
4677     (if (and (not (variable? x))
4678              (not (variable? y))
4679              (not (variable? z))
4680              (/= z (* x y)))
4681         (fail))))
4682
4683 (defun *-rule-down (z x y)
4684   ;; note: We can't assert that X and Y are integers when Z is an integer since
4685   ;;       Z may be an integer when X and Y are Gaussian integers. But we can
4686   ;;       make such an assertion if either X or Y is real. If the Screamer
4687   ;;       type system could distinguish Gaussian integers from other complex
4688   ;;       numbers we could make such an assertion whenever either X or Y was
4689   ;;       not a Gaussian integer.
4690   (if (and (variable-integer? z) (or (variable-real? x) (variable-real? y)))
4691       (restrict-integer! x))
4692   ;; note: Ditto.
4693   (if (and (variable-real? z) (or (variable-real? x) (variable-real? y)))
4694       (restrict-real! x))
4695   (if (and (variable-real? x) (variable-real? y) (variable-real? z))
4696       (/-rule z y x))
4697   (let ((x (value-of x))
4698         (y (value-of y))
4699         (z (value-of z)))
4700     (if (and (not (variable? x))
4701              (not (variable? y))
4702              (not (variable? z))
4703              (/= z (* x y)))
4704         (fail))))
4705
4706 (defun min-rule-up (z x y)
4707   (if (and (variable-integer? x) (variable-integer? y)) (restrict-integer! z))
4708   (restrict-bounds!
4709    z
4710    (infinity-min (variable-lower-bound x) (variable-lower-bound y))
4711    (if (variable-upper-bound x)
4712        (if (variable-upper-bound y)
4713            (min (variable-upper-bound x) (variable-upper-bound y))
4714            (variable-upper-bound x))
4715        (variable-upper-bound y)))
4716   (let ((x (value-of x))
4717         (y (value-of y))
4718         (z (value-of z)))
4719     (if (and (not (variable? z))
4720              (not (variable? x))
4721              (not (variable? y))
4722              (/= z (min x y)))
4723         (fail))))
4724
4725 (defun min-rule-down (z x y)
4726   ;; note: The analog of the following for upper bounds, namely restricting
4727   ;;       the upper bound of either X or Y to (VARIABLE-UPPER-BOUND Z) is
4728   ;;       nondeterministic.
4729   (if (variable-lower-bound z)
4730       (restrict-lower-bound! x (variable-lower-bound z)))
4731   (let ((x (value-of x))
4732         (y (value-of y))
4733         (z (value-of z)))
4734     (if (and (not (variable? z))
4735              (not (variable? x))
4736              (not (variable? y))
4737              (/= z (min x y)))
4738         (fail))))
4739
4740 (defun max-rule-up (z x y)
4741   (if (and (variable-integer? x) (variable-integer? y)) (restrict-integer! z))
4742   (restrict-bounds!
4743    z
4744    (if (variable-lower-bound x)
4745        (if (variable-lower-bound y)
4746            (max (variable-lower-bound x) (variable-lower-bound y))
4747            (variable-lower-bound x))
4748        (variable-lower-bound y))
4749    (infinity-max (variable-upper-bound x) (variable-upper-bound y)))
4750   (let ((x (value-of x))
4751         (y (value-of y))
4752         (z (value-of z)))
4753     (if (and (not (variable? z))
4754              (not (variable? x))
4755              (not (variable? y))
4756              (/= z (max x y)))
4757         (fail))))
4758
4759 (defun max-rule-down (z x y)
4760   ;; note: The analog of the following for lower bounds, namely restricting
4761   ;;       the lower bound of either X or Y to (VARIABLE-LOWER-BOUND Z) is
4762   ;;       nondeterministic.
4763   (if (variable-upper-bound z)
4764       (restrict-upper-bound! x (variable-upper-bound z)))
4765   (let ((x (value-of x))
4766         (y (value-of y))
4767         (z (value-of z)))
4768     (if (and (not (variable? z))
4769              (not (variable? x))
4770              (not (variable? y))
4771              (/= z (max x y)))
4772         (fail))))
4773
4774 (defun =-rule (x y)
4775   (cond
4776     ;; note: I forget why +-RULE *-RULE MIN-RULE and MAX-RULE must perform the
4777     ;;       check in the second COND clause irrespective of whether the first
4778     ;;       clause is executed.
4779     ((and (variable-real? x) (variable-real? y))
4780      (restrict-bounds! x (variable-lower-bound y) (variable-upper-bound y))
4781      (restrict-bounds! y (variable-lower-bound x) (variable-upper-bound x)))
4782     ((and (not (variable? x)) (not (variable? y)) (/= x y)) (fail))))
4783
4784 (defun <=-rule (x y)
4785   (if (variable-lower-bound x)
4786       (restrict-lower-bound! y (variable-lower-bound x)))
4787   (if (variable-upper-bound y)
4788       (restrict-upper-bound! x (variable-upper-bound y))))
4789
4790 (defun <-rule (x y)
4791   (if (variable-lower-bound x)
4792       (restrict-lower-bound! y (if (variable-integer? y)
4793                                    (1+ (floor (variable-lower-bound x)))
4794                                    (variable-lower-bound x))))
4795   (if (variable-upper-bound y)
4796       (restrict-upper-bound! x (if (variable-integer? x)
4797                                    (1- (ceiling (variable-upper-bound y)))
4798                                    (variable-upper-bound y))))
4799   (let ((x (value-of x))
4800         (y (value-of y)))
4801     (if (and (not (variable? x)) (not (variable? y)) (>= x y)) (fail))))
4802
4803 (defun /=-rule (x y)
4804   ;; note: Got rid of the nondeterministic version of /=-RULE.
4805   (let ((x (value-of x))
4806         (y (value-of y)))
4807     (if (and (not (variable? x)) (not (variable? y)) (= x y)) (fail))))
4808
4809 ;;; Lifted Arithmetic Functions (Two argument optimized)
4810
4811 (defun +v2 (x y)
4812   (assert!-numberpv x)
4813   (assert!-numberpv y)
4814   ;; needs work: The first two optimizations below violate CommonLisp type
4815   ;;             propagation conventions.
4816   (cond ((and (bound? x) (zerop (value-of x))) (value-of y))
4817         ((and (bound? y) (zerop (value-of y))) (value-of x))
4818         ((and (bound? x) (bound? y)) (+ (value-of x) (value-of y)))
4819         (t (let ((x (variablize x))
4820                  (y (variablize y))
4821                  (z (a-numberv)))
4822              (attach-noticer!
4823               #'(lambda () (+-rule-up z x y) (+-rule-down z y x)) x)
4824              (attach-noticer!
4825               #'(lambda () (+-rule-up z x y) (+-rule-down z x y)) y)
4826              (attach-noticer!
4827               #'(lambda () (+-rule-down z x y) (+-rule-down z y x)) z)
4828              z))))
4829
4830 (defun -v2 (x y)
4831   (assert!-numberpv x)
4832   (assert!-numberpv y)
4833   ;; needs work: The first optimization below violates CommonLisp type
4834   ;;             propagation conventions.
4835   (cond ((and (bound? y) (zerop (value-of y))) (value-of x))
4836         ((and (bound? x) (bound? y)) (- (value-of x) (value-of y)))
4837         (t (let ((x (variablize x))
4838                  (y (variablize y))
4839                  (z (a-numberv)))
4840              (attach-noticer!
4841               #'(lambda () (+-rule-down x y z) (+-rule-down x z y)) x)
4842              (attach-noticer!
4843               #'(lambda () (+-rule-up x y z) (+-rule-down x z y)) y)
4844              (attach-noticer!
4845               #'(lambda () (+-rule-up x y z) (+-rule-down x y z)) z)
4846              z))))
4847
4848 (defun *v2 (x y)
4849   (assert!-numberpv x)
4850   (assert!-numberpv y)
4851   ;; needs work: The first four optimizations below violate CommonLisp type
4852   ;;             propagation conventions.
4853   (cond ((and (bound? x) (zerop (value-of x))) 0)
4854         ((and (bound? y) (zerop (value-of y))) 0)
4855         ((and (bound? x) (= (value-of x) 1)) (value-of y))
4856         ((and (bound? y) (= (value-of y) 1)) (value-of x))
4857         ((and (bound? x) (bound? y)) (* (value-of x) (value-of y)))
4858         (t (let ((x (variablize x))
4859                  (y (variablize y))
4860                  (z (a-numberv)))
4861              (attach-noticer!
4862               #'(lambda () (*-rule-up z x y) (*-rule-down z y x)) x)
4863              (attach-noticer!
4864               #'(lambda () (*-rule-up z x y) (*-rule-down z x y)) y)
4865              (attach-noticer!
4866               #'(lambda () (*-rule-down z x y) (*-rule-down z y x)) z)
4867              z))))
4868
4869 (defun /v2 (x y)
4870   (assert!-numberpv x)
4871   (assert!-numberpv y)
4872   ;; needs work: The first three optimizations below violate CommonLisp type
4873   ;;             propagation conventions.
4874   (cond ((and (bound? x) (zerop (value-of x))) 0)
4875         ((and (bound? y) (zerop (value-of y))) (fail))
4876         ((and (bound? y) (= (value-of y) 1)) (value-of x))
4877         ((and (bound? x) (bound? y)) (/ (value-of x) (value-of y)))
4878         (t (let ((x (variablize x))
4879                  (y (variablize y))
4880                  (z (a-numberv)))
4881              (attach-noticer!
4882               #'(lambda () (*-rule-down x y z) (*-rule-down x z y)) x)
4883              (attach-noticer!
4884               #'(lambda () (*-rule-up x y z) (*-rule-down x z y)) y)
4885              (attach-noticer!
4886               #'(lambda () (*-rule-up x y z) (*-rule-down x y z)) z)
4887              z))))
4888
4889 (defun minv2 (x y)
4890   (assert!-realpv x)
4891   (assert!-realpv y)
4892   (cond ((known?-<=v2-internal x y) (value-of x))
4893         ((known?-<=v2-internal y x) (value-of y))
4894         (t (let ((x (variablize x))
4895                  (y (variablize y))
4896                  (z (a-realv)))
4897              (attach-noticer!
4898               #'(lambda () (min-rule-up z x y) (min-rule-down z y x)) x)
4899              (attach-noticer!
4900               #'(lambda () (min-rule-up z x y) (min-rule-down z x y)) y)
4901              (attach-noticer!
4902               #'(lambda () (min-rule-down z x y) (min-rule-down z y x)) z)
4903              z))))
4904
4905 (defun maxv2 (x y)
4906   (assert!-realpv x)
4907   (assert!-realpv y)
4908   (cond ((known?-<=v2-internal y x) (value-of x))
4909         ((known?-<=v2-internal x y) (value-of y))
4910         (t (let ((x (variablize x))
4911                  (y (variablize y))
4912                  (z (a-realv)))
4913              (attach-noticer!
4914               #'(lambda () (max-rule-up z x y) (max-rule-down z y x)) x)
4915              (attach-noticer!
4916               #'(lambda () (max-rule-up z x y) (max-rule-down z x y)) y)
4917              (attach-noticer!
4918               #'(lambda () (max-rule-down z x y) (max-rule-down z y x)) z)
4919              z))))
4920
4921 ;;; Lifted Type Functions (KNOWN? optimized)
4922
4923 (defun known?-integerpv (x)
4924   (let ((x (value-of x)))
4925     (typecase x
4926       (integer t)
4927       (variable (variable-integer? x))
4928       (otherwise nil))))
4929
4930 (defun known?-notv-integerpv (x)
4931   (let ((x (value-of x)))
4932     (typecase x
4933       (integer nil)
4934       (variable (variable-noninteger? x))
4935       (otherwise t))))
4936
4937 (defun known?-realpv (x)
4938   (let ((x (value-of x)))
4939     (typecase x
4940       (real t)
4941       (variable (variable-real? x))
4942       (otherwise nil))))
4943
4944 (defun known?-notv-realpv (x)
4945   (let ((x (value-of x)))
4946     (typecase x
4947       (real nil)
4948       (variable (variable-nonreal? x))
4949       (otherwise t))))
4950
4951 (defun known?-numberpv (x)
4952   (let ((x (value-of x)))
4953     (typecase x
4954       (number t)
4955       (variable (variable-number? x))
4956       (otherwise nil))))
4957
4958 (defun known?-notv-numberpv (x)
4959   (let ((x (value-of x)))
4960     (typecase x
4961       (number nil)
4962       (variable (variable-nonnumber? x))
4963       (otherwise t))))
4964
4965 (defun known?-booleanpv (x)
4966   (let ((x (value-of x)))
4967     (typecase x
4968       (boolean t)
4969       (variable (variable-boolean? x))
4970       (otherwise nil))))
4971
4972 (defun known?-notv-booleanpv (x)
4973   (let ((x (value-of x)))
4974     (typecase x
4975       (boolean nil)
4976       (variable (variable-nonboolean? x))
4977       (otherwise t))))
4978
4979 ;;; Lifted Arithmetic Comparison Functions (Two argument KNOWN? optimized)
4980
4981 (defun known?-<=v2-variable (x y)
4982   (and (variable-upper-bound x)
4983        (variable-lower-bound y)
4984        (<= (variable-upper-bound x) (variable-lower-bound y))))
4985
4986 (defun known?-<v2-variable (x y)
4987   (and (variable-upper-bound x)
4988        (variable-lower-bound y)
4989        (< (variable-upper-bound x) (variable-lower-bound y))))
4990
4991 (defun known?-=v2-variable (x y)
4992   (or (and (variable-real? x)
4993            (variable-real? y)
4994            (known?-<=v2-variable x y)
4995            (known?-<=v2-variable y x))
4996       (and (not (eq x (variable-value x)))
4997            (not (eq y (variable-value y)))
4998            (= (variable-value x) (variable-value y)))))
4999
5000 (defun known?-/=v2-variable (x y)
5001   (or (and (variable-real? x)
5002            (variable-real? y)
5003            (or (known?-<v2-variable x y) (known?-<v2-variable y x)))
5004       (and (not (eq x (variable-value x)))
5005            (not (eq y (variable-value y)))
5006            (/= (variable-value x) (variable-value y)))))
5007
5008 (defun known?-=v2-internal (x y)
5009   (known?-=v2-variable (variablize x) (variablize y)))
5010
5011 (defun known?-<=v2-internal (x y)
5012   (known?-<=v2-variable (variablize x) (variablize y)))
5013
5014 (defun known?-<v2-internal (x y)
5015   (known?-<v2-variable (variablize x) (variablize y)))
5016
5017 (defun known?-/=v2-internal (x y)
5018   (known?-/=v2-variable (variablize x) (variablize y)))
5019
5020 (defun known?-=v2 (x y)
5021   (assert!-numberpv x)
5022   (assert!-numberpv y)
5023   (known?-=v2-internal x y))
5024
5025 (defun known?-<=v2 (x y)
5026   (assert!-realpv x)
5027   (assert!-realpv y)
5028   (known?-<=v2-internal x y))
5029
5030 (defun known?-<v2 (x y)
5031   (assert!-realpv x)
5032   (assert!-realpv y)
5033   (known?-<v2-internal x y))
5034
5035 (defun known?-/=v2 (x y)
5036   (assert!-numberpv x)
5037   (assert!-numberpv y)
5038   (known?-/=v2-internal x y))
5039
5040 ;;; Lifted Type Functions (ASSERT! optimized)
5041
5042 (defun assert!-integerpv (x)
5043   (let ((x (value-of x)))
5044     (typecase x
5045       (integer)
5046       (variable (restrict-integer! x))
5047       (otherwise (fail)))))
5048
5049 (defun assert!-notv-integerpv (x)
5050   (let ((x (value-of x)))
5051     (typecase x
5052       (integer (fail))
5053       (variable (restrict-noninteger! x))
5054       (otherwise))))
5055
5056 (defun assert!-realpv (x)
5057   (let ((x (value-of x)))
5058     (typecase x
5059       (real)
5060       (variable (restrict-real! x))
5061       (otherwise (fail)))))
5062
5063 (defun assert!-notv-realpv (x)
5064   (let ((x (value-of x)))
5065     (typecase x
5066       (real (fail))
5067       (variable (restrict-nonreal! x))
5068       (otherwise))))
5069
5070 (defun assert!-numberpv (x)
5071   (let ((x (value-of x)))
5072     (typecase x
5073       (number)
5074       (variable (restrict-number! x))
5075       (otherwise (fail)))))
5076
5077 (defun assert!-notv-numberpv (x)
5078   (let ((x (value-of x)))
5079     (typecase x
5080       (number (fail))
5081       (variable (restrict-nonnumber! x))
5082       (otherwise))))
5083
5084 (defun assert!-booleanpv (x)
5085   (let ((x (value-of x)))
5086     (typecase x
5087       (boolean)
5088       (variable (restrict-boolean! x))
5089       (otherwise (fail)))))
5090
5091 (defun assert!-notv-booleanpv (x)
5092   (let ((x (value-of x)))
5093     (typecase x
5094       (boolean (fail))
5095       (variable (restrict-nonboolean! x))
5096       (otherwise))))
5097
5098 ;;; Lifted Arithmetic Comparison Functions (Two argument ASSERT! optimized)
5099
5100 (defun assert!-=v2 (x y)
5101   (assert!-numberpv x)
5102   (assert!-numberpv y)
5103   (let ((x (variablize x))
5104         (y (variablize y)))
5105     (attach-noticer! #'(lambda () (=-rule x y)) x)
5106     (attach-noticer! #'(lambda () (=-rule x y)) y)))
5107
5108 (defun assert!-<=v2 (x y)
5109   (assert!-realpv x)
5110   (assert!-realpv y)
5111   (let ((x (variablize x))
5112         (y (variablize y)))
5113     (attach-noticer! #'(lambda () (<=-rule x y)) x)
5114     (attach-noticer! #'(lambda () (<=-rule x y)) y)))
5115
5116 (defun assert!-<v2 (x y)
5117   (assert!-realpv x)
5118   (assert!-realpv y)
5119   (let ((x (variablize x))
5120         (y (variablize y)))
5121     (attach-noticer! #'(lambda () (<-rule x y)) x)
5122     (attach-noticer! #'(lambda () (<-rule x y)) y)))
5123
5124 (defun assert!-/=v2 (x y)
5125   (assert!-numberpv x)
5126   (assert!-numberpv y)
5127   (let ((x (variablize x))
5128         (y (variablize y)))
5129     ;; note: Got rid of the nondeterministic version that called the
5130     ;;       nondeterministic version of /=-RULE.
5131     (attach-noticer! #'(lambda () (/=-rule x y)) x)
5132     (attach-noticer! #'(lambda () (/=-rule x y)) y)))
5133
5134 ;;; Lifted Type Functions
5135
5136 (defun integerpv (x)
5137   "If when INTEGERPV is called, X is known to be integer valued then
5138 INTEGERPV returns T. Alternatively, if when INTEGERPV is called, X is
5139 known to be non-integer valued then INTEGERPV returns NIL. If it is
5140 not known whether or not X is integer valued when INTEGERPV is called
5141 then INTEGERPV creates and returns a new boolean variable V. The
5142 values of X and V are mutually constrained via noticers so that V is
5143 equal to T if and only if X is known to be integer valued and V is
5144 equal to NIL if and only if X is known to be non-integer valued. If X
5145 later becomes known to be integer valued, a noticer attached to X
5146 restricts V to equal t. Likewise, if X later becomes known to be
5147 non-integer valued, a noticer attached to X restricts V to equal NIL.
5148 Furthermore, if V ever becomes known to equal T then a noticer
5149 attached to V restricts X to be integer valued. Likewise, if V ever
5150 becomes known to equal NIL then a noticer attached to V restricts X to
5151 be non-integer valued."
5152   (cond ((known?-integerpv x) t)
5153         ((known?-notv-integerpv x) nil)
5154         (t (let ((x (variablize x))
5155                  (z (a-booleanv)))
5156              (attach-noticer!
5157               #'(lambda ()
5158                   (cond ((variable-integer? x) (restrict-true! z))
5159                         ((variable-noninteger? x) (restrict-false! z))))
5160               x)
5161              (attach-noticer!
5162               #'(lambda ()
5163                   (cond ((variable-true? z) (restrict-integer! x))
5164                         ((variable-false? z) (restrict-noninteger! x))))
5165               z)
5166              z))))
5167
5168 (defun realpv (x)
5169   "If when REALPV is called, X is known to be real then REALPV returns
5170 T. Alternatively, if when REALPV is called, X is known to be non-real
5171 then REALPV returns NIL. If it is not known whether or not X is real
5172 when REALPV is called then REALPV creates and returns a new boolean
5173 variable V. The values of X and V are mutually constrained via
5174 noticers so that V is equal to T if and only if X is known to be real
5175 and V is equal to NIL if and only if X is known to be non-real. If X
5176 later becomes known to be real, a noticer attached to X restricts V to
5177 equal T. Likewise, if X later becomes known to be non-real, a noticer
5178 attached to X restricts V to equal NIL. Furthermore, if V ever becomes
5179 known to equal T then a noticer attached to V restricts X to be real.
5180 Likewise, if V ever becomes known to equal NIL then a noticer attached
5181 to V restricts X to be non-real."
5182   (cond ((known?-realpv x) t)
5183         ((known?-notv-realpv x) nil)
5184         (t (let ((x (variablize x))
5185                  (z (a-booleanv)))
5186              (attach-noticer!
5187               #'(lambda ()
5188                   (cond ((variable-real? x) (restrict-true! z))
5189                         ((variable-nonreal? x) (restrict-false! z))))
5190               x)
5191              (attach-noticer!
5192               #'(lambda ()
5193                   (cond ((variable-true? z) (restrict-real! x))
5194                         ((variable-false? z) (restrict-nonreal! x))))
5195               z)
5196              z))))
5197
5198 (defun numberpv (x)
5199   "If when NUMBERPV is called, X is known to be numeric then NUMBERPV
5200 returns T. Alternatively, if when NUMBERPV is called, X is known to be
5201 non-numeric then NUMBERPV returns NIL. If it is not known whether or
5202 not X is numeric when NUMBERPV is called then NUMBERPV creates and
5203 returns a new boolean variable V. The values of X and V are mutually
5204 constrained via noticers so that V is equal to T if and only if X is
5205 known to be numeric and V is equal to NIL if and only if X is known to
5206 be non-numeric. If X later becomes known to be numeric, a noticer
5207 attached to X restricts V to equal T. Likewise, if X later becomes
5208 known to be non-numeric, a noticer attached to X restricts V to equal
5209 NIL. Furthermore, if V ever becomes known to equal T then a noticer
5210 attached to V restricts X to be numeric. Likewise, if V ever becomes
5211 known to equal NIL then a noticer attached to V restricts X to be
5212 non-numeric."
5213   (cond ((known?-numberpv x) t)
5214         ((known?-notv-numberpv x) nil)
5215         (t (let ((x (variablize x))
5216                  (z (a-booleanv)))
5217              (attach-noticer!
5218               #'(lambda ()
5219                   (cond ((variable-number? x) (restrict-true! z))
5220                         ((variable-nonnumber? x) (restrict-false! z))))
5221               x)
5222              (attach-noticer!
5223               #'(lambda ()
5224                   (cond ((variable-true? z) (restrict-number! x))
5225                         ((variable-false? z) (restrict-nonnumber! x))))
5226               z)
5227              z))))
5228
5229 (defun booleanpv (x)
5230   "The expression \(BOOLEANPV X) is an abbreviation for \(MEMBERV X '\(T NIL))."
5231   (cond ((known?-booleanpv x) t)
5232         ((known?-notv-booleanpv x) nil)
5233         (t (let ((x (variablize x))
5234                  (z (a-booleanv)))
5235              (attach-noticer!
5236               #'(lambda ()
5237                   (cond ((variable-boolean? x) (restrict-true! z))
5238                         ((variable-nonboolean? x) (restrict-false! z))))
5239               x)
5240              (attach-noticer!
5241               #'(lambda ()
5242                   (cond ((variable-true? z) (restrict-boolean! x))
5243                         ((variable-false? z) (restrict-nonboolean! x))))
5244               z)
5245              z))))
5246
5247 ;;; Lifted MEMBERV
5248
5249 (defun known?-memberv-list-internal (x y)
5250   (and (consp y)
5251        (or (known?-equalv x (first y))
5252            (known?-memberv-list-internal x (rest y)))))
5253
5254 (defun known?-memberv-list (x y)
5255   (typecase y
5256     (cons (or (known?-equalv x (first y)) (known?-memberv-list x (rest y))))
5257     (variable
5258      (if (eq (variable-value y) y)
5259          (and (not (eq (variable-enumerated-domain y) t))
5260               (every
5261                #'(lambda (element) (known?-memberv-list-internal x element))
5262                (variable-enumerated-domain y)))
5263          (known?-memberv-list x (variable-value y))))
5264     (otherwise nil)))
5265
5266 (defun known?-memberv-internal (x y)
5267   (typecase y
5268     (list (known?-memberv-list x y))
5269     (vector (some #'(lambda (element) (known?-equalv x element)) y))
5270     (variable
5271      (if (eq (variable-value y) y)
5272          (and (not (eq (variable-enumerated-domain y) t))
5273               (every
5274                #'(lambda (element)
5275                    (typecase element
5276                      (list (known?-memberv-list-internal x element))
5277                      (vector (some #'(lambda (e) (known?-equalv x e)) element))
5278                      (otherwise nil)))
5279                (variable-enumerated-domain y)))
5280          (known?-memberv-internal x (variable-value y))))
5281     (otherwise (fail))))
5282
5283 (defun known?-memberv (x y)
5284   (cond ((and (variable? x) (not (eq (variable-value x) x)))
5285          (known?-memberv (variable-value x) y))
5286         ((and (variable? x) (not (eq (variable-enumerated-domain x) t)))
5287          ;; note: This first alternative is an optimization in case membership
5288          ;;       can be determined simply through sharing relationships.
5289          (or (known?-memberv-internal x y)
5290              (every #'(lambda (element) (known?-memberv-internal element y))
5291                     (variable-enumerated-domain x))))
5292         (t (known?-memberv-internal x y))))
5293
5294 (defun known?-notv-memberv-list-internal (x y)
5295   (or (not (consp y))
5296       (and (known?-notv-equalv x (first y))
5297            (known?-notv-memberv-list-internal x (rest y)))))
5298
5299 (defun known?-notv-memberv-list (x y)
5300   (typecase y
5301     (cons (and (known?-notv-equalv x (first y))
5302                (known?-notv-memberv-list x (rest y))))
5303     (variable
5304      (if (eq (variable-value y) y)
5305          (and (not (eq (variable-enumerated-domain y) t))
5306               (every #'(lambda (element)
5307                          (known?-notv-memberv-list-internal x element))
5308                      (variable-enumerated-domain y)))
5309          (known?-notv-memberv-list x (variable-value y))))
5310     (otherwise t)))
5311
5312 (defun known?-notv-memberv-internal (x y)
5313   (typecase y
5314     (list (known?-notv-memberv-list x y))
5315     (vector (every #'(lambda (element) (known?-notv-equalv x element)) y))
5316     (variable
5317      (if (eq (variable-value y) y)
5318          (and (not (eq (variable-enumerated-domain y) t))
5319               (every
5320                #'(lambda (element)
5321                    (typecase element
5322                      (list (known?-notv-memberv-list-internal x element))
5323                      (vector
5324                       (every #'(lambda (e) (known?-notv-equalv x e)) element))
5325                      (otherwise nil)))
5326                (variable-enumerated-domain y)))
5327          (known?-notv-memberv-internal x (variable-value y))))
5328     (otherwise (fail))))
5329
5330 (defun known?-notv-memberv (x y)
5331   (cond
5332     ((and (variable? x) (not (eq (variable-value x) x)))
5333      (known?-notv-memberv (variable-value x) y))
5334     ((and (variable? x) (not (eq (variable-enumerated-domain x) t)))
5335      ;; note: This first alternative is an optimization in case membership
5336      ;;       can be determined simply through sharing relationships.
5337      (or (known?-notv-memberv-internal x y)
5338          (every #'(lambda (element) (known?-notv-memberv-internal element y))
5339                 (variable-enumerated-domain x))))
5340     (t (known?-notv-memberv-internal x y))))
5341
5342 (defun assert!-memberv-internal (x y)
5343   (let ((x (value-of x)))
5344     (if (known?-notv-memberv x y) (fail))
5345     (if (variable? x)
5346         (let ((y (value-of y)))
5347           (unless (variable? y) (restrict-enumerated-domain! x y))))))
5348
5349 (defun assert!-memberv (x y)
5350   (let ((y (value-of y)))
5351     (if (vectorp y)
5352         (dotimes (i (length y))
5353           (attach-noticer! #'(lambda () (assert!-memberv-internal x y))
5354                            (aref y i)))
5355         (attach-noticer! #'(lambda () (assert!-memberv-internal x y)) y))))
5356
5357 (defun assert!-notv-memberv-internal (x y)
5358   (let ((x (value-of x)))
5359     (if (known?-memberv x y) (fail))
5360     (if (variable? x)
5361         (let ((y (value-of y)))
5362           (unless (variable? y) (restrict-enumerated-antidomain! x y))))))
5363
5364 (defun assert!-notv-memberv (x y)
5365   (let ((y (value-of y)))
5366     (if (vectorp y)
5367         (dotimes (i (length y))
5368           (attach-noticer! #'(lambda () (assert!-notv-memberv-internal x y))
5369                            (aref y i)))
5370         (attach-noticer! #'(lambda () (assert!-notv-memberv-internal x y)) y))))
5371
5372 (defun memberv (x y)
5373   "The current implementation imposes two constraints on the parameter
5374 Y. First, Y must be bound when MEMBERV is called. Second, Y must not
5375 contain any unbound variables when MEMBERV is called. The value of
5376 parameter Y must be a sequence, i.e. either a list or a vector. If
5377 when MEMBERV is called, X is known to be a member of Y \(using the
5378 Common Lisp function EQL as a test function) then MEMBERV returns T.
5379 Alternatively, if when MEMBERV is called, X is known not to be a
5380 member of Y then MEMBERV returns NIL. If it is not known whether or
5381 not X is a member of Y when MEMBERV is called then MEMBERV creates and
5382 returns a new boolean variable V. The values of X and V are mutually
5383 constrained via noticers so that V is equal to T if and only if X is
5384 known to be a member of Y and V is equal to NIL if and only if X is
5385 known not to be a member of Y. If X later becomes known to be a member
5386 of Y, a noticer attached to X restricts v to equal T. Likewise, if X
5387 later becomes known not to be a member of Y, a noticer attached to X
5388 restricts V to equal NIL. Furthermore, if V ever becomes known to
5389 equal T then a noticer attached to V restricts X to be a member of Y.
5390 Likewise, if V ever becomes known to equal NIL then a noticer attached
5391 to V restricts X not to be a member of Y."
5392   (cond ((known?-memberv x y) t)
5393         ((known?-notv-memberv x y) nil)
5394         (t (let ((x (variablize x))
5395                  (z (a-booleanv)))
5396              (attach-noticer!
5397               #'(lambda ()
5398                   (cond ((known?-memberv x y) (restrict-true! z))
5399                         ((known?-notv-memberv x y) (restrict-false! z))))
5400               x)
5401              (if (vectorp y)
5402                  (dolist (element y)
5403                    (attach-noticer!
5404                     #'(lambda ()
5405                         (cond ((known?-memberv x y) (restrict-true! z))
5406                               ((known?-notv-memberv x y) (restrict-false! z))))
5407                     element))
5408                  (attach-noticer!
5409                   #'(lambda ()
5410                       (cond ((known?-memberv x y) (restrict-true! z))
5411                             ((known?-notv-memberv x y) (restrict-false! z))))
5412                   y))
5413              (attach-noticer!
5414               #'(lambda ()
5415                   (cond ((variable-true? z) (assert!-memberv x y))
5416                         ((variable-false? z) (assert!-notv-memberv x y))))
5417               z)
5418              z))))
5419
5420 ;;; Lifted Arithmetic Comparison Functions (Two argument optimized)
5421
5422 (defun =v2 (x y)
5423   (assert!-numberpv x)
5424   (assert!-numberpv y)
5425   (cond ((known?-=v2-internal x y) t)
5426         ((known?-/=v2-internal x y) nil)
5427         (t (let ((x (variablize x))
5428                  (y (variablize y))
5429                  (z (a-booleanv)))
5430              (attach-noticer!
5431               #'(lambda ()
5432                   (cond ((known?-=v2-variable x y) (restrict-true! z))
5433                         ((known?-/=v2-variable x y) (restrict-false! z))))
5434               x)
5435              (attach-noticer!
5436               #'(lambda ()
5437                   (cond ((known?-=v2-variable x y) (restrict-true! z))
5438                         ((known?-/=v2-variable x y) (restrict-false! z))))
5439               y)
5440              (attach-noticer!
5441               #'(lambda ()
5442                   (cond ((variable-true? z) (assert!-=v2 x y))
5443                         ((variable-false? z) (assert!-/=v2 x y))))
5444               z)
5445              z))))
5446
5447 (defun <=v2 (x y)
5448   (assert!-realpv x)
5449   (assert!-realpv y)
5450   (cond ((known?-<=v2-internal x y) t)
5451         ((known?-<v2-internal y x) nil)
5452         (t (let ((x (variablize x))
5453                  (y (variablize y))
5454                  (z (a-booleanv)))
5455              (attach-noticer!
5456               #'(lambda ()
5457                   (cond ((known?-<=v2-variable x y) (restrict-true! z))
5458                         ((known?-<v2-variable y x) (restrict-false! z))))
5459               x)
5460              (attach-noticer!
5461               #'(lambda ()
5462                   (cond ((known?-<=v2-variable x y) (restrict-true! z))
5463                         ((known?-<v2-variable y x) (restrict-false! z))))
5464               y)
5465              (attach-noticer!
5466               #'(lambda ()
5467                   (cond ((variable-true? z) (assert!-<=v2 x y))
5468                         ((variable-false? z) (assert!-<v2 y x))))
5469               z)
5470              z))))
5471
5472 (defun <v2 (x y)
5473   (assert!-realpv x)
5474   (assert!-realpv y)
5475   (cond ((known?-<v2-internal x y) t)
5476         ((known?-<=v2-internal y x) nil)
5477         (t (let ((x (variablize x))
5478                  (y (variablize y))
5479                  (z (a-booleanv)))
5480              (attach-noticer!
5481               #'(lambda ()
5482                   (cond ((known?-<v2-variable x y) (restrict-true! z))
5483                         ((known?-<=v2-variable y x) (restrict-false! z))))
5484               x)
5485              (attach-noticer!
5486               #'(lambda ()
5487                   (cond ((known?-<v2-variable x y) (restrict-true! z))
5488                         ((known?-<=v2-variable y x) (restrict-false! z))))
5489               y)
5490              (attach-noticer!
5491               #'(lambda ()
5492                   (cond ((variable-true? z) (assert!-<v2 x y))
5493                         ((variable-false? z) (assert!-<=v2 y x))))
5494               z)
5495              z))))
5496
5497 (defun /=v2 (x y)
5498   (assert!-numberpv x)
5499   (assert!-numberpv y)
5500   (cond ((known?-/=v2-internal x y) t)
5501         ((known?-=v2-internal x y) nil)
5502         (t (let ((x (variablize x))
5503                  (y (variablize y))
5504                  (z (a-booleanv)))
5505              (attach-noticer!
5506               #'(lambda ()
5507                   (cond ((known?-/=v2-variable x y) (restrict-true! z))
5508                         ((known?-=v2-variable x y) (restrict-false! z))))
5509               x)
5510              (attach-noticer!
5511               #'(lambda ()
5512                   (cond ((known?-/=v2-variable x y) (restrict-true! z))
5513                         ((known?-=v2-variable x y) (restrict-false! z))))
5514               y)
5515              (attach-noticer!
5516               #'(lambda ()
5517                   (cond ((variable-true? z) (assert!-/=v2 x y))
5518                         ((variable-false? z) (assert!-=v2 x y))))
5519               z)
5520              z))))
5521
5522 ;;; Lifted NOTV, ANDV and ORV
5523
5524 (defun notv (x)
5525   (assert!-booleanpv x)
5526   (let ((x (value-of x)))
5527     (cond ((eq x t) nil)
5528           ((eq x nil) t)
5529           (t (let ((z (a-booleanv)))
5530                (attach-noticer!
5531                 #'(lambda ()
5532                     (cond ((variable-true? x) (restrict-false! z))
5533                           ((variable-false? x) (restrict-true! z))))
5534                 x)
5535                (attach-noticer!
5536                 #'(lambda ()
5537                     (cond ((variable-true? z) (restrict-false! x))
5538                           ((variable-false? z) (restrict-true! x))))
5539                 z)
5540                z)))))
5541
5542 (defun andv-internal (xs)
5543   (dolist (x xs) (assert!-booleanpv x))
5544   (let ((xs (mapcar #'value-of xs)))
5545     (if (member nil xs :test #'eq)
5546         nil
5547         (let* ((xs (remove t xs :test #'eq))
5548                (count (length xs)))
5549           (cond
5550             ((zerop count) t)
5551             ((= count 1) (first xs))
5552             (t (let ((z (a-booleanv)))
5553                  (attach-noticer!
5554                   #'(lambda ()
5555                       (cond ((variable-true? z) (dolist (x xs) (restrict-true! x)))
5556                             ((and (= count 1) (variable-false? z))
5557                              (dolist (x xs)
5558                                (unless (variable-true? x) (restrict-false! x))))))
5559                   z)
5560                  (dolist (x xs)
5561                    (let ((x x))
5562                      (attach-noticer!-internal
5563                       #'(lambda ()
5564                           (cond ((variable-false? x) (restrict-false! z))
5565                                 ((variable-true? x)
5566                                  (local (decf count))
5567                                  (cond ((zerop count) (restrict-true! z))
5568                                        ((and (= count 1) (variable-false? z))
5569                                         (dolist (x xs)
5570                                           (unless (variable-true? x)
5571                                             (restrict-false! x))))))))
5572                       x)))
5573                  z)))))))
5574
5575 (defun andv (&rest xs) (andv-internal xs))
5576
5577 (defun assert!-notv-andv-internal (xs)
5578   (dolist (x xs) (assert!-booleanpv x))
5579   (let ((xs (mapcar #'value-of xs)))
5580     (unless (member nil xs :test #'eq)
5581       (let* ((xs (remove t xs :test #'eq))
5582              (count (length xs)))
5583         (cond ((zerop count) (fail))
5584               ((= count 1) (restrict-false! (first xs)))
5585               (t (dolist (x xs)
5586                    (let ((x x))
5587                      (attach-noticer!-internal
5588                       #'(lambda ()
5589                           (cond ((variable-false? x))
5590                                 ((variable-true? x)
5591                                  (local (decf count))
5592                                  (cond ((zerop count) (fail))
5593                                        ((= count 1)
5594                                         (dolist (x xs)
5595                                           (unless (variable-true? x)
5596                                             (restrict-false! x))))))))
5597                       x)))))))))
5598
5599 (defun assert!-notv-andv (&rest xs) (assert!-notv-andv-internal xs))
5600
5601 (defun orv-internal (xs)
5602   (dolist (x xs) (assert!-booleanpv x))
5603   (let ((xs (mapcar #'value-of xs)))
5604     (if (member t xs :test #'eq)
5605         t
5606         (let* ((xs (remove nil xs :test #'eq))
5607                (count (length xs)))
5608           (cond
5609             ((zerop count) nil)
5610             ((= count 1) (first xs))
5611             (t (let ((z (a-booleanv)))
5612                  (attach-noticer!
5613                   #'(lambda ()
5614                       (cond ((variable-false? z)
5615                              (dolist (x xs) (restrict-false! x)))
5616                             ((and (= count 1) (variable-true? z))
5617                              (dolist (x xs)
5618                                (unless (variable-false? x) (restrict-true! x))))))
5619                   z)
5620                  (dolist (x xs)
5621                    (let ((x x))
5622                      (attach-noticer!-internal
5623                       #'(lambda ()
5624                           (cond ((variable-true? x) (restrict-true! z))
5625                                 ((variable-false? x)
5626                                  (local (decf count))
5627                                  (cond ((zerop count) (restrict-false! z))
5628                                        ((and (= count 1) (variable-true? z))
5629                                         (dolist (x xs)
5630                                           (unless (variable-false? x)
5631                                             (restrict-true! x))))))))
5632                       x)))
5633                  z)))))))
5634
5635 (defun orv (&rest xs) (orv-internal xs))
5636
5637 (defun assert!-orv-internal (xs)
5638   (dolist (x xs) (assert!-booleanpv x))
5639   (let ((xs (mapcar #'value-of xs)))
5640     (unless (member t xs :test #'eq)
5641       (let* ((xs (remove nil xs :test #'eq))
5642              (count (length xs)))
5643         (cond ((zerop count) (fail))
5644               ((= count 1) (restrict-true! (first xs)))
5645               (t (dolist (x xs)
5646                    (let ((x x))
5647                      (attach-noticer!-internal
5648                       #'(lambda ()
5649                           (cond ((variable-true? x))
5650                                 ((variable-false? x)
5651                                  (local (decf count))
5652                                  (cond ((zerop count) (fail))
5653                                        ((= count 1)
5654                                         (dolist (x xs)
5655                                           (unless (variable-false? x)
5656                                             (restrict-true! x))))))))
5657                       x)))))))))
5658
5659 (defun assert!-orv (&rest xs) (assert!-orv-internal xs))
5660
5661 (defun assert!-clause (xs ps)
5662   (dolist (x xs) (assert!-booleanpv x))
5663   (let ((xs (mapcar #'value-of xs)))
5664     (unless (some #'eq xs ps)
5665       (let (new-xs new-ps)
5666         (do ((xrest xs (rest xrest))
5667              (prest ps (rest prest)))
5668             ((or (null xrest) (null prest)))
5669           (let ((x (first xrest))
5670                 (p (first prest)))
5671             (unless (eq x (not p))
5672               (push x new-xs)
5673               (push p new-ps))))
5674         (let ((count (length new-xs)))
5675           (cond ((zerop count) (fail))
5676                 ((= count 1)
5677                  (if (first new-ps)
5678                      (restrict-true! (first new-xs))
5679                      (restrict-false! (first new-xs))))
5680                 (t (do ((xrest new-xs (rest xrest))
5681                         (prest new-ps (rest prest)))
5682                        ((null xrest))
5683                      (let ((x (first xrest)))
5684                        (attach-noticer!-internal
5685                         (if (first prest)
5686                             #'(lambda ()
5687                                 (cond ((variable-true? x))
5688                                       ((variable-false? x)
5689                                        (local (decf count))
5690                                        (cond ((zerop count) (fail))
5691                                              ((= count 1)
5692                                               (do ((xrest new-xs (rest xrest))
5693                                                    (prest new-ps (rest prest)))
5694                                                   ((null xrest))
5695                                                 (let ((x (first xrest)))
5696                                                   (unless (bound? x)
5697                                                     (if (first prest)
5698                                                         (restrict-true! x)
5699                                                         (restrict-false! x))))))))))
5700                             #'(lambda ()
5701                                 (cond ((variable-false? x))
5702                                       ((variable-true? x)
5703                                        (local (decf count))
5704                                        (cond
5705                                          ((zerop count) (fail))
5706                                          ((= count 1)
5707                                           (do ((xrest new-xs (rest xrest))
5708                                                (prest new-ps (rest prest)))
5709                                               ((null xrest))
5710                                             (let ((x (first xrest)))
5711                                               (unless (bound? x)
5712                                                 (if (first prest)
5713                                                     (restrict-true! x)
5714                                                     (restrict-false! x)))))))))))
5715                         x))))))))))
5716
5717 (defun count-trues-internal (xs) (count-if #'identity xs))
5718
5719 (defun count-trues (&rest xs) (count-trues-internal xs))
5720
5721 (defun count-truesv-internal (xs)
5722   (dolist (x xs) (assert!-booleanpv x))
5723   (let ((xs (mapcar #'value-of xs))
5724         (lower 0)
5725         (upper (length xs)))
5726     (dolist (x xs)
5727       (cond ((eq x t) (incf lower))
5728             ((eq x nil) (decf upper))))
5729     (if (= lower upper)
5730         lower
5731         (let ((z (an-integer-betweenv lower upper))
5732               (xs (remove-if #'bound? xs)))
5733           (attach-noticer!
5734            #'(lambda ()
5735                (if (= upper (variable-lower-bound z))
5736                    (dolist (x xs)
5737                      (unless (variable-false? x) (restrict-true! x))))
5738                (if (= lower (variable-upper-bound z))
5739                    (dolist (x xs)
5740                      (unless (variable-true? x) (restrict-false! x)))))
5741            z)
5742           (dolist (x xs)
5743             (let ((x x))
5744               (attach-noticer!
5745                #'(lambda ()
5746                    (cond ((variable-false? x)
5747                           (local (decf upper))
5748                           (restrict-upper-bound! z upper)
5749                           (if (= upper (variable-lower-bound z))
5750                               (dolist (x xs)
5751                                 (unless (variable-false? x) (restrict-true! x)))))
5752                          ((variable-true? x)
5753                           (local (incf lower))
5754                           (restrict-lower-bound! z lower)
5755                           (if (= lower (variable-upper-bound z))
5756                               (dolist (x xs)
5757                                 (unless (variable-true? x) (restrict-false! x)))))))
5758                x)))
5759           z))))
5760
5761 (defun count-truesv (&rest xs) (count-truesv-internal xs))
5762
5763 ;;; Lifted FUNCALLV and APPLYV
5764
5765 (defun finite-domain? (variable)
5766   (let ((variable (value-of variable)))
5767     (or (not (variable? variable))
5768         (not (eq (variable-enumerated-domain variable) t))
5769         (and (variable-integer? variable)
5770              (variable-lower-bound variable)
5771              (variable-upper-bound variable)))))
5772
5773 ;;; note: SOLUTION, LINEAR-FORCE and STATIC-ORDERING were moved here to be
5774 ;;;       before KNOWN?-CONSTRAINT to avoid forward references to
5775 ;;;       nondeterministic functions.
5776
5777 (defun solution (x force-function)
5778   (funcall-nondeterministic
5779    (value-of force-function) (variables-in (value-of x)))
5780   (apply-substitution x))
5781
5782 (defun linear-force (variable)
5783   (let ((variable (value-of variable)))
5784     (if (variable? variable)
5785         (restrict-value!
5786          variable
5787          (cond ((not (eq (variable-enumerated-domain variable) t))
5788                 (a-member-of (variable-enumerated-domain variable)))
5789                ((variable-integer? variable)
5790                 (if (variable-lower-bound variable)
5791                     (if (variable-upper-bound variable)
5792                         (an-integer-between
5793                          (variable-lower-bound variable)
5794                          (variable-upper-bound variable))
5795                         (an-integer-above (variable-lower-bound variable)))
5796                     (if (variable-upper-bound variable)
5797                         (an-integer-below (variable-upper-bound variable))
5798                         (an-integer))))
5799                (t (error "It is only possible to linear force a variable that~%~
5800                         has a countable domain"))))))
5801   (value-of variable))
5802
5803 (defun static-ordering-internal (variables force-function)
5804   (if variables
5805       (let ((variable (value-of (first variables))))
5806         (cond ((variable? variable)
5807                (funcall-nondeterministic force-function variable)
5808                (static-ordering-internal variables force-function))
5809               (t (static-ordering-internal (rest variables) force-function))))))
5810
5811 (defun static-ordering (force-function)
5812   ;; note: This closure will heap cons.
5813   (let ((force-function (value-of force-function)))
5814     #'(lambda (variables) (static-ordering-internal variables force-function))))
5815
5816 (defun known?-constraint (f polarity? x)
5817   (let ((f (value-of f)))
5818     (if (variable? f)
5819         (error "The current implementation does not allow the first argument~%~
5820               of FUNCALLV or APPLYV to be an unbound variable"))
5821     (unless (functionp f)
5822       (error "The first argument to FUNCALLV or APPLYV must be a deterministic~%~
5823            function"))
5824     (and (every #'finite-domain? x)
5825          (block exit
5826            (for-effects
5827              (if (if polarity?
5828                      (not (apply f (solution x (static-ordering #'linear-force))))
5829                      (apply f (solution x (static-ordering #'linear-force))))
5830                  (return-from exit nil)))
5831            t))))
5832
5833 (defun propagate-gfc (predicate polarity? variables unassigned-variable)
5834   ;; note: UNASSIGNED-VARIABLE must be a variable which is not bound and
5835   ;;       all of the VARIABLES except the UNASSIGNED-VARIABLE must be bound.
5836   (let ((unassigned-variable (value-of unassigned-variable)))
5837     ;; There is no way to propagate a value to a variable that doesn't have an
5838     ;; enumerated domain.
5839     (if (and (not (eq (variable-enumerated-domain unassigned-variable) t))
5840              (not (null (rest (variable-enumerated-domain
5841                                unassigned-variable)))))
5842         ;; note: Could do less consing if had LOCAL DELETE-IF-NOT.
5843         ;; note: Consing.
5844         (let* ((variable-values (mapcar #'value-of variables))
5845                (new-enumerated-domain
5846                 (if polarity?
5847                     (remove-if-not
5848                      #'(lambda (value)
5849                          (apply predicate
5850                                 ;; note: Consing.
5851                                 (mapcar #'(lambda (variable variable-value)
5852                                             (if (eq variable unassigned-variable)
5853                                                 value
5854                                                 variable-value))
5855                                         variables
5856                                         variable-values)))
5857                      (variable-enumerated-domain unassigned-variable))
5858                     (remove-if
5859                      #'(lambda (value)
5860                          (apply predicate
5861                                 ;; note: Consing.
5862                                 (mapcar #'(lambda (variable variable-value)
5863                                             (if (eq variable unassigned-variable)
5864                                                 value
5865                                                 variable-value))
5866                                         variables
5867                                         variable-values)))
5868                      (variable-enumerated-domain unassigned-variable)))))
5869           (if (set-enumerated-domain! unassigned-variable new-enumerated-domain)
5870               (run-noticers unassigned-variable))))))
5871
5872 (defun a-tuple (variables variable value)
5873   (if (null variables)
5874       nil
5875       (cons (cond ((eq (first variables) variable) value)
5876                   ((variable? (first variables))
5877                    (a-member-of (variable-enumerated-domain (first variables))))
5878                   (t (first variables)))
5879             (a-tuple (rest variables) variable value))))
5880
5881 (defun propagate-ac (predicate polarity? variables)
5882   (unless (some #'(lambda (variable)
5883                     (and (variable? variable)
5884                          (eq (variable-enumerated-domain variable) t)))
5885                 variables)
5886     (dolist (variable variables)
5887       ;; note: Could do less consing if had LOCAL DELETE-IF-NOT.
5888       (if (variable? variable)
5889           (let ((new-enumerated-domain
5890                  (if polarity?
5891                      (remove-if-not
5892                       #'(lambda (value)
5893                           (possibly?
5894                             ;; note: Consing.
5895                             (apply predicate (a-tuple variables variable value))))
5896                       (variable-enumerated-domain variable))
5897                      (remove-if
5898                       #'(lambda (value)
5899                           (possibly?
5900                             ;; note: Consing.
5901                             (apply predicate (a-tuple variables variable value))))
5902                       (variable-enumerated-domain variable)))))
5903             (if (set-enumerated-domain! variable new-enumerated-domain)
5904                 (run-noticers variable)))))))
5905
5906 (defun assert!-constraint-gfc (predicate polarity? variables)
5907   (let ((predicate (value-of predicate))
5908         (multiple-unassigned-variables? nil)
5909         (unassigned-variable nil))
5910     (if (variable? predicate)
5911         (error "The current implementation does not allow the first argument~%~
5912               of FUNCALLV or APPLYV to be an unbound variable"))
5913     (unless (functionp predicate)
5914       (error "The first argument to FUNCALLV or APPLYV must be a deterministic~%~
5915            function"))
5916     (dolist (variable variables)
5917       (unless (bound? variable)
5918         (if unassigned-variable (setf multiple-unassigned-variables? t))
5919         (setf unassigned-variable variable)))
5920     (cond
5921       (multiple-unassigned-variables?
5922        ;; The case where two or more variables are unbound
5923        (let ((variables (copy-list variables)))
5924          (dolist (variable variables)
5925            (unless (bound? variable)
5926              (let ((variable variable))
5927                (attach-noticer!
5928                 #'(lambda ()
5929                     (global
5930                       (block exit
5931                         (let ((unassigned-variable nil))
5932                           (dolist (variable variables)
5933                             (unless (bound? variable)
5934                               (if unassigned-variable (return-from exit))
5935                               (setf unassigned-variable variable)))
5936                           (if unassigned-variable
5937                               (propagate-gfc
5938                                predicate polarity? variables unassigned-variable)
5939                               (unless (if polarity?
5940                                           (apply predicate (mapcar #'value-of variables))
5941                                           (not (apply predicate
5942                                                       (mapcar #'value-of variables))))
5943                                 (fail)))))))
5944                 variable))))))
5945       (unassigned-variable
5946        ;; The case where all but one of the variables are bound
5947        (propagate-gfc predicate polarity? variables unassigned-variable))
5948       ;; The case where all variables are bound
5949       ;; note: Consing.
5950       (t (unless (if polarity?
5951                      (apply predicate (mapcar #'value-of variables))
5952                      (not (apply predicate (mapcar #'value-of variables))))
5953            (fail))))))
5954
5955 (defun assert!-constraint-ac (predicate polarity? variables)
5956   (let ((predicate (value-of predicate)))
5957     (if (variable? predicate)
5958         (error "The current implementation does not allow the first argument~%~
5959               of FUNCALLV or APPLYV to be an unbound variable"))
5960     (unless (functionp predicate)
5961       (error "The first argument to FUNCALLV or APPLYV must be a deterministic~%~
5962            function"))
5963     (dolist (variable variables)
5964       (attach-noticer!
5965        #'(lambda () (propagate-ac predicate polarity? variables))
5966        variable))
5967     (propagate-ac predicate polarity? variables)))
5968
5969 (defun assert!-constraint (predicate polarity? variables)
5970   (ecase *strategy*
5971     (:gfc (assert!-constraint-gfc predicate polarity? variables))
5972     (:ac (assert!-constraint-ac predicate polarity? variables))))
5973
5974 (defun known?-funcallv (f &rest x) (known?-constraint f t x))
5975
5976 (defun known?-notv-funcallv (f &rest x) (known?-constraint f nil x))
5977
5978 (defun assert!-funcallv (f &rest x) (assert!-constraint f t x))
5979
5980 (defun assert!-notv-funcallv (f &rest x) (assert!-constraint f nil x))
5981
5982 (defun funcallv (f &rest x)
5983   (let ((f (value-of f)))
5984     (if (variable? f)
5985         (error "The current implementation does not allow the first argument~%~
5986               of FUNCALLV to be an unbound variable"))
5987     (unless (functionp f)
5988       (error "The first argument to FUNCALLV must be a deterministic function"))
5989     (if (every #'bound? x)
5990         (apply f (mapcar #'value-of x))
5991         (let ((z (make-variable)))
5992           (assert!-constraint
5993            #'(lambda (&rest x) (equal (first x) (apply f (rest x)))) t (cons z x))
5994           (dolist (argument x)
5995             (attach-noticer!
5996              #'(lambda ()
5997                  (if (every #'bound? x)
5998                      (assert!-equalv z (apply f (mapcar #'value-of x)))))
5999              argument))
6000           z))))
6001
6002 (defun arguments-for-applyv (x xs)
6003   (unless (bound? (first (last (cons x xs))))
6004     (error "The current implementation does not allow the last argument to~%~
6005           APPLYV to be an unbound variable"))
6006   (apply #'list* (mapcar #'value-of (cons x xs))))
6007
6008 (defun known?-applyv (f x &rest xs)
6009   (known?-constraint f t (arguments-for-applyv x xs)))
6010
6011 (defun known?-notv-applyv (f x &rest xs)
6012   (known?-constraint f nil (arguments-for-applyv x xs)))
6013
6014 (defun assert!-applyv (f x &rest xs)
6015   (assert!-constraint f t (arguments-for-applyv x xs)))
6016
6017 (defun assert!-notv-applyv (f x &rest xs)
6018   (assert!-constraint f nil (arguments-for-applyv x xs)))
6019
6020 (defun applyv (f x &rest xs)
6021   (let ((f (value-of f)))
6022     (if (variable? f)
6023         (error "The current implementation does not allow the first argument~%~
6024               of APPLYV to be an unbound variable"))
6025     (unless (functionp f)
6026       (error "The first argument to APPLYV must be a deterministic function"))
6027     (let ((arguments (arguments-for-applyv x xs)))
6028       (if (every #'bound? arguments)
6029           (apply f (mapcar #'value-of arguments))
6030           (let ((z (make-variable)))
6031             (assert!-constraint
6032              #'(lambda (&rest x) (equal (first x) (apply f (rest x))))
6033              t
6034              (cons z arguments))
6035             (dolist (argument arguments)
6036               (attach-noticer!
6037                #'(lambda ()
6038                    (if (every #'bound? arguments)
6039                        (assert!-equalv z (apply f (mapcar #'value-of arguments)))))
6040                argument))
6041             z)))))
6042
6043 ;;; Lifted EQUALV
6044
6045 (defun known?-equalv (x y)
6046   (or (eql x y)
6047       (cond ((variable? x)
6048              (and (not (eq (variable-value x) x))
6049                   (known?-equalv (variable-value x) y)))
6050             ((variable? y)
6051              (and (not (eq (variable-value y) y))
6052                   (known?-equalv x (variable-value y))))
6053             (t (and (consp x)
6054                     (consp y)
6055                     (known?-equalv (car x) (car y))
6056                     (known?-equalv (cdr x) (cdr y)))))))
6057
6058 (defun assert!-equalv (x y)
6059   (unless (eql x y)
6060     (cond ((variable? x)
6061            (cond ((not (eq (variable-value x) x))
6062                   (assert!-equalv (variable-value x) y))
6063                  ((variable? y)
6064                   (if (eq (variable-value y) y)
6065                       (share! x y)
6066                       (assert!-equalv x (variable-value y))))
6067                  (t (restrict-value! x y))))
6068           ((variable? y)
6069            (if (eq (variable-value y) y)
6070                (restrict-value! y x)
6071                (assert!-equalv x (variable-value y))))
6072           ((and (consp x) (consp y))
6073            (assert!-equalv (car x) (car y))
6074            (assert!-equalv (cdr x) (cdr y)))
6075           (t (fail)))))
6076
6077 (defun known?-notv-equalv (x y) (one-value (progn (assert!-equalv x y) nil) t))
6078
6079 (defun assert!-notv-equalv (x y)
6080   ;; note: Can be made more efficient so that if you later find out that
6081   ;;       X and Y are KNOWN?-NUMBERPV you can then ASSERT!-/=V2.
6082   (if (known?-equalv x y) (fail))
6083   (unless (known?-notv-equalv x y)
6084     (let ((x (variablize x))
6085           (y (variablize y)))
6086       (attach-noticer! #'(lambda () (if (known?-equalv x y) (fail))) x)
6087       (attach-noticer! #'(lambda () (if (known?-equalv x y) (fail))) y))))
6088
6089 (defun equalv (x y)
6090   ;; note: Can be made more efficient and return an AND tree of individual
6091   ;;       constraints needed to make EQUALV true. This can be done also for
6092   ;;       the KNOWN? and ASSERT! versions.
6093   (cond ((known?-equalv x y) t)
6094         ((known?-notv-equalv x y) nil)
6095         (t (let ((x (variablize x))
6096                  (y (variablize y))
6097                  (z (a-booleanv)))
6098              (attach-noticer!
6099               #'(lambda ()
6100                   (cond ((known?-equalv x y) (restrict-true! z))
6101                         ((known?-notv-equalv x y) (restrict-false! z))))
6102               x)
6103              (attach-noticer!
6104               #'(lambda ()
6105                   (cond ((known?-equalv x y) (restrict-true! z))
6106                         ((known?-notv-equalv x y) (restrict-false! z))))
6107               y)
6108              (attach-noticer!
6109               #'(lambda ()
6110                   (cond ((variable-true? z) (assert!-equalv x y))
6111                         ((variable-false? z) (assert!-notv-equalv x y))))
6112               z)
6113              z))))
6114
6115 ;;; Lifted Arithmetic Functions
6116
6117 (defun +v-internal (xs)
6118   (if (null xs) 0 (+v2 (first xs) (+v-internal (rest xs)))))
6119
6120 (defun +v (&rest xs) (+v-internal xs))
6121
6122 (defun -v-internal (x xs)
6123   (if (null xs) x (-v-internal (-v2 x (first xs)) (rest xs))))
6124
6125 (defun -v (x &rest xs) (if (null xs) (-v2 0 x) (-v-internal x xs)))
6126
6127 (defun *v-internal (xs)
6128   (if (null xs) 1 (*v2 (first xs) (*v-internal (rest xs)))))
6129
6130 (defun *v (&rest xs) (*v-internal xs))
6131
6132 (defun /v-internal (x xs)
6133   (if (null xs) x (/v-internal (/v2 x (first xs)) (rest xs))))
6134
6135 (defun /v (x &rest xs) (if (null xs) (/v2 1 x) (/v-internal x xs)))
6136
6137 (defun minv-internal (x xs)
6138   (if (null xs) x (minv-internal (minv2 x (first xs)) (rest xs))))
6139
6140 (defun minv (x &rest xs) (if (null xs) x (minv-internal x xs)))
6141
6142 (defun maxv-internal (x xs)
6143   (if (null xs) x (maxv-internal (maxv2 x (first xs)) (rest xs))))
6144
6145 (defun maxv (x &rest xs) (if (null xs) x (maxv-internal x xs)))
6146
6147 ;;; Lifted Arithmetic Comparison Functions (KNOWN? optimized)
6148
6149 (defun known?-=v-internal (x xs)
6150   (if (null xs)
6151       t
6152       (and (known?-=v2 x (first xs))
6153            (known?-=v-internal (first xs) (rest xs)))))
6154
6155 (defun known?-=v (x &rest xs) (known?-=v-internal x xs))
6156
6157 (defun known?-<v-internal (x xs)
6158   (if (null xs)
6159       t
6160       (and (known?-<v2 x (first xs))
6161            (known?-<v-internal (first xs) (rest xs)))))
6162
6163 (defun known?-<v (x &rest xs) (known?-<v-internal x xs))
6164
6165 (defun known?-<=v-internal (x xs)
6166   (if (null xs)
6167       t
6168       (and (known?-<=v2 x (first xs))
6169            (known?-<=v-internal (first xs) (rest xs)))))
6170
6171 (defun known?-<=v (x &rest xs) (known?-<=v-internal x xs))
6172
6173 (defun known?->v-internal (x xs)
6174   (if (null xs)
6175       t
6176       (and (known?-<v2 (first xs) x)
6177            (known?->v-internal (first xs) (rest xs)))))
6178
6179 (defun known?->v (x &rest xs) (known?->v-internal x xs))
6180
6181 (defun known?->=v-internal (x xs)
6182   (if (null xs)
6183       t
6184       (and (known?-<=v2 (first xs) x)
6185            (known?->=v-internal (first xs) (rest xs)))))
6186
6187 (defun known?->=v (x &rest xs) (known?->=v-internal x xs))
6188
6189 (defun known?-/=v-internal (x xs)
6190   (if (null xs)
6191       t
6192       (and (known?-/=v2 x (first xs))
6193            (known?-/=v-internal x (rest xs))
6194            (known?-/=v-internal (first xs) (rest xs)))))
6195
6196 (defun known?-/=v (x &rest xs) (known?-/=v-internal x xs))
6197
6198 ;;; Lifted Arithmetic Comparison Functions (ASSERT! optimized)
6199
6200 (defun assert!-=v-internal (x xs)
6201   (unless (null xs)
6202     (assert!-=v2 x (first xs))
6203     (assert!-=v-internal (first xs) (rest xs))))
6204
6205 (defun assert!-=v (x &rest xs) (assert!-=v-internal x xs))
6206
6207 (defun assert!-<v-internal (x xs)
6208   (unless (null xs)
6209     (assert!-<v2 x (first xs))
6210     (assert!-<v-internal (first xs) (rest xs))))
6211
6212 (defun assert!-<v (x &rest xs) (assert!-<v-internal x xs))
6213
6214 (defun assert!-<=v-internal (x xs)
6215   (unless (null xs)
6216     (assert!-<=v2 x (first xs))
6217     (assert!-<=v-internal (first xs) (rest xs))))
6218
6219 (defun assert!-<=v (x &rest xs) (assert!-<=v-internal x xs))
6220
6221 (defun assert!->v-internal (x xs)
6222   (unless (null xs)
6223     (assert!-<v2 (first xs) x)
6224     (assert!->v-internal (first xs) (rest xs))))
6225
6226 (defun assert!->v (x &rest xs) (assert!->v-internal x xs))
6227
6228 (defun assert!->=v-internal (x xs)
6229   (unless (null xs)
6230     (assert!-<=v2 (first xs) x)
6231     (assert!->=v-internal (first xs) (rest xs))))
6232
6233 (defun assert!->=v (x &rest xs) (assert!->=v-internal x xs))
6234
6235 (defun assert!-/=v-internal (x xs)
6236   (unless (null xs)
6237     (assert!-/=v2 x (first xs))
6238     (assert!-/=v-internal x (rest xs))
6239     (assert!-/=v-internal (first xs) (rest xs))))
6240
6241 (defun assert!-/=v (x &rest xs) (assert!-/=v-internal x xs))
6242
6243 ;;; Lifted Arithmetic Comparisons Functions
6244
6245 (defun =v-internal (x xs)
6246   (if (null xs)
6247       t
6248       (andv (=v2 x (first xs)) (=v-internal (first xs) (rest xs)))))
6249
6250 (defun =v (x &rest xs) (=v-internal x xs))
6251
6252 (defun <v-internal (x xs)
6253   (if (null xs)
6254       t
6255       (andv (<v2 x (first xs)) (<v-internal (first xs) (rest xs)))))
6256
6257 (defun <v (x &rest xs) (<v-internal x xs))
6258
6259 (defun <=v-internal (x xs)
6260   (if (null xs)
6261       t
6262       (andv (<=v2 x (first xs)) (<=v-internal (first xs) (rest xs)))))
6263
6264 (defun <=v (x &rest xs) (<=v-internal x xs))
6265
6266 (defun >v-internal (x xs)
6267   (if (null xs)
6268       t
6269       (andv (<v2 (first xs) x) (>v-internal (first xs) (rest xs)))))
6270
6271 (defun >v (x &rest xs) (>v-internal x xs))
6272
6273 (defun >=v-internal (x xs)
6274   (if (null xs)
6275       t
6276       (andv (<=v2 (first xs) x) (>=v-internal (first xs) (rest xs)))))
6277
6278 (defun >=v (x &rest xs) (>=v-internal x xs))
6279
6280 (defun /=v-internal (x xs)
6281   (if (null xs)
6282       t
6283       (andv (/=v2 x (first xs))
6284             (/=v-internal x (rest xs))
6285             (/=v-internal (first xs) (rest xs)))))
6286
6287 (defun /=v (x &rest xs) (/=v-internal x xs))
6288
6289 ;;; The Optimizer Macros for ASSERT!, KNOWN? and DECIDE
6290
6291 (defun known?-true (x) (assert!-booleanpv x) (eq (value-of x) t))
6292
6293 (defun known?-false (x) (assert!-booleanpv x) (null (value-of x)))
6294
6295 (defun-compile-time transform-known? (form polarity?)
6296   (if (and (consp form) (null (rest (last form))))
6297       (cond
6298         ((and (eq (first form) 'notv)
6299               (= (length form) 2))
6300          (transform-known? (second form) (not polarity?)))
6301         ((eq (first form) 'andv)
6302          (cons (if polarity? 'and 'or)
6303                (mapcar #'(lambda (form) (transform-known? form polarity?))
6304                        (rest form))))
6305         ((eq (first form) 'orv)
6306          (cons (if polarity? 'or 'and)
6307                (mapcar #'(lambda (form) (transform-known? form polarity?))
6308                        (rest form))))
6309         ((member (first form)
6310                  '(integerpv realpv numberpv memberv booleanpv
6311                    =v <v <=v >v >=v /=v funcallv applyv equalv)
6312                  :test #'eq)
6313          (cons (cdr (assoc (first form)
6314                            (if polarity?
6315                                '((integerpv . known?-integerpv)
6316                                  (realpv . known?-realpv)
6317                                  (numberpv . known?-numberpv)
6318                                  (memberv . known?-memberv)
6319                                  (booleanpv . known?-booleanpv)
6320                                  (=v . known?-=v)
6321                                  (<v . known?-<v)
6322                                  (<=v . known?-<=v)
6323                                  (>v . known?->v)
6324                                  (>=v . known?->=v)
6325                                  (/=v . known?-/=v)
6326                                  (funcallv . known?-funcallv)
6327                                  (applyv . known?-applyv)
6328                                  (equalv . known?-equalv))
6329                                '((integerpv . known?-notv-integerpv)
6330                                  (realpv . known?-notv-realpv)
6331                                  (numberpv . known?-notv-numberpv)
6332                                  (memberv . known?-notv-memberv)
6333                                  (booleanpv . known?-notv-booleanpv)
6334                                  (=v . known?-/=v)
6335                                  (<v . known?->=v)
6336                                  (<=v . known?->v)
6337                                  (>v . known?-<=v)
6338                                  (>=v . known?-<v)
6339                                  (/=v . known?-=v)
6340                                  (funcallv . known?-notv-funcallv)
6341                                  (applyv . known?-notv-applyv)
6342                                  (equalv . known?-notv-equalv)))
6343                            :test #'eq))
6344                (rest form)))
6345         (polarity? `(known?-true ,form))
6346         (t `(known?-false ,form)))
6347       (if polarity? `(known?-true ,form) `(known?-false ,form))))
6348
6349 (defmacro-compile-time known? (form) (transform-known? form t))
6350
6351 (defun assert!-true (x) (assert!-equalv x t))
6352
6353 (defun assert!-false (x) (assert!-equalv x nil))
6354
6355 (defun-compile-time transform-assert! (form polarity?)
6356   (if (and (consp form) (null (rest (last form))))
6357       (cond
6358         ((and (eq (first form) 'notv)
6359               (= (length form) 2))
6360          (transform-assert! (second form) (not polarity?)))
6361         ((eq (first form) 'andv)
6362          (if polarity?
6363              `(progn ,@(mapcar
6364                         #'(lambda (form) (transform-assert! form polarity?))
6365                         (rest form)))
6366              (cond ((null (rest form)) `(fail))
6367                    ((null (rest (rest form))) `(assert!-false ,(second form)))
6368                    (t `(assert!-notv-andv ,@(rest form))))))
6369         ((eq (first form) 'orv)
6370          (if polarity?
6371              (cond ((null (rest form)) `(fail))
6372                    ((null (rest (rest form))) `(assert!-true ,(second form)))
6373                    (t `(assert!-orv ,@(rest form))))
6374              `(progn ,@(mapcar
6375                         #'(lambda (form) (transform-assert! form polarity?))
6376                         (rest form)))))
6377         ((member (first form)
6378                  '(integerpv realpv numberpv memberv booleanpv
6379                    =v <v <=v >v >=v /=v funcallv applyv equalv)
6380                  :test #'eq)
6381          (cons (cdr (assoc (first form)
6382                            (if polarity?
6383                                '((integerpv . assert!-integerpv)
6384                                  (realpv . assert!-realpv)
6385                                  (numberpv . assert!-numberpv)
6386                                  (memberv . assert!-memberv)
6387                                  (booleanpv . assert!-booleanpv)
6388                                  (=v . assert!-=v)
6389                                  (<v . assert!-<v)
6390                                  (<=v . assert!-<=v)
6391                                  (>v . assert!->v)
6392                                  (>=v . assert!->=v)
6393                                  (/=v . assert!-/=v)
6394                                  (funcallv . assert!-funcallv)
6395                                  (applyv . assert!-applyv)
6396                                  (equalv . assert!-equalv))
6397                                '((integerpv . assert!-notv-integerpv)
6398                                  (realpv . assert!-notv-realpv)
6399                                  (numberpv . assert!-notv-numberpv)
6400                                  (memberv . assert!-notv-memberv)
6401                                  (booleanpv . assert!-notv-booleanpv)
6402                                  (=v . assert!-/=v)
6403                                  (<v . assert!->=v)
6404                                  (<=v . assert!->v)
6405                                  (>v . assert!-<=v)
6406                                  (>=v . assert!-<v)
6407                                  (/=v . assert!-=v)
6408                                  (funcallv . assert!-notv-funcallv)
6409                                  (applyv . assert!-notv-applyv)
6410                                  (equalv . assert!-notv-equalv)))
6411                            :test #'eq))
6412                (rest form)))
6413         (polarity? `(assert!-true ,form))
6414         (t `(assert!-false ,form)))
6415       (if polarity? `(assert!-true ,form) `(assert!-false ,form))))
6416
6417 (defmacro-compile-time assert! (form) (transform-assert! form t))
6418
6419 (defun-compile-time transform-decide (form polarity?)
6420   (if (and (consp form) (null (rest (last form))))
6421       (cond
6422         ((and (eq (first form) 'notv)
6423               (= (length form) 2))
6424          (transform-decide (second form) (not polarity?)))
6425         ((eq (first form) 'andv)
6426          (let ((result (mapcar #'(lambda (form)
6427                                    (multiple-value-list
6428                                     (transform-decide form polarity?)))
6429                                (rest form))))
6430            (values (reduce #'append (mapcar #'first result))
6431                    (cons (if polarity? 'progn 'either)
6432                          (mapcar #'second result))
6433                    (cons (if polarity? 'either 'progn)
6434                          (mapcar #'third result)))))
6435         ((eq (first form) 'orv)
6436          (let ((result (mapcar #'(lambda (form)
6437                                    (multiple-value-list
6438                                     (transform-decide form polarity?)))
6439                                (rest form))))
6440            (values (reduce #'append (mapcar #'first result))
6441                    (cons (if polarity? 'either 'progn)
6442                          (mapcar #'second result))
6443                    (cons (if polarity? 'progn 'either)
6444                          (mapcar #'third result)))))
6445         ((member (first form)
6446                  '(integerpv realpv numberpv memberv booleanpv
6447                    =v <v <=v >v >=v /=v funcallv applyv equalv)
6448                  :test #'eq)
6449          (let ((arguments (mapcar #'(lambda (argument)
6450                                       (declare (ignore argument))
6451                                       (gensym "ARGUMENT-"))
6452                                   (rest form))))
6453            (values (mapcar #'list arguments (rest form))
6454                    (cons (cdr (assoc (first form)
6455                                      (if polarity?
6456                                          '((integerpv . assert!-integerpv)
6457                                            (realpv . assert!-realpv)
6458                                            (numberpv . assert!-numberpv)
6459                                            (memberv . assert!-memberv)
6460                                            (booleanpv . assert!-booleanpv)
6461                                            (=v . assert!-=v)
6462                                            (<v . assert!-<v)
6463                                            (<=v . assert!-<=v)
6464                                            (>v . assert!->v)
6465                                            (>=v . assert!->=v)
6466                                            (/=v . assert!-/=v)
6467                                            (funcallv . assert!-funcallv)
6468                                            (applyv . assert!-applyv)
6469                                            (equalv . assert!-equalv))
6470                                          '((integerpv . assert!-notv-integerpv)
6471                                            (realpv . assert!-notv-realpv)
6472                                            (numberpv . assert!-notv-numberpv)
6473                                            (memberv . assert!-notv-memberv)
6474                                            (booleanpv . assert!-notv-booleanpv)
6475                                            (=v . assert!-/=v)
6476                                            (<v . assert!->=v)
6477                                            (<=v . assert!->v)
6478                                            (>v . assert!-<=v)
6479                                            (>=v . assert!-<v)
6480                                            (/=v . assert!-=v)
6481                                            (funcallv . assert!-notv-funcallv)
6482                                            (applyv . assert!-notv-applyv)
6483                                            (equalv . assert!-notv-equalv)))
6484                                      :test #'eq))
6485                          arguments)
6486                    (cons (cdr (assoc (first form)
6487                                      (if polarity?
6488                                          '((integerpv . assert!-notv-integerpv)
6489                                            (realpv . assert!-notv-realpv)
6490                                            (numberpv . assert!-notv-numberpv)
6491                                            (memberv . assert!-notv-memberv)
6492                                            (booleanpv . assert!-notv-booleanpv)
6493                                            (=v . assert!-/=v)
6494                                            (<v . assert!->=v)
6495                                            (<=v . assert!->v)
6496                                            (>v . assert!-<=v)
6497                                            (>=v . assert!-<v)
6498                                            (/=v . assert!-=v)
6499                                            (funcallv . assert!-notv-funcallv)
6500                                            (applyv . assert!-notv-applyv)
6501                                            (equalv . assert!-notv-equalv))
6502                                          '((integerpv . assert!-integerpv)
6503                                            (realpv . assert!-realpv)
6504                                            (numberpv . assert!-numberpv)
6505                                            (memberv . assert!-memberv)
6506                                            (booleanpv . assert!-booleanpv)
6507                                            (=v . assert!-=v)
6508                                            (<v . assert!-<v)
6509                                            (<=v . assert!-<=v)
6510                                            (>v . assert!->v)
6511                                            (>=v . assert!->=v)
6512                                            (/=v . assert!-/=v)
6513                                            (funcallv . assert!-funcallv)
6514                                            (applyv . assert!-applyv)
6515                                            (equalv . assert!-equalv)))
6516                                      :test #'eq))
6517                          arguments))))
6518         (t (let ((argument (gensym "ARGUMENT-")))
6519              (values (list (list argument form))
6520                      (if polarity?
6521                          `(assert!-true ,argument)
6522                          `(assert!-false ,argument))
6523                      (if polarity?
6524                          `(assert!-false ,argument)
6525                          `(assert!-true ,argument))))))
6526       (let ((argument (gensym "ARGUMENT-")))
6527         (values
6528          (list (list argument form))
6529          (if polarity? `(assert!-true ,argument) `(assert!-false ,argument))
6530          (if polarity? `(assert!-false ,argument) `(assert!-true ,argument))))))
6531
6532 (defmacro-compile-time decide (form)
6533   (cl:multiple-value-bind (arguments true false)
6534       (transform-decide form t)
6535     `(let ,arguments (either (progn ,true t) (progn ,false nil)))))
6536
6537 ;;; Lifted Generators
6538 ;;; note: The following functions could be handled more efficiently as special
6539 ;;;       cases.
6540
6541 (defun a-booleanv (&optional (name nil name?))
6542   (let ((v (if name? (make-variable name) (make-variable))))
6543     (assert! (booleanpv v))
6544     v))
6545
6546 (defun an-integerv (&optional (name nil name?))
6547   (let ((v (if name? (make-variable name) (make-variable))))
6548     (assert! (integerpv v))
6549     v))
6550
6551 (defun an-integer-abovev (low &optional (name nil name?))
6552   (let ((v (if name? (make-variable name) (make-variable))))
6553     (assert! (andv (integerpv v) (>=v v low)))
6554     v))
6555
6556 (defun an-integer-belowv (high &optional (name nil name?))
6557   (let ((v (if name? (make-variable name) (make-variable))))
6558     (assert! (andv (integerpv v) (<=v v high)))
6559     v))
6560
6561 (defun an-integer-betweenv (low high &optional (name nil name?))
6562   (let ((v (if name? (make-variable name) (make-variable))))
6563     (assert! (andv (integerpv v) (>=v v low) (<=v v high)))
6564     (value-of v)))
6565
6566 (defun a-realv (&optional (name nil name?))
6567   (let ((v (if name? (make-variable name) (make-variable))))
6568     (assert! (realpv v))
6569     v))
6570
6571 (defun a-real-abovev (low &optional (name nil name?))
6572   (let ((v (if name? (make-variable name) (make-variable))))
6573     (assert! (andv (realpv v) (>=v v low)))
6574     v))
6575
6576 (defun a-real-belowv (high &optional (name nil name?))
6577   (let ((v (if name? (make-variable name) (make-variable))))
6578     (assert! (andv (realpv v) (<=v v high)))
6579     v))
6580
6581 (defun a-real-betweenv (low high &optional (name nil name?))
6582   (let ((v (if name? (make-variable name) (make-variable))))
6583     (assert! (andv (realpv v) (>=v v low) (<=v v high)))
6584     v))
6585
6586 (defun a-numberv (&optional (name nil name?))
6587   (let ((v (if name? (make-variable name) (make-variable))))
6588     (assert! (numberpv v))
6589     v))
6590
6591 (defun a-member-ofv (values &optional (name nil name?))
6592   (let ((v (if name? (make-variable name) (make-variable))))
6593     (assert! (memberv v values))
6594     (value-of v)))
6595
6596 ;;; Search Control
6597
6598 (defun variables-in (x)
6599   (typecase x
6600     (cons (append (variables-in (car x)) (variables-in (cdr x))))
6601     (variable (list x))
6602     (otherwise nil)))
6603
6604 ;;; note: SOLUTION and LINEAR-FORCE used to be here but was moved to be before
6605 ;;;       KNOWN?-CONSTRAINT to avoid forward references to nondeterministic
6606 ;;;       functions.
6607
6608 (defun divide-and-conquer-force (variable)
6609   (let ((variable (value-of variable)))
6610     (if (variable? variable)
6611         (cond
6612           ((not (eq (variable-enumerated-domain variable) t))
6613            (let ((n (floor (length (variable-enumerated-domain variable)) 2)))
6614              (set-enumerated-domain!
6615               variable
6616               (either (subseq (variable-enumerated-domain variable) 0 n)
6617                       (subseq (variable-enumerated-domain variable) n)))
6618              (run-noticers variable)))
6619           ((and (variable-real? variable)
6620                 (variable-lower-bound variable)
6621                 (variable-upper-bound variable))
6622            (if (variable-integer? variable)
6623                (let ((midpoint (floor (+ (variable-lower-bound variable)
6624                                          (variable-upper-bound variable))
6625                                       2)))
6626                  (either (let ((old-bound (variable-upper-bound variable)))
6627                            (restrict-upper-bound! variable midpoint)
6628                            (if (= old-bound (variable-upper-bound variable))
6629                                (fail)))
6630                          (let ((old-bound (variable-lower-bound variable)))
6631                            (restrict-lower-bound! variable (1+ midpoint))
6632                            (if (= old-bound (variable-lower-bound variable))
6633                                (fail)))))
6634                (let ((midpoint (/ (+ (variable-lower-bound variable)
6635                                      (variable-upper-bound variable))
6636                                   2)))
6637                  (either (let ((old-bound (variable-upper-bound variable)))
6638                            (restrict-upper-bound! variable midpoint)
6639                            (if (= old-bound (variable-upper-bound variable))
6640                                (fail)))
6641                          (let ((old-bound (variable-lower-bound variable)))
6642                            (restrict-lower-bound! variable midpoint)
6643                            (if (= old-bound (variable-lower-bound variable))
6644                                (fail)))))))
6645           (t (error "It is only possible to divide and conquer force a~%~
6646                   variable that has a countable domain or a finite range")))))
6647   (value-of variable))
6648
6649 ;;; note: STATIC-ORDERING used to be here but was moved to be before
6650 ;;;       KNOWN?-CONSTRAINT to avoid a forward reference to a nondeterministic
6651 ;;;       function.
6652
6653 (defun domain-size (x)
6654   (let ((x (value-of x)))
6655     (typecase x
6656       (cons (infinity-* (domain-size (car x)) (domain-size (cdr x))))
6657       (variable
6658        (cond ((not (eq (variable-enumerated-domain x) t))
6659               (length (variable-enumerated-domain x)))
6660              ((and (variable-lower-bound x)
6661                    (variable-upper-bound x)
6662                    (variable-integer? x))
6663               (1+ (- (variable-upper-bound x) (variable-lower-bound x))))
6664              (t nil)))
6665       (otherwise 1))))
6666
6667 (defun range-size (x)
6668   (let ((x (value-of x)))
6669     (typecase x
6670       (integer 0)
6671       (real 0.0)
6672       (variable (and (variable-real? x)
6673                      (variable-lower-bound x)
6674                      (variable-upper-bound x)
6675                      (- (variable-upper-bound x) (variable-lower-bound x))))
6676       (otherwise nil))))
6677
6678 (defun corrupted? (variable)
6679   (let* ((lower-bound (variable-lower-bound variable))
6680          (upper-bound (variable-upper-bound variable)))
6681     (and lower-bound
6682          upper-bound
6683          (/= lower-bound upper-bound)
6684          (let ((midpoint (/ (+ lower-bound upper-bound) 2)))
6685            (or (= midpoint lower-bound) (= midpoint upper-bound))))))
6686
6687 (defun find-best (cost order list)
6688   (let ((best nil)
6689         (best-cost nil))
6690     (dolist (x list)
6691       (let ((x (value-of x)))
6692         (if (and (variable? x) (not (corrupted? x)))
6693             (let ((cost (funcall cost x)))
6694               (when (and (not (null cost))
6695                          (or (null best-cost) (funcall order cost best-cost)))
6696                 (setf best x)
6697                 (setf best-cost cost))))))
6698     best))
6699
6700 (defun reorder-internal
6701     (variables cost-function terminate? order force-function)
6702   (let ((variable (find-best cost-function order variables)))
6703     (when (and variable
6704                (not (funcall terminate? (funcall cost-function variable))))
6705       (funcall-nondeterministic force-function (value-of variable))
6706       (reorder-internal
6707        variables cost-function terminate? order force-function))))
6708
6709 (defun reorder (cost-function terminate? order force-function)
6710   ;; note: This closure will heap cons.
6711   (let ((cost-function (value-of cost-function))
6712         (terminate? (value-of terminate?))
6713         (order (value-of order))
6714         (force-function (value-of force-function)))
6715     #'(lambda (variables)
6716         (reorder-internal
6717          variables cost-function terminate? order force-function))))
6718
6719 (defmacro-compile-time best-value
6720     (form1 objective-form &optional (form2 nil form2?))
6721   (let ((bound (gensym "BOUND-"))
6722         (best (gensym "BEST-"))
6723         (objective (gensym "OBJECTIVE-")))
6724     `(let ((,bound nil)
6725            (,best nil)
6726            (,objective (variablize ,objective-form)))
6727        (attach-noticer!
6728         #'(lambda ()
6729             (if (and ,bound (<= (variable-upper-bound ,objective) ,bound)) (fail)))
6730         ,objective)
6731        (for-effects
6732          (let ((value ,form1))
6733            (global (setf ,bound (variable-upper-bound ,objective))
6734                    (setf ,best value))))
6735        (if ,bound (list ,best ,bound) ,(if form2? form2 '(fail))))))
6736
6737 (defun template-internal (template variables)
6738   (cond
6739     ((and (symbolp template) (char= #\? (aref (string template) 0)))
6740      (let ((binding (assoc template variables :test #'eq)))
6741        (if binding
6742            (values (cdr binding) variables)
6743            (let ((variable (make-variable template)))
6744              (values variable (cons (cons template variable) variables))))))
6745     ((consp template)
6746      (cl:multiple-value-bind (car-template car-variables)
6747          (template-internal (car template) variables)
6748        (cl:multiple-value-bind (cdr-template cdr-variables)
6749            (template-internal (cdr template) car-variables)
6750          (values (cons car-template cdr-template) cdr-variables))))
6751     (t (values template variables))))
6752
6753 (defun template (template)
6754   (template-internal (value-of template) '()))
6755
6756 (eval-when (:compile-toplevel :load-toplevel :execute)
6757   (setf *screamer?* nil))
6758
6759 (eval-when (:compile-toplevel :load-toplevel :execute)
6760   (pushnew :screamer *features* :test #'eq))
6761
6762 ;;; Tam V'Nishlam Shevah L'El Borei Olam