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   (declare (ignore function arguments))
3270   (screamer-error
3271    "FUNCALL-NONDETERMINISTIC is a nondeterministic function. As such, it~%~
3272    must be called only from a nondeterministic context."))
3273
3274 (cl:defun funcall-nondeterministic-nondeterministic
3275     (continuation function &rest arguments)
3276   (let ((function (value-of function)))
3277     (if (nondeterministic-function? function)
3278         (apply (nondeterministic-function-function function)
3279                continuation
3280                arguments)
3281         (funcall continuation (apply function arguments)))))
3282
3283 (eval-when (:compile-toplevel :load-toplevel :execute)
3284   (declare-nondeterministic 'apply-nondeterministic))
3285
3286 (cl:defun apply-nondeterministic (function argument &rest arguments)
3287   (declare (ignore function argument arguments))
3288   (screamer-error
3289    "APPLY-NONDETERMINISTIC is a nondeterministic function. As such, it must~%~
3290    be called only from a nondeterministic context."))
3291
3292 (cl:defun apply-nondeterministic-nondeterministic
3293     (continuation function argument &rest arguments)
3294   (let ((function (value-of function)))
3295     (if (nondeterministic-function? function)
3296         ;; note: I don't know how to avoid the consing here.
3297         (apply (nondeterministic-function-function function)
3298                continuation
3299                (apply #'list* (cons argument arguments)))
3300         (funcall continuation (apply function argument arguments)))))
3301
3302 (defmacro-compile-time multiple-value-bind
3303     (variables form &body body &environment environment)
3304   (if (every #'(lambda (form) (deterministic? form environment))
3305              (peal-off-documentation-string-and-declarations body))
3306       `(cl:multiple-value-bind ,variables ,form ,@body)
3307       (let ((other-arguments (gensym "OTHER-")))
3308         `(multiple-value-call-nondeterministic
3309           #'(lambda (&optional ,@variables &rest ,other-arguments)
3310               (declare (ignore ,other-arguments))
3311               ,@body)
3312           ,form))))
3313
3314 (defun unwind-trail ()
3315   (tagbody
3316    loop
3317      (if (zerop (fill-pointer *trail*)) (return-from unwind-trail))
3318      (funcall (vector-pop *trail*))
3319      ;; note: This is to allow the trail closures to be garbage collected.
3320      (setf (aref *trail* (fill-pointer *trail*)) nil)
3321      (go loop)))
3322
3323 (defun purge (function-name)
3324   (remhash (value-of function-name) *function-record-table*)
3325   t)
3326
3327 (defun unwedge-screamer ()
3328   (maphash #'(lambda (function-name function-record)
3329                (unless (function-record-screamer? function-record)
3330                  (remhash function-name *function-record-table*)))
3331            *function-record-table*)
3332   t)
3333
3334 ;;; note: These optimized versions of AN-INTEGER, AN-INTEGER-ABOVE,
3335 ;;;       AN-INTEGER-BELOW, AN-INTEGER-BETWEEN and A-MEMBER-OF have different
3336 ;;;       failure behavior as far as WHEN-FAILING is concerned than the
3337 ;;;       original purely Screamer versions. This is likely to affect only
3338 ;;;       failure counts generated by COUNT-FAILURES. A small price to pay for
3339 ;;;       tail recursion optimization.
3340
3341 (eval-when (:compile-toplevel :load-toplevel :execute)
3342   (declare-nondeterministic 'an-integer))
3343
3344 (cl:defun an-integer ()
3345   (screamer-error
3346    "AN-INTEGER is a nondeterministic function. As such, it must be called~%~
3347    only from a nondeterministic context."))
3348
3349 (cl:defun an-integer-nondeterministic (continuation)
3350   (choice-point-external
3351    (choice-point-internal (funcall continuation 0))
3352    (let ((i 1))
3353      (loop (choice-point-internal (funcall continuation i))
3354        (choice-point-internal (funcall continuation (- i)))
3355        (incf i)))))
3356
3357 (eval-when (:compile-toplevel :load-toplevel :execute)
3358   (declare-nondeterministic 'an-integer-above))
3359
3360 (cl:defun an-integer-above (low)
3361   (declare (ignore low))
3362   (screamer-error
3363    "AN-INTEGER-ABOVE is a nondeterministic function. As such, it must be~%~
3364    called only from a nondeterministic context."))
3365
3366 (cl:defun an-integer-above-nondeterministic (continuation low)
3367   (let ((low (ceiling (value-of low))))
3368     (choice-point-external
3369      (let ((i low))
3370        (loop (choice-point-internal (funcall continuation i))
3371          (incf i))))))
3372
3373 (eval-when (:compile-toplevel :load-toplevel :execute)
3374   (declare-nondeterministic 'an-integer-below))
3375
3376 (cl:defun an-integer-below (high)
3377   (declare (ignore high))
3378   (screamer-error
3379    "AN-INTEGER-BELOW is a nondeterministic function. As such, it must be~%~
3380    called only from a nondeterministic context."))
3381
3382 (cl:defun an-integer-below-nondeterministic (continuation high)
3383   (let ((high (floor (value-of high))))
3384     (choice-point-external
3385      (let ((i high))
3386        (loop (choice-point-internal (funcall continuation i))
3387          (decf i))))))
3388
3389 (eval-when (:compile-toplevel :load-toplevel :execute)
3390   (declare-nondeterministic 'an-integer-between))
3391
3392 (cl:defun an-integer-between (low high)
3393   (declare (ignore low high))
3394   (screamer-error
3395    "AN-INTEGER-BETWEEN is a nondeterministic function. As such, it must be~%~
3396    called only from a nondeterministic context."))
3397
3398 (cl:defun an-integer-between-nondeterministic (continuation low high)
3399   (let ((low (ceiling (value-of low)))
3400         (high (floor (value-of high))))
3401     (unless (> low high)
3402       (choice-point-external
3403        (do ((i low (1+ i))) ((= i high))
3404          (choice-point-internal (funcall continuation i))))
3405       (funcall continuation high))))
3406
3407 (eval-when (:compile-toplevel :load-toplevel :execute)
3408   (declare-nondeterministic 'a-member-of))
3409
3410 (cl:defun a-member-of (sequence)
3411   (declare (ignore sequence))
3412   (screamer-error
3413    "A-MEMBER-OF is a nondeterministic function. As such, it must be called~%~
3414    only from a nondeterministic context."))
3415
3416 (cl:defun a-member-of-nondeterministic (continuation sequence)
3417   (let ((sequence (value-of sequence)))
3418     (cond
3419       ((listp sequence)
3420        (unless (null sequence)
3421          (choice-point-external
3422           (loop (if (null (rest sequence)) (return))
3423             (choice-point-internal (funcall continuation (first sequence)))
3424             (setf sequence (value-of (rest sequence)))))
3425          (funcall continuation (first sequence))))
3426       ((vectorp sequence)
3427        (let ((n (1- (length sequence))))
3428          (unless (zerop n)
3429            (choice-point-external
3430             (dotimes (i n)
3431               (choice-point-internal (funcall continuation (aref sequence i)))))
3432            (funcall continuation (aref sequence n)))))
3433       (t (error "SEQUENCE must be a sequence")))))
3434
3435 ;;; note: The following two functions work only when Screamer is running under
3436 ;;;       ILisp/GNUEmacs with iscream.el loaded.
3437
3438 (defun emacs-eval (expression)
3439   (unless *iscream?*
3440     (error "Cannot do EMACS-EVAL unless Screamer is running under~%~
3441           ILisp/GNUEmacs with iscream.el loaded."))
3442   (format *terminal-io* "~A~A~A"
3443           (format nil "~A" (code-char 27))
3444           (string-downcase (format nil "~A" expression))
3445           (format nil "~A" (code-char 29))))
3446
3447 (defmacro-compile-time local-output (&body forms)
3448   `(progn
3449      (unless *iscream?*
3450        (error "Cannot do LOCAL-OUTPUT unless Screamer is running under~%~
3451             ILisp/GNUEmacs with iscream.el loaded."))
3452      (trail #'(lambda () (emacs-eval '(pop-end-marker))))
3453      (emacs-eval '(push-end-marker))
3454      ,@forms))
3455
3456 ;;; Constraints
3457
3458 (defvar *name* 0 "The counter for anonymous names.")
3459
3460 (defvar *minimum-shrink-ratio* 1e-2
3461   "Ignore propagations which reduce the range of a variable by less than this
3462    ratio.")
3463
3464 (defvar *maximum-discretization-range* 20
3465   "Discretize integer variables whose range is not greater than this number.
3466    Discretize all integer variables if NIL.
3467    Must be an integer or NIL.")
3468
3469 (defvar *strategy* :gfc
3470   "Strategy to use for FUNCALLV and APPLYV: either :GFC or :AC")
3471
3472 ;;; note: Enable this to use CLOS instead of DEFSTRUCT for variables.
3473 #+(or)
3474 (eval-when (:compile-toplevel :load-toplevel :execute)
3475   (pushnew :screamer-clos *features* :test #'eq))
3476
3477 #-screamer-clos
3478 (defstruct-compile-time (variable (:print-function print-variable)
3479                                   (:predicate variable?)
3480                                   (:constructor make-variable-internal))
3481   name
3482   (noticers nil)
3483   (enumerated-domain t)
3484   (enumerated-antidomain nil)
3485   value
3486   (possibly-integer? t)
3487   (possibly-noninteger-real? t)
3488   (possibly-nonreal-number? t)
3489   (possibly-boolean? t)
3490   (possibly-nonboolean-nonnumber? t)
3491   (lower-bound nil)
3492   (upper-bound nil))
3493
3494 #+screamer-clos
3495 (defclass variable ()
3496   ((name :accessor variable-name :initarg :name)
3497    (noticers :accessor variable-noticers :initform nil)
3498    (enumerated-domain :accessor variable-enumerated-domain :initform t)
3499    (enumerated-antidomain :accessor variable-enumerated-antidomain
3500                           :initform nil)
3501    (value :accessor variable-value)
3502    (possibly-integer? :accessor variable-possibly-integer? :initform t)
3503    (possibly-noninteger-real? :accessor variable-possibly-noninteger-real?
3504                               :initform t)
3505    (possibly-nonreal-number? :accessor variable-possibly-nonreal-number?
3506                              :initform t)
3507    (possibly-boolean? :accessor variable-possibly-boolean? :initform t)
3508    (possibly-nonboolean-nonnumber?
3509     :accessor variable-possibly-nonboolean-nonnumber?
3510     :initform t)
3511    (lower-bound :accessor variable-lower-bound :initform nil)
3512    (upper-bound :accessor variable-upper-bound :initform nil)))
3513
3514 #+screamer-clos
3515 (defmethod print-object ((variable variable) stream)
3516   (print-variable variable stream nil))
3517
3518 #+screamer-clos
3519 (defun-compile-time variable? (thing) (typep thing 'variable))
3520
3521 (defun booleanp (x) (typep x 'boolean))
3522
3523 (defun infinity-min (x y) (and x y (min x y)))
3524
3525 (defun infinity-max (x y) (and x y (max x y)))
3526
3527 (defun infinity-+ (x y) (and x y (+ x y)))
3528
3529 (defun infinity-- (x y) (and x y (- x y)))
3530
3531 (defun infinity-* (x y) (and x y (* x y)))
3532
3533 (defun contains-variables? (x)
3534   (typecase x
3535     (cons (or (contains-variables? (car x)) (contains-variables? (cdr x))))
3536     (variable t)
3537     (otherwise nil)))
3538
3539 (defun eliminate-variables (x)
3540   (if (contains-variables? x)
3541       (if (consp x)
3542           (cons (eliminate-variables (car x)) (eliminate-variables (cdr x)))
3543           (eliminate-variables (variable-value x)))
3544       x))
3545
3546 (defun print-variable (x stream print-level)
3547   (declare (ignore print-level))
3548   (let ((x (value-of x)))
3549     (cond
3550       ((variable? x)
3551        (if (and (not (eq (variable-enumerated-domain x) t))
3552                 (not (null (variable-enumerated-antidomain x))))
3553            (error "This shouldn't happen"))
3554        (format stream "[~S" (variable-name x))
3555        (format stream "~A"
3556                (cond ((variable-boolean? x) " Boolean")
3557                      ((variable-integer? x) " integer")
3558                      ((variable-real? x)
3559                       (if (variable-noninteger? x) " noninteger-real" " real"))
3560                      ((variable-number? x)
3561                       (cond ((variable-nonreal? x) " nonreal-number")
3562                             ((variable-noninteger? x) " noninteger-number")
3563                             (t " number")))
3564                      ((variable-nonnumber? x) " nonnumber")
3565                      ((variable-nonreal? x) " nonreal")
3566                      ((variable-noninteger? x) " noninteger")
3567                      (t "")))
3568        (if (variable-real? x)
3569            (if (variable-lower-bound x)
3570                (if (variable-upper-bound x)
3571                    (format stream " ~D:~D"
3572                            (variable-lower-bound x) (variable-upper-bound x))
3573                    (format stream " ~D:" (variable-lower-bound x)))
3574                (if (variable-upper-bound x)
3575                    (format stream " :~D" (variable-upper-bound x)))))
3576        (if (and (not (eq (variable-enumerated-domain x) t))
3577                 (not (variable-boolean? x)))
3578            (format stream " enumerated-domain:~S"
3579                    (variable-enumerated-domain x)))
3580        (if (not (null (variable-enumerated-antidomain x)))
3581            (format stream " enumerated-antidomain:~S"
3582                    (variable-enumerated-antidomain x)))
3583        (format stream "]"))
3584       (t (format stream "~S" x)))))
3585
3586 (defun make-variable (&optional (name nil name?))
3587   (let ((variable
3588          #-screamer-clos
3589           (make-variable-internal :name (if name? name (incf *name*)))
3590           #+screamer-clos
3591           (make-instance 'variable :name (if name? name (incf *name*)))))
3592     (setf (variable-value variable) variable)
3593     variable))
3594
3595 (defun variable-integer? (x)
3596   (and (not (variable-possibly-boolean? x))
3597        (not (variable-possibly-nonboolean-nonnumber? x))
3598        (not (variable-possibly-nonreal-number? x))
3599        (not (variable-possibly-noninteger-real? x))
3600        (variable-possibly-integer? x)))
3601
3602 (defun variable-noninteger? (x)
3603   (and (or (variable-possibly-boolean? x)
3604            (variable-possibly-nonboolean-nonnumber? x)
3605            (variable-possibly-nonreal-number? x)
3606            (variable-possibly-noninteger-real? x))
3607        (not (variable-possibly-integer? x))))
3608
3609 (defun variable-real? (x)
3610   (and (not (variable-possibly-boolean? x))
3611        (not (variable-possibly-nonboolean-nonnumber? x))
3612        (not (variable-possibly-nonreal-number? x))
3613        (or (variable-possibly-noninteger-real? x)
3614            (variable-possibly-integer? x))))
3615
3616 (defun variable-nonreal? (x)
3617   (and (or (variable-possibly-boolean? x)
3618            (variable-possibly-nonboolean-nonnumber? x)
3619            (variable-possibly-nonreal-number? x))
3620        (not (variable-possibly-noninteger-real? x))
3621        (not (variable-possibly-integer? x))))
3622
3623 (defun variable-number? (x)
3624   (and (not (variable-possibly-boolean? x))
3625        (not (variable-possibly-nonboolean-nonnumber? x))
3626        (or (variable-possibly-nonreal-number? x)
3627            (variable-possibly-noninteger-real? x)
3628            (variable-possibly-integer? x))))
3629
3630 (defun variable-nonnumber? (x)
3631   (and (or (variable-possibly-boolean? x)
3632            (variable-possibly-nonboolean-nonnumber? x))
3633        (not (variable-possibly-nonreal-number? x))
3634        (not (variable-possibly-noninteger-real? x))
3635        (not (variable-possibly-integer? x))))
3636
3637 (defun variable-boolean? (x)
3638   (and (variable-possibly-boolean? x)
3639        (not (variable-possibly-nonboolean-nonnumber? x))
3640        (not (variable-possibly-nonreal-number? x))
3641        (not (variable-possibly-noninteger-real? x))
3642        (not (variable-possibly-integer? x))))
3643
3644 (defun variable-nonboolean? (x)
3645   (and (not (variable-possibly-boolean? x))
3646        (or (variable-possibly-nonboolean-nonnumber? x)
3647            (variable-possibly-nonreal-number? x)
3648            (variable-possibly-noninteger-real? x)
3649            (variable-possibly-integer? x))))
3650
3651 (defun variable-true? (x) (eq (variable-value x) t))
3652
3653 (defun variable-false? (x) (null (variable-value x)))
3654
3655 (defun value-of (x)
3656   (tagbody
3657    loop
3658      (if (or (not (variable? x))
3659              #+screamer-clos (not (slot-boundp x 'value))
3660              (eq (variable-value x) x))
3661          (return-from value-of x))
3662      (setf x (variable-value x))
3663      (go loop)))
3664
3665 (defun variablize (x)
3666   (if (variable? x)
3667       (tagbody
3668        loop
3669          (if (or (not (variable? (variable-value x)))
3670                  (eq (variable-value x) x))
3671              (return-from variablize x))
3672          (setf x (variable-value x))
3673          (go loop))
3674       (let ((y (make-variable))) (restrict-value! y x) y)))
3675
3676 (defun bound? (x) (not (variable? (value-of x))))
3677
3678 (defun ground? (x)
3679   (let ((x (value-of x)))
3680     (and (not (variable? x))
3681          (or (not (consp x)) (and (ground? (car x)) (ground? (cdr x)))))))
3682
3683 (defun apply-substitution (x)
3684   (let ((x (value-of x)))
3685     (if (consp x)
3686         (cons (apply-substitution (car x)) (apply-substitution (cdr x)))
3687         x)))
3688
3689 (defun occurs-in? (x value)
3690   ;; note: X must be a variable such that (EQ X (VALUE-OF X)).
3691   ;; note: Will loop if VALUE is circular.
3692   (cond
3693     ((eq x value) t)
3694     ((and (variable? value) (not (eq value (variable-value value))))
3695      (occurs-in? x (variable-value value)))
3696     ((consp value) (or (occurs-in? x (car value)) (occurs-in? x (cdr value))))
3697     (t nil)))
3698
3699 (defun attach-noticer!-internal (noticer x)
3700   ;; note: Will loop if X is circular.
3701   (typecase x
3702     (cons (attach-noticer!-internal noticer (car x))
3703           (attach-noticer!-internal noticer (cdr x)))
3704     (variable (if (eq x (variable-value x))
3705                   ;; note: I can't remember why this check for duplication is
3706                   ;;       here.
3707                   (unless (member noticer (variable-noticers x) :test #'eq)
3708                     ;; note: This can't be a PUSH because of the Lucid screw.
3709                     (local (setf (variable-noticers x)
3710                                  (cons noticer (variable-noticers x)))))
3711                   (attach-noticer!-internal noticer (variable-value x))))))
3712
3713 (defun attach-noticer! (noticer x)
3714   (attach-noticer!-internal noticer x)
3715   (funcall noticer))
3716
3717 (defun run-noticers (x)
3718   (dolist (noticer (variable-noticers x)) (funcall noticer)))
3719
3720 ;;; Restrictions
3721
3722 (defun restrict-integer! (x)
3723   ;; note: X must be a variable.
3724   (unless (variable-possibly-integer? x) (fail))
3725   (if (or (eq (variable-value x) x) (not (variable? (variable-value x))))
3726       (let ((run? nil))
3727         (when (variable-possibly-noninteger-real? x)
3728           (local (setf (variable-possibly-noninteger-real? x) nil))
3729           (setf run? t))
3730         (when (variable-possibly-nonreal-number? x)
3731           (local (setf (variable-possibly-nonreal-number? x) nil))
3732           (setf run? t))
3733         (when (variable-possibly-boolean? x)
3734           (local (setf (variable-possibly-boolean? x) nil))
3735           (setf run? t))
3736         (when (variable-possibly-nonboolean-nonnumber? x)
3737           (local (setf (variable-possibly-nonboolean-nonnumber? x) nil))
3738           (setf run? t))
3739         (when (and (variable-lower-bound x)
3740                    (not (integerp (variable-lower-bound x))))
3741           (if (and (variable-upper-bound x)
3742                    (< (variable-upper-bound x)
3743                       (ceiling (variable-lower-bound x))))
3744               (fail))
3745           (local (setf (variable-lower-bound x)
3746                        (ceiling (variable-lower-bound x))))
3747           (setf run? t))
3748         (when (and (variable-upper-bound x)
3749                    (not (integerp (variable-upper-bound x))))
3750           (if (and (variable-lower-bound x)
3751                    (> (variable-lower-bound x)
3752                       (floor (variable-upper-bound x))))
3753               (fail))
3754           (local (setf (variable-upper-bound x) (floor (variable-upper-bound x))))
3755           (setf run? t))
3756         (when run?
3757           (cond ((eq (variable-enumerated-domain x) t)
3758                  (if (and (variable-lower-bound x)
3759                           (variable-upper-bound x)
3760                           (or (null *maximum-discretization-range*)
3761                               (<= (- (variable-upper-bound x)
3762                                      (variable-lower-bound x))
3763                                   *maximum-discretization-range*)))
3764                      (set-enumerated-domain!
3765                       x (all-values (an-integer-between
3766                                      (variable-lower-bound x)
3767                                      (variable-upper-bound x))))))
3768                 ((not (every #'integerp (variable-enumerated-domain x)))
3769                  ;; note: Could do less consing if had LOCAL DELETE-IF.
3770                  ;;       This would also allow checking list only once.
3771                  (set-enumerated-domain!
3772                   x (remove-if-not #'integerp (variable-enumerated-domain x)))))
3773           (run-noticers x)))))
3774
3775 (defun restrict-noninteger! (x)
3776   ;; note: X must be a variable.
3777   (unless (or (variable-possibly-noninteger-real? x)
3778               (variable-possibly-nonreal-number? x)
3779               (variable-possibly-boolean? x)
3780               (variable-possibly-nonboolean-nonnumber? x))
3781     (fail))
3782   (when (and (or (eq (variable-value x) x) (not (variable? (variable-value x))))
3783              (variable-possibly-integer? x))
3784     (local (setf (variable-possibly-integer? x) nil))
3785     (if (and (not (eq (variable-enumerated-domain x) t))
3786              (some #'integerp (variable-enumerated-domain x)))
3787         ;; note: Could do less consing if had LOCAL DELETE-IF.
3788         ;;       This would also allow checking list only once.
3789         (set-enumerated-domain!
3790          x (remove-if #'integerp (variable-enumerated-domain x))))
3791     (run-noticers x)))
3792
3793 (defun restrict-real! (x)
3794   ;; note: X must be a variable.
3795   (unless (or (variable-possibly-integer? x)
3796               (variable-possibly-noninteger-real? x))
3797     (fail))
3798   (if (or (eq (variable-value x) x) (not (variable? (variable-value x))))
3799       (let ((run? nil))
3800         (when (variable-possibly-nonreal-number? x)
3801           (local (setf (variable-possibly-nonreal-number? x) nil))
3802           (setf run? t))
3803         (when (variable-possibly-boolean? x)
3804           (local (setf (variable-possibly-boolean? x) nil))
3805           (setf run? t))
3806         (when (variable-possibly-nonboolean-nonnumber? x)
3807           (local (setf (variable-possibly-nonboolean-nonnumber? x) nil))
3808           (setf run? t))
3809         (when run?
3810           (if (and (not (eq (variable-enumerated-domain x) t))
3811                    (not (every #'realp (variable-enumerated-domain x))))
3812               ;; note: Could do less consing if had LOCAL DELETE-IF.
3813               ;;       This would also allow checking list only once.
3814               (set-enumerated-domain!
3815                x (remove-if-not #'realp (variable-enumerated-domain x))))
3816           (run-noticers x)))))
3817
3818 (defun restrict-nonreal! (x)
3819   ;; note: X must be a variable.
3820   (unless (or (variable-possibly-nonreal-number? x)
3821               (variable-possibly-boolean? x)
3822               (variable-possibly-nonboolean-nonnumber? x))
3823     (fail))
3824   (if (or (eq (variable-value x) x) (not (variable? (variable-value x))))
3825       (let ((run? nil))
3826         (when (variable-possibly-integer? x)
3827           (local (setf (variable-possibly-integer? x) nil))
3828           (setf run? t))
3829         (when (variable-possibly-noninteger-real? x)
3830           (local (setf (variable-possibly-noninteger-real? x) nil))
3831           (setf run? t))
3832         (when run?
3833           (if (and (not (eq (variable-enumerated-domain x) t))
3834                    (some #'realp (variable-enumerated-domain x)))
3835               ;; note: Could do less consing if had LOCAL DELETE-IF.
3836               ;;       This would also allow checking list only once.
3837               (set-enumerated-domain!
3838                x (remove-if #'realp (variable-enumerated-domain x))))
3839           (run-noticers x)))))
3840
3841 (defun restrict-number! (x)
3842   ;; note: X must be a variable.
3843   (unless (or (variable-possibly-integer? x)
3844               (variable-possibly-noninteger-real? x)
3845               (variable-possibly-nonreal-number? x))
3846     (fail))
3847   (if (or (eq (variable-value x) x) (not (variable? (variable-value x))))
3848       (let ((run? nil))
3849         (when (variable-possibly-boolean? x)
3850           (local (setf (variable-possibly-boolean? x) nil))
3851           (setf run? t))
3852         (when (variable-possibly-nonboolean-nonnumber? x)
3853           (local (setf (variable-possibly-nonboolean-nonnumber? x) nil))
3854           (setf run? t))
3855         (when run?
3856           (if (and (not (eq (variable-enumerated-domain x) t))
3857                    (not (every #'numberp (variable-enumerated-domain x))))
3858               ;; note: Could do less consing if had LOCAL DELETE-IF.
3859               ;;       This would also allow checking list only once.
3860               (set-enumerated-domain!
3861                x (remove-if-not #'numberp (variable-enumerated-domain x))))
3862           (run-noticers x)))))
3863
3864 (defun restrict-nonnumber! (x)
3865   ;; note: X must be a variable.
3866   (unless (or (variable-possibly-boolean? x)
3867               (variable-possibly-nonboolean-nonnumber? x))
3868     (fail))
3869   (if (or (eq (variable-value x) x) (not (variable? (variable-value x))))
3870       (let ((run? nil))
3871         (when (variable-possibly-integer? x)
3872           (local (setf (variable-possibly-integer? x) nil))
3873           (setf run? t))
3874         (when (variable-possibly-noninteger-real? x)
3875           (local (setf (variable-possibly-noninteger-real? x) nil))
3876           (setf run? t))
3877         (when (variable-possibly-nonreal-number? x)
3878           (local (setf (variable-possibly-nonreal-number? x) nil))
3879           (setf run? t))
3880         (when run?
3881           (if (and (not (eq (variable-enumerated-domain x) t))
3882                    (some #'numberp (variable-enumerated-domain x)))
3883               ;; note: Could do less consing if had LOCAL DELETE-IF.
3884               ;;       This would also allow checking list only once.
3885               (set-enumerated-domain!
3886                x (remove-if #'numberp (variable-enumerated-domain x))))
3887           (run-noticers x)))))
3888
3889 (defun restrict-boolean! (x)
3890   ;; note: X must be a variable.
3891   (unless (variable-possibly-boolean? x) (fail))
3892   (if (or (eq (variable-value x) x) (not (variable? (variable-value x))))
3893       (let ((run? nil))
3894         (when (variable-possibly-integer? x)
3895           (local (setf (variable-possibly-integer? x) nil))
3896           (setf run? t))
3897         (when (variable-possibly-noninteger-real? x)
3898           (local (setf (variable-possibly-noninteger-real? x) nil))
3899           (setf run? t))
3900         (when (variable-possibly-nonreal-number? x)
3901           (local (setf (variable-possibly-nonreal-number? x) nil))
3902           (setf run? t))
3903         (when (variable-possibly-nonboolean-nonnumber? x)
3904           (local (setf (variable-possibly-nonboolean-nonnumber? x) nil))
3905           (setf run? t))
3906         (when run?
3907           (cond
3908             ((eq (variable-enumerated-domain x) t)
3909              (local
3910                (cond
3911                  ((member t (variable-enumerated-antidomain x) :test #'eq)
3912                   (cond ((member nil (variable-enumerated-antidomain x) :test #'eq)
3913                          (fail))
3914                         (t (setf (variable-enumerated-domain x) '(nil))
3915                            (setf (variable-enumerated-antidomain x) '())
3916                            (setf (variable-value x) nil))))
3917                  ((member nil (variable-enumerated-antidomain x) :test #'eq)
3918                   (setf (variable-enumerated-domain x) '(t))
3919                   (setf (variable-enumerated-antidomain x) '())
3920                   (setf (variable-value x) t))
3921                  (t (setf (variable-enumerated-domain x) '(t nil))
3922                     (unless (null (variable-enumerated-antidomain x))
3923                       (setf (variable-enumerated-antidomain x) '()))))))
3924             ((not (every #'booleanp (variable-enumerated-domain x)))
3925              ;; note: Could do less consing if had LOCAL DELETE-IF.
3926              ;;       This would also allow checking list only once.
3927              (set-enumerated-domain!
3928               x (remove-if-not #'booleanp (variable-enumerated-domain x)))))
3929           (run-noticers x)))))
3930
3931 (defun restrict-nonboolean! (x)
3932   ;; note: X must be a variable.
3933   (unless (or (variable-possibly-integer? x)
3934               (variable-possibly-noninteger-real? x)
3935               (variable-possibly-nonreal-number? x)
3936               (variable-possibly-nonboolean-nonnumber? x))
3937     (fail))
3938   (when (and (or (eq (variable-value x) x) (not (variable? (variable-value x))))
3939              (variable-possibly-boolean? x))
3940     (local (setf (variable-possibly-boolean? x) nil))
3941     (cond ((eq (variable-enumerated-domain x) t)
3942            (local (setf (variable-enumerated-antidomain x)
3943                         (adjoin t
3944                                 (adjoin nil (variable-enumerated-antidomain x)
3945                                         :test #'eq)
3946                                 :test #'eq))))
3947           ((some #'booleanp (variable-enumerated-domain x))
3948            ;; note: Could do less consing if had LOCAL DELETE-IF.
3949            ;;       This would also allow checking list only once.
3950            (set-enumerated-domain!
3951             x (remove-if #'booleanp (variable-enumerated-domain x)))))
3952     (run-noticers x)))
3953
3954 (defun restrict-lower-bound! (x lower-bound)
3955   ;; note: X must be a variable.
3956   ;; note: LOWER-BOUND must be a real constant.
3957   (if (variable-integer? x) (setf lower-bound (ceiling lower-bound)))
3958   (when (and (or (eq (variable-value x) x) (not (variable? (variable-value x))))
3959              (or (not (variable-lower-bound x))
3960                  (> lower-bound (variable-lower-bound x))))
3961     (if (and (variable-upper-bound x) (< (variable-upper-bound x) lower-bound))
3962         (fail))
3963     (when (or (not (variable-lower-bound x))
3964               (not (variable-upper-bound x))
3965               (>= (/ (- lower-bound (variable-lower-bound x))
3966                      (- (variable-upper-bound x) (variable-lower-bound x)))
3967                   *minimum-shrink-ratio*))
3968       (local (setf (variable-lower-bound x) lower-bound))
3969       (cond ((eq (variable-enumerated-domain x) t)
3970              (if (and lower-bound
3971                       (variable-upper-bound x)
3972                       (variable-integer? x)
3973                       (or (null *maximum-discretization-range*)
3974                           (<= (- (variable-upper-bound x) lower-bound)
3975                               *maximum-discretization-range*)))
3976                  (set-enumerated-domain!
3977                   x (all-values (an-integer-between lower-bound
3978                                                     (variable-upper-bound x))))))
3979             ((some #'(lambda (element) (< element lower-bound))
3980                    (variable-enumerated-domain x))
3981              ;; note: Could do less consing if had LOCAL DELETE-IF.
3982              ;;       This would also allow checking list only once.
3983              (set-enumerated-domain!
3984               x (remove-if #'(lambda (element) (< element lower-bound))
3985                            (variable-enumerated-domain x)))))
3986       (run-noticers x))))
3987
3988 (defun restrict-upper-bound! (x upper-bound)
3989   ;; note: X must be a variable.
3990   ;; note: UPPER-BOUND must be a real constant.
3991   (when (variable-integer? x)
3992     (setf upper-bound (floor upper-bound)))
3993   (when (and (or (eq (variable-value x) x) (not (variable? (variable-value x))))
3994              (or (not (variable-upper-bound x))
3995                  (< upper-bound (variable-upper-bound x))))
3996     (when (and (variable-lower-bound x) (> (variable-lower-bound x) upper-bound))
3997       (fail))
3998     (when (or (not (variable-lower-bound x))
3999               (not (variable-upper-bound x))
4000               (>= (/ (- (variable-upper-bound x) upper-bound)
4001                      (- (variable-upper-bound x) (variable-lower-bound x)))
4002                   *minimum-shrink-ratio*))
4003       (local (setf (variable-upper-bound x) upper-bound))
4004       (cond ((eq (variable-enumerated-domain x) t)
4005              (when (and (variable-lower-bound x)
4006                         upper-bound
4007                         (variable-integer? x)
4008                         (or (null *maximum-discretization-range*)
4009                             (<= (- upper-bound (variable-lower-bound x))
4010                                 *maximum-discretization-range*)))
4011                (set-enumerated-domain!
4012                 x (all-values (an-integer-between (variable-lower-bound x)
4013                                                   upper-bound)))))
4014             ((some #'(lambda (element) (> element upper-bound))
4015                    (variable-enumerated-domain x))
4016              ;; note: Could do less consing if had LOCAL DELETE-IF.
4017              ;;       This would also allow checking list only once.
4018              (set-enumerated-domain!
4019               x (remove-if #'(lambda (element) (> element upper-bound))
4020                            (variable-enumerated-domain x)))))
4021       (run-noticers x))))
4022
4023 (defun restrict-bounds! (x lower-bound upper-bound)
4024   ;; note: X must be a variable.
4025   ;; note: LOWER-BOUND and UPPER-BOUND must be real constants.
4026   (when (variable-integer? x)
4027     (if lower-bound (setf lower-bound (ceiling lower-bound)))
4028     (if upper-bound (setf upper-bound (floor upper-bound))))
4029   (if (or (eq (variable-value x) x) (not (variable? (variable-value x))))
4030       (let ((run? nil))
4031         (when (and lower-bound
4032                    (or (not (variable-lower-bound x))
4033                        (> lower-bound (variable-lower-bound x))))
4034           (if (and (variable-upper-bound x)
4035                    (< (variable-upper-bound x) lower-bound))
4036               (fail))
4037           (when (or (not (variable-lower-bound x))
4038                     (not (variable-upper-bound x))
4039                     (>= (/ (- lower-bound (variable-lower-bound x))
4040                            (- (variable-upper-bound x) (variable-lower-bound x)))
4041                         *minimum-shrink-ratio*))
4042             (local (setf (variable-lower-bound x) lower-bound))
4043             (setf run? t)))
4044         (when (and upper-bound
4045                    (or (not (variable-upper-bound x))
4046                        (< upper-bound (variable-upper-bound x))))
4047           (if (and (variable-lower-bound x)
4048                    (> (variable-lower-bound x) upper-bound))
4049               (fail))
4050           (when (or (not (variable-lower-bound x))
4051                     (not (variable-upper-bound x))
4052                     (>= (/ (- (variable-upper-bound x) upper-bound)
4053                            (- (variable-upper-bound x) (variable-lower-bound x)))
4054                         *minimum-shrink-ratio*))
4055             (local (setf (variable-upper-bound x) upper-bound))
4056             (setf run? t)))
4057         (when run?
4058           (cond ((eq (variable-enumerated-domain x) t)
4059                  (if (and (variable-lower-bound x)
4060                           (variable-upper-bound x)
4061                           (variable-integer? x)
4062                           (or (null *maximum-discretization-range*)
4063                               (<= (- (variable-upper-bound x)
4064                                      (variable-lower-bound x))
4065                                   *maximum-discretization-range*)))
4066                      (set-enumerated-domain!
4067                       x (all-values (an-integer-between
4068                                      (variable-lower-bound x)
4069                                      (variable-upper-bound x))))))
4070                 ((or (and lower-bound
4071                           (some #'(lambda (element) (< element lower-bound))
4072                                 (variable-enumerated-domain x)))
4073                      (and upper-bound
4074                           (some #'(lambda (element) (> element upper-bound))
4075                                 (variable-enumerated-domain x))))
4076                  ;; note: Could do less consing if had LOCAL DELETE-IF.
4077                  ;;       This would also allow checking list only once.
4078                  (set-enumerated-domain!
4079                   x (remove-if #'(lambda (element)
4080                                    (or (and lower-bound (< element lower-bound))
4081                                        (and upper-bound (> element upper-bound))))
4082                                (variable-enumerated-domain x)))))
4083           (run-noticers x)))))
4084
4085 (defun share! (x y)
4086   ;; note: X and Y must be variables such that (EQ X (VALUE-OF X)) and
4087   ;;       (EQ Y (VALUE-OF Y)).
4088   (let ((run? nil)
4089         (y-lower-bound? nil)
4090         (y-upper-bound? nil)
4091         (x-lower-bound (variable-lower-bound x))
4092         (x-upper-bound (variable-upper-bound x))
4093         (y-lower-bound (variable-lower-bound y))
4094         (y-upper-bound (variable-upper-bound y)))
4095     (cond ((and (variable-integer? y) (not (variable-integer? x)))
4096            (if x-lower-bound (setf x-lower-bound (ceiling x-lower-bound)))
4097            (if x-upper-bound (setf x-upper-bound (floor x-upper-bound))))
4098           ((and (not (variable-integer? y)) (variable-integer? x))
4099            (when (and y-lower-bound (not (integerp y-lower-bound)))
4100              (setf y-lower-bound (ceiling y-lower-bound))
4101              (setf y-lower-bound? t))
4102            (when (and y-upper-bound (not (integerp y-upper-bound)))
4103              (setf y-upper-bound (floor y-upper-bound))
4104              (setf y-upper-bound? t))))
4105     (when (and (not (variable-possibly-integer? x))
4106                (variable-possibly-integer? y))
4107       (local (setf (variable-possibly-integer? y) nil))
4108       (setf run? t))
4109     (when (and (not (variable-possibly-noninteger-real? x))
4110                (variable-possibly-noninteger-real? y))
4111       (local (setf (variable-possibly-noninteger-real? y) nil))
4112       (setf run? t))
4113     (when (and (not (variable-possibly-nonreal-number? x))
4114                (variable-possibly-nonreal-number? y))
4115       (local (setf (variable-possibly-nonreal-number? y) nil))
4116       (setf run? t))
4117     (when (and (not (variable-possibly-boolean? x))
4118                (variable-possibly-boolean? y))
4119       (local (setf (variable-possibly-boolean? y) nil))
4120       (setf run? t))
4121     (when (and (not (variable-possibly-nonboolean-nonnumber? x))
4122                (variable-possibly-nonboolean-nonnumber? y))
4123       (local (setf (variable-possibly-nonboolean-nonnumber? y) nil))
4124       (setf run? t))
4125     (unless (or (variable-possibly-integer? y)
4126                 (variable-possibly-noninteger-real? y)
4127                 (variable-possibly-nonreal-number? y)
4128                 (variable-possibly-boolean? y)
4129                 (variable-possibly-nonboolean-nonnumber? y))
4130       (fail))
4131     (cond ((and x-lower-bound
4132                 (or (not y-lower-bound) (> x-lower-bound y-lower-bound)))
4133            (local (setf (variable-lower-bound y) x-lower-bound))
4134            (setf run? t))
4135           (y-lower-bound?
4136            (local (setf (variable-lower-bound y) y-lower-bound))
4137            (setf run? t)))
4138     (cond ((and x-upper-bound
4139                 (or (not y-upper-bound) (< x-upper-bound y-upper-bound)))
4140            (local (setf (variable-upper-bound y) x-upper-bound))
4141            (setf run? t))
4142           (y-upper-bound?
4143            (local (setf (variable-upper-bound y) y-upper-bound))
4144            (setf run? t)))
4145     (unless (or (null (variable-lower-bound y))
4146                 (null (variable-upper-bound y))
4147                 (< (variable-lower-bound y) (variable-upper-bound y)))
4148       (fail))
4149     (if run?
4150         (let ((lower-bound (variable-lower-bound y))
4151               (upper-bound (variable-upper-bound y)))
4152           (if (eq (variable-enumerated-domain y) t)
4153               (if (and lower-bound
4154                        upper-bound
4155                        (variable-integer? y)
4156                        (or (null *maximum-discretization-range*)
4157                            (<= (- upper-bound lower-bound)
4158                                *maximum-discretization-range*)))
4159                   (set-enumerated-domain!
4160                    y (all-values (an-integer-between lower-bound upper-bound))))
4161               (if lower-bound
4162                   (if upper-bound
4163                       (if (some #'(lambda (element)
4164                                     (or (< element lower-bound)
4165                                         (> element upper-bound)))
4166                                 (variable-enumerated-domain y))
4167                           ;; note: Could do less consing if had LOCAL DELETE-IF.
4168                           ;;       This would also allow checking list only once.
4169                           (set-enumerated-domain!
4170                            y (remove-if #'(lambda (element)
4171                                             (or (< element lower-bound)
4172                                                 (> element upper-bound)))
4173                                         (variable-enumerated-domain y))))
4174                       (if (some #'(lambda (element) (< element lower-bound))
4175                                 (variable-enumerated-domain y))
4176                           ;; note: Could do less consing if had LOCAL DELETE-IF.
4177                           ;;       This would also allow checking list only once.
4178                           (set-enumerated-domain!
4179                            y (remove-if #'(lambda (element)
4180                                             (< element lower-bound))
4181                                         (variable-enumerated-domain y)))))
4182                   (if upper-bound
4183                       (if (some #'(lambda (element) (> element upper-bound))
4184                                 (variable-enumerated-domain y))
4185                           ;; note: Could do less consing if had LOCAL DELETE-IF.
4186                           ;;       This would also allow checking list only once.
4187                           (set-enumerated-domain!
4188                            y (remove-if #'(lambda (element)
4189                                             (> element upper-bound))
4190                                         (variable-enumerated-domain y)))))))))
4191     (local (let* ((enumerated-domain
4192                    (cond
4193                      ((eq (variable-enumerated-domain x) t)
4194                       (if (eq (variable-enumerated-domain y) t)
4195                           t
4196                           (set-difference (variable-enumerated-domain y)
4197                                           (variable-enumerated-antidomain x)
4198                                           :test #'equal)))
4199                      ((eq (variable-enumerated-domain y) t)
4200                       (set-difference (variable-enumerated-domain x)
4201                                       (variable-enumerated-antidomain y)
4202                                       :test #'equal))
4203                      (t (intersection (variable-enumerated-domain x)
4204                                       (variable-enumerated-domain y)
4205                                       :test #'equal))))
4206                   (enumerated-antidomain
4207                    (if (eq enumerated-domain t)
4208                        (union (variable-enumerated-antidomain x)
4209                               (variable-enumerated-antidomain y)
4210                               :test #'equal)
4211                        '())))
4212              (if (null enumerated-domain) (fail))
4213              (if (and (not (eq enumerated-domain t))
4214                       (or (eq (variable-enumerated-domain y) t)
4215                           (< (length enumerated-domain)
4216                              (length (variable-enumerated-domain y)))))
4217                  (setf (variable-enumerated-domain y) enumerated-domain))
4218              (if (if (eq enumerated-domain t)
4219                      (> (length enumerated-antidomain)
4220                         (length (variable-enumerated-antidomain y)))
4221                      (not (null (variable-enumerated-antidomain y))))
4222                  (setf (variable-enumerated-antidomain y) enumerated-antidomain)))
4223            (setf (variable-noticers y)
4224                  (append (variable-noticers y) (variable-noticers x)))
4225            (setf (variable-noticers x) '())
4226            (setf (variable-value x) y))
4227     (run-noticers y)))
4228
4229 (defun restrict-value! (x value)
4230   ;; note: X must be a variable such that (EQ X (VALUE-OF X)).
4231   ;; note: VALUE must not be a variable.
4232   (if (occurs-in? x value) (fail))
4233   (typecase value
4234     (integer (unless (variable-possibly-integer? x) (fail)))
4235     (real (unless (variable-possibly-noninteger-real? x) (fail)))
4236     (number (unless (variable-possibly-nonreal-number? x) (fail)))
4237     (boolean (unless (variable-possibly-boolean? x) (fail)))
4238     (otherwise (unless (variable-possibly-nonboolean-nonnumber? x) (fail))))
4239   ;; needs work: This is sound only if VALUE does not contain any variables.
4240   (if (eq (variable-enumerated-domain x) t)
4241       (if (member value (variable-enumerated-antidomain x) :test #'equal)
4242           (fail))
4243       (unless (member value (variable-enumerated-domain x) :test #'equal)
4244         (fail)))
4245   (if (and (realp value)
4246            (or (and (variable-lower-bound x)
4247                     (< value (variable-lower-bound x)))
4248                (and (variable-upper-bound x)
4249                     (> value (variable-upper-bound x)))))
4250       (fail))
4251   (local (setf (variable-value x) value)
4252          (typecase value
4253            (integer (if (variable-possibly-noninteger-real? x)
4254                         (setf (variable-possibly-noninteger-real? x) nil))
4255                     (if (variable-possibly-nonreal-number? x)
4256                         (setf (variable-possibly-nonreal-number? x) nil))
4257                     (if (variable-possibly-boolean? x)
4258                         (setf (variable-possibly-boolean? x) nil))
4259                     (if (variable-possibly-nonboolean-nonnumber? x)
4260                         (setf (variable-possibly-nonboolean-nonnumber? x) nil))
4261                     (if (or (null (variable-lower-bound x))
4262                             (not (integerp (variable-lower-bound x)))
4263                             (> value (variable-lower-bound x)))
4264                         (setf (variable-lower-bound x) value))
4265                     (if (or (null (variable-upper-bound x))
4266                             (not (integerp (variable-upper-bound x)))
4267                             (< value (variable-upper-bound x)))
4268                         (setf (variable-upper-bound x) value)))
4269            (real (if (variable-possibly-integer? x)
4270                      (setf (variable-possibly-integer? x) nil))
4271                  (if (variable-possibly-nonreal-number? x)
4272                      (setf (variable-possibly-nonreal-number? x) nil))
4273                  (if (variable-possibly-boolean? x)
4274                      (setf (variable-possibly-boolean? x) nil))
4275                  (if (variable-possibly-nonboolean-nonnumber? x)
4276                      (setf (variable-possibly-nonboolean-nonnumber? x) nil))
4277                  (if (or (null (variable-lower-bound x))
4278                          (> value (variable-lower-bound x)))
4279                      (setf (variable-lower-bound x) value))
4280                  (if (or (null (variable-upper-bound x))
4281                          (< value (variable-upper-bound x)))
4282                      (setf (variable-upper-bound x) value)))
4283            (number (if (variable-possibly-integer? x)
4284                        (setf (variable-possibly-integer? x) nil))
4285                    (if (variable-possibly-noninteger-real? x)
4286                        (setf (variable-possibly-noninteger-real? x) nil))
4287                    (if (variable-possibly-boolean? x)
4288                        (setf (variable-possibly-boolean? x) nil))
4289                    (if (variable-possibly-nonboolean-nonnumber? x)
4290                        (setf (variable-possibly-nonboolean-nonnumber? x) nil)))
4291            (boolean (if (variable-possibly-integer? x)
4292                         (setf (variable-possibly-integer? x) nil))
4293                     (if (variable-possibly-noninteger-real? x)
4294                         (setf (variable-possibly-noninteger-real? x) nil))
4295                     (if (variable-possibly-nonreal-number? x)
4296                         (setf (variable-possibly-nonreal-number? x) nil))
4297                     (if (variable-possibly-nonboolean-nonnumber? x)
4298                         (setf (variable-possibly-nonboolean-nonnumber? x) nil)))
4299            (otherwise (if (variable-possibly-integer? x)
4300                           (setf (variable-possibly-integer? x) nil))
4301                       (if (variable-possibly-noninteger-real? x)
4302                           (setf (variable-possibly-noninteger-real? x) nil))
4303                       (if (variable-possibly-nonreal-number? x)
4304                           (setf (variable-possibly-nonreal-number? x) nil))
4305                       (if (variable-possibly-boolean? x)
4306                           (setf (variable-possibly-boolean? x) nil))))
4307          (cond ((eq (variable-enumerated-domain x) t)
4308                 ;; needs work: This is sound only if VALUE does not contain any
4309                 ;;             variables.
4310                 (setf (variable-enumerated-domain x) (list value))
4311                 (setf (variable-enumerated-antidomain x) '()))
4312                ((not (null (rest (variable-enumerated-domain x))))
4313                 ;; needs work: This is sound only if VALUE does not contain any
4314                 ;;             variables.
4315                 (setf (variable-enumerated-domain x) (list value)))))
4316   (run-noticers x))
4317
4318 (defun restrict-true! (x)
4319   ;; note: X must be a Boolean variable.
4320   (if (eq (variable-value x) nil) (fail))
4321   (when (eq (variable-value x) x)
4322     (local (setf (variable-value x) t)
4323            (setf (variable-enumerated-domain x) '(t)))
4324     (run-noticers x)))
4325
4326 (defun restrict-false! (x)
4327   ;; note: X must be a Boolean variable.
4328   (if (eq (variable-value x) t) (fail))
4329   (when (eq (variable-value x) x)
4330     (local (setf (variable-value x) nil)
4331            (setf (variable-enumerated-domain x) '(nil)))
4332     (run-noticers x)))
4333
4334 (defun set-enumerated-domain! (x enumerated-domain)
4335   ;; note: X must be a variable such that (EQ X (VALUE-OF X)).
4336   ;; note: All callers must insure that the new ENUMERATED-DOMAIN is a subset
4337   ;;       of the old one.
4338   (if (null enumerated-domain) (fail))
4339   (local
4340     (cond
4341       ((eq (variable-enumerated-domain x) t)
4342        (setf (variable-enumerated-domain x) enumerated-domain)
4343        (unless (null (variable-enumerated-antidomain x))
4344          (setf (variable-enumerated-antidomain x) '()))
4345        (if (and (variable-possibly-boolean? x)
4346                 (not (some #'booleanp enumerated-domain)))
4347            (setf (variable-possibly-boolean? x) nil))
4348        (if (and (variable-possibly-nonboolean-nonnumber? x)
4349                 (not (some #'(lambda (x)
4350                                (and (not (booleanp x)) (not (numberp x))))
4351                            enumerated-domain)))
4352            (setf (variable-possibly-nonboolean-nonnumber? x) nil))
4353        (if (and (variable-possibly-nonreal-number? x)
4354                 (not (some #'(lambda (x) (and (not (realp x)) (numberp x)))
4355                            enumerated-domain)))
4356            (setf (variable-possibly-nonreal-number? x) nil))
4357        (if (and (variable-possibly-noninteger-real? x)
4358                 (not (some #'(lambda (x) (and (not (integerp x)) (realp x)))
4359                            enumerated-domain)))
4360            (setf (variable-possibly-noninteger-real? x) nil))
4361        (if (and (variable-possibly-integer? x)
4362                 (not (some #'integerp enumerated-domain)))
4363            (setf (variable-possibly-integer? x) nil))
4364        (if (variable-real? x)
4365            (let ((lower-bound (reduce #'min enumerated-domain))
4366                  (upper-bound (reduce #'max enumerated-domain)))
4367              (if (or (null (variable-lower-bound x))
4368                      (> lower-bound (variable-lower-bound x)))
4369                  (setf (variable-lower-bound x) lower-bound))
4370              (if (or (null (variable-upper-bound x))
4371                      (< upper-bound (variable-upper-bound x)))
4372                  (setf (variable-upper-bound x) upper-bound))))
4373        (if (null (rest enumerated-domain))
4374            (setf (variable-value x) (first enumerated-domain)))
4375        t)
4376       ((< (length enumerated-domain) (length (variable-enumerated-domain x)))
4377        (setf (variable-enumerated-domain x) enumerated-domain)
4378        (if (and (variable-possibly-boolean? x)
4379                 (not (some #'booleanp enumerated-domain)))
4380            (setf (variable-possibly-boolean? x) nil))
4381        (if (and (variable-possibly-nonboolean-nonnumber? x)
4382                 (not (some #'(lambda (x)
4383                                (and (not (booleanp x)) (not (numberp x))))
4384                            enumerated-domain)))
4385            (setf (variable-possibly-nonboolean-nonnumber? x) nil))
4386        (if (and (variable-possibly-nonreal-number? x)
4387                 (not (some #'(lambda (x) (and (not (realp x)) (numberp x)))
4388                            enumerated-domain)))
4389            (setf (variable-possibly-nonreal-number? x) nil))
4390        (if (and (variable-possibly-noninteger-real? x)
4391                 (not (some #'(lambda (x) (and (not (integerp x)) (realp x)))
4392                            enumerated-domain)))
4393            (setf (variable-possibly-noninteger-real? x) nil))
4394        (if (and (variable-possibly-integer? x)
4395                 (not (some #'integerp enumerated-domain)))
4396            (setf (variable-possibly-integer? x) nil))
4397        (if (variable-real? x)
4398            (let ((lower-bound (reduce #'min enumerated-domain))
4399                  (upper-bound (reduce #'max enumerated-domain)))
4400              (if (or (null (variable-lower-bound x))
4401                      (> lower-bound (variable-lower-bound x)))
4402                  (setf (variable-lower-bound x) lower-bound))
4403              (if (or (null (variable-upper-bound x))
4404                      (< upper-bound (variable-upper-bound x)))
4405                  (setf (variable-upper-bound x) upper-bound))))
4406        (if (null (rest enumerated-domain))
4407            (setf (variable-value x) (first enumerated-domain)))
4408        t)
4409       (t nil))))
4410
4411 (defun restrict-enumerated-domain! (x enumerated-domain)
4412   ;; note: X must be a variable such that (EQ X (VALUE-OF X)).
4413   ;; note: ENUMERATED-DOMAIN must not be a variable.
4414   (unless (typep enumerated-domain 'sequence) (fail))
4415   (when (every #'ground? enumerated-domain)
4416     (setf enumerated-domain
4417           (remove-duplicates (map 'list #'eliminate-variables enumerated-domain)
4418                              :test #'equal))
4419     (unless (variable-possibly-boolean? x)
4420       (setf enumerated-domain (remove-if #'booleanp enumerated-domain)))
4421     (unless (variable-possibly-nonboolean-nonnumber? x)
4422       (setf enumerated-domain
4423             (remove-if #'(lambda (x) (and (not (booleanp x)) (not (numberp x))))
4424                        enumerated-domain)))
4425     (unless (variable-possibly-nonreal-number? x)
4426       (setf enumerated-domain
4427             (remove-if #'(lambda (x) (and (not (realp x)) (numberp x)))
4428                        enumerated-domain)))
4429     (unless (variable-possibly-noninteger-real? x)
4430       (setf enumerated-domain
4431             (remove-if #'(lambda (x) (and (not (integerp x)) (realp x)))
4432                        enumerated-domain)))
4433     (unless (variable-possibly-integer? x)
4434       (setf enumerated-domain (remove-if #'integerp enumerated-domain)))
4435     (if (variable-upper-bound x)
4436         (let ((upper-bound (variable-upper-bound x)))
4437           (setf enumerated-domain
4438                 (remove-if #'(lambda (element) (> element upper-bound))
4439                            enumerated-domain))))
4440     (if (variable-lower-bound x)
4441         (let ((lower-bound (variable-lower-bound x)))
4442           (setf enumerated-domain
4443                 (remove-if #'(lambda (element) (< element lower-bound))
4444                            enumerated-domain))))
4445     (setf enumerated-domain
4446           (if (eq (variable-enumerated-domain x) t)
4447               (set-difference enumerated-domain
4448                               (variable-enumerated-antidomain x)
4449                               :test #'equal)
4450               (intersection (variable-enumerated-domain x) enumerated-domain
4451                             :test #'equal)))
4452     (if (set-enumerated-domain! x enumerated-domain) (run-noticers x))))
4453
4454 (defun restrict-enumerated-antidomain! (x enumerated-antidomain)
4455   ;; note: X must be a variable such that (EQ X (VALUE-OF X)).
4456   ;; note: ENUMERATED-ANTIDOMAIN must not be a variable.
4457   (unless (typep enumerated-antidomain 'sequence) (fail))
4458   (when (every #'ground? enumerated-antidomain)
4459     (setf enumerated-antidomain
4460           (remove-duplicates
4461            (map 'list #'eliminate-variables enumerated-antidomain)
4462            :test #'equal))
4463     (cond
4464       ((eq (variable-enumerated-domain x) t)
4465        (setf enumerated-antidomain
4466              (union (variable-enumerated-antidomain x) enumerated-antidomain
4467                     :test #'equal))
4468        (when (> (length enumerated-antidomain)
4469                 (length (variable-enumerated-antidomain x)))
4470          (local (setf (variable-enumerated-antidomain x) enumerated-antidomain))
4471          (run-noticers x)))
4472       ((set-enumerated-domain!
4473         x (set-difference (variable-enumerated-domain x) enumerated-antidomain
4474                           :test #'equal))
4475        (run-noticers x)))))
4476
4477 ;;; Rules
4478
4479 (defun +-rule-up (z x y)
4480   (if (and (variable-integer? x) (variable-integer? y)) (restrict-integer! z))
4481   ;; note: We can't assert that Z in not an integer when either X or Y are not
4482   ;;       integers since they may be Gaussian integers. But we can if either
4483   ;;       X or Y is real. If the Screamer type system could distinguish
4484   ;;       Gaussian integers from other complex numbers we could whenever X or
4485   ;;       Y was not a Gaussian integer.
4486   (if (and (or (variable-noninteger? x) (variable-noninteger? y))
4487            (or (variable-real? x) (variable-real? y)))
4488       (restrict-noninteger! z))
4489   (if (and (variable-real? x) (variable-real? y)) (restrict-real! z))
4490   ;; note: Ditto.
4491   (if (and (or (variable-nonreal? x) (variable-nonreal? y))
4492            (or (variable-real? x) (variable-real? y)))
4493       (restrict-nonreal! z))
4494   (if (and (variable-real? x) (variable-real? y) (variable-real? z))
4495       (restrict-bounds!
4496        z
4497        (infinity-+ (variable-lower-bound x) (variable-lower-bound y))
4498        (infinity-+ (variable-upper-bound x) (variable-upper-bound y))))
4499   (let ((x (value-of x))
4500         (y (value-of y))
4501         (z (value-of z)))
4502     (if (and (not (variable? x))
4503              (not (variable? y))
4504              (not (variable? z))
4505              (/= z (+ x y)))
4506         (fail))))
4507
4508 (defun +-rule-down (z x y)
4509   ;; note: We can't assert that X and Y are integers when Z is an integer since
4510   ;;       Z may be an integer when X and Y are Gaussian integers. But we can
4511   ;;       make such an assertion if either X or Y is real. If the Screamer
4512   ;;       type system could distinguish Gaussian integers from other complex
4513   ;;       numbers we could make such an assertion whenever either X or Y was
4514   ;;       not a Gaussian integer.
4515   (if (and (variable-integer? z) (or (variable-real? x) (variable-real? y)))
4516       (restrict-integer! x))
4517   ;; note: Ditto.
4518   (if (and (variable-real? z) (or (variable-real? x) (variable-real? y)))
4519       (restrict-real! x))
4520   (if (and (variable-real? x) (variable-real? y) (variable-real? z))
4521       (restrict-bounds!
4522        x
4523        (infinity-- (variable-lower-bound z) (variable-upper-bound y))
4524        (infinity-- (variable-upper-bound z) (variable-lower-bound y))))
4525   (let ((x (value-of x))
4526         (y (value-of y))
4527         (z (value-of z)))
4528     (if (and (not (variable? x))
4529              (not (variable? y))
4530              (not (variable? z))
4531              (/= z (+ x y)))
4532         (fail))))
4533
4534 (defun /-rule (z x y)
4535   (when (and (variable-lower-bound x) (plusp (variable-lower-bound x)))
4536     (cond ((and (variable-upper-bound x) (not (zerop (variable-upper-bound x))))
4537            (if (variable-lower-bound z)
4538                (cond
4539                  ((minusp (variable-lower-bound z))
4540                   (restrict-lower-bound!
4541                    y (/ (variable-lower-bound z) (variable-lower-bound x))))
4542                  (t (restrict-lower-bound! y 0)
4543                     (restrict-lower-bound!
4544                      y (/ (variable-lower-bound z) (variable-upper-bound x))))))
4545            (if (variable-upper-bound z)
4546                (cond
4547                  ((plusp (variable-upper-bound z))
4548                   (restrict-upper-bound!
4549                    y (/ (variable-upper-bound z) (variable-lower-bound x))))
4550                  (t (restrict-upper-bound! y 0)
4551                     (restrict-upper-bound!
4552                      y (/ (variable-upper-bound z) (variable-upper-bound x)))))))
4553           (t (if (variable-lower-bound z)
4554                  (cond
4555                    ((minusp (variable-lower-bound z))
4556                     (restrict-lower-bound!
4557                      y (/ (variable-lower-bound z) (variable-lower-bound x))))
4558                    (t (restrict-lower-bound! y 0))))
4559              (if (variable-upper-bound z)
4560                  (cond
4561                    ((plusp (variable-upper-bound z))
4562                     (restrict-upper-bound!
4563                      y (/ (variable-upper-bound z) (variable-lower-bound x))))
4564                    (t (restrict-upper-bound! y 0)))))))
4565   (when (and (variable-upper-bound x) (minusp (variable-upper-bound x)))
4566     (cond ((and (variable-lower-bound x) (not (zerop (variable-lower-bound x))))
4567            (if (variable-upper-bound z)
4568                (cond
4569                  ((plusp (variable-upper-bound z))
4570                   (restrict-lower-bound!
4571                    y (/ (variable-upper-bound z) (variable-upper-bound x))))
4572                  (t (restrict-lower-bound! y 0)
4573                     (restrict-lower-bound!
4574                      y (/ (variable-upper-bound z) (variable-lower-bound x))))))
4575            (if (variable-lower-bound z)
4576                (cond
4577                  ((minusp (variable-lower-bound z))
4578                   (restrict-upper-bound!
4579                    y (/ (variable-lower-bound z) (variable-upper-bound x))))
4580                  (t (restrict-upper-bound! y 0)
4581                     (restrict-upper-bound!
4582                      y (/ (variable-lower-bound z) (variable-lower-bound x)))))))
4583           (t (if (variable-upper-bound z)
4584                  (cond
4585                    ((plusp (variable-upper-bound z))
4586                     (restrict-lower-bound!
4587                      y (/ (variable-upper-bound z) (variable-upper-bound x))))
4588                    (t (restrict-lower-bound! y 0))))
4589              (if (variable-lower-bound z)
4590                  (cond
4591                    ((minusp (variable-lower-bound z))
4592                     (restrict-upper-bound!
4593                      y (/ (variable-lower-bound z) (variable-upper-bound x))))
4594                    (t (restrict-upper-bound! y 0))))))))
4595
4596 (defun *-rule-up (z x y)
4597   (if (and (variable-integer? x) (variable-integer? y)) (restrict-integer! z))
4598   ;; note: We can't assert that Z in not an integer when either X or Y are not
4599   ;;       integers since they may be Gaussian integers. But we can if either
4600   ;;       X or Y is real. If the Screamer type system could distinguish
4601   ;;       Gaussian integers from other complex numbers we could whenever X or
4602   ;;       Y was not a Gaussian integer.
4603   (if (and (or (variable-noninteger? x) (variable-noninteger? y))
4604            (or (variable-real? x) (variable-real? y)))
4605       (restrict-noninteger! z))
4606   (if (and (variable-real? x) (variable-real? y)) (restrict-real! z))
4607   ;; note: Ditto.
4608   (if (and (or (variable-nonreal? x) (variable-nonreal? y))
4609            (or (variable-real? x) (variable-real? y)))
4610       (restrict-nonreal! z))
4611   (if (and (variable-real? x) (variable-real? y) (variable-real? z))
4612       ;; note: Can sometimes do better than the following even when ranges are
4613       ;;       not finite.
4614       (restrict-bounds!
4615        z
4616        (infinity-min
4617         (infinity-* (variable-lower-bound x) (variable-lower-bound y))
4618         (infinity-min
4619          (infinity-* (variable-lower-bound x) (variable-upper-bound y))
4620          (infinity-min
4621           (infinity-* (variable-upper-bound x) (variable-lower-bound y))
4622           (infinity-* (variable-upper-bound x) (variable-upper-bound y)))))
4623        (infinity-max
4624         (infinity-* (variable-lower-bound x) (variable-lower-bound y))
4625         (infinity-max
4626          (infinity-* (variable-lower-bound x) (variable-upper-bound y))
4627          (infinity-max
4628           (infinity-* (variable-upper-bound x) (variable-lower-bound y))
4629           (infinity-* (variable-upper-bound x) (variable-upper-bound y)))))))
4630   (let ((x (value-of x))
4631         (y (value-of y))
4632         (z (value-of z)))
4633     (if (and (not (variable? x))
4634              (not (variable? y))
4635              (not (variable? z))
4636              (/= z (* x y)))
4637         (fail))))
4638
4639 (defun *-rule-down (z x y)
4640   ;; note: We can't assert that X and Y are integers when Z is an integer since
4641   ;;       Z may be an integer when X and Y are Gaussian integers. But we can
4642   ;;       make such an assertion if either X or Y is real. If the Screamer
4643   ;;       type system could distinguish Gaussian integers from other complex
4644   ;;       numbers we could make such an assertion whenever either X or Y was
4645   ;;       not a Gaussian integer.
4646   (if (and (variable-integer? z) (or (variable-real? x) (variable-real? y)))
4647       (restrict-integer! x))
4648   ;; note: Ditto.
4649   (if (and (variable-real? z) (or (variable-real? x) (variable-real? y)))
4650       (restrict-real! x))
4651   (if (and (variable-real? x) (variable-real? y) (variable-real? z))
4652       (/-rule z y x))
4653   (let ((x (value-of x))
4654         (y (value-of y))
4655         (z (value-of z)))
4656     (if (and (not (variable? x))
4657              (not (variable? y))
4658              (not (variable? z))
4659              (/= z (* x y)))
4660         (fail))))
4661
4662 (defun min-rule-up (z x y)
4663   (if (and (variable-integer? x) (variable-integer? y)) (restrict-integer! z))
4664   (restrict-bounds!
4665    z
4666    (infinity-min (variable-lower-bound x) (variable-lower-bound y))
4667    (if (variable-upper-bound x)
4668        (if (variable-upper-bound y)
4669            (min (variable-upper-bound x) (variable-upper-bound y))
4670            (variable-upper-bound x))
4671        (variable-upper-bound y)))
4672   (let ((x (value-of x))
4673         (y (value-of y))
4674         (z (value-of z)))
4675     (if (and (not (variable? z))
4676              (not (variable? x))
4677              (not (variable? y))
4678              (/= z (min x y)))
4679         (fail))))
4680
4681 (defun min-rule-down (z x y)
4682   ;; note: The analog of the following for upper bounds, namely restricting
4683   ;;       the upper bound of either X or Y to (VARIABLE-UPPER-BOUND Z) is
4684   ;;       nondeterministic.
4685   (if (variable-lower-bound z)
4686       (restrict-lower-bound! x (variable-lower-bound z)))
4687   (let ((x (value-of x))
4688         (y (value-of y))
4689         (z (value-of z)))
4690     (if (and (not (variable? z))
4691              (not (variable? x))
4692              (not (variable? y))
4693              (/= z (min x y)))
4694         (fail))))
4695
4696 (defun max-rule-up (z x y)
4697   (if (and (variable-integer? x) (variable-integer? y)) (restrict-integer! z))
4698   (restrict-bounds!
4699    z
4700    (if (variable-lower-bound x)
4701        (if (variable-lower-bound y)
4702            (max (variable-lower-bound x) (variable-lower-bound y))
4703            (variable-lower-bound x))
4704        (variable-lower-bound y))
4705    (infinity-max (variable-upper-bound x) (variable-upper-bound y)))
4706   (let ((x (value-of x))
4707         (y (value-of y))
4708         (z (value-of z)))
4709     (if (and (not (variable? z))
4710              (not (variable? x))
4711              (not (variable? y))
4712              (/= z (max x y)))
4713         (fail))))
4714
4715 (defun max-rule-down (z x y)
4716   ;; note: The analog of the following for lower bounds, namely restricting
4717   ;;       the lower bound of either X or Y to (VARIABLE-LOWER-BOUND Z) is
4718   ;;       nondeterministic.
4719   (if (variable-upper-bound z)
4720       (restrict-upper-bound! x (variable-upper-bound z)))
4721   (let ((x (value-of x))
4722         (y (value-of y))
4723         (z (value-of z)))
4724     (if (and (not (variable? z))
4725              (not (variable? x))
4726              (not (variable? y))
4727              (/= z (max x y)))
4728         (fail))))
4729
4730 (defun =-rule (x y)
4731   (cond
4732     ;; note: I forget why +-RULE *-RULE MIN-RULE and MAX-RULE must perform the
4733     ;;       check in the second COND clause irrespective of whether the first
4734     ;;       clause is executed.
4735     ((and (variable-real? x) (variable-real? y))
4736      (restrict-bounds! x (variable-lower-bound y) (variable-upper-bound y))
4737      (restrict-bounds! y (variable-lower-bound x) (variable-upper-bound x)))
4738     ((and (not (variable? x)) (not (variable? y)) (/= x y)) (fail))))
4739
4740 (defun <=-rule (x y)
4741   (if (variable-lower-bound x)
4742       (restrict-lower-bound! y (variable-lower-bound x)))
4743   (if (variable-upper-bound y)
4744       (restrict-upper-bound! x (variable-upper-bound y))))
4745
4746 (defun <-rule (x y)
4747   (if (variable-lower-bound x)
4748       (restrict-lower-bound! y (if (variable-integer? y)
4749                                    (1+ (floor (variable-lower-bound x)))
4750                                    (variable-lower-bound x))))
4751   (if (variable-upper-bound y)
4752       (restrict-upper-bound! x (if (variable-integer? x)
4753                                    (1- (ceiling (variable-upper-bound y)))
4754                                    (variable-upper-bound y))))
4755   (let ((x (value-of x))
4756         (y (value-of y)))
4757     (if (and (not (variable? x)) (not (variable? y)) (>= x y)) (fail))))
4758
4759 (defun /=-rule (x y)
4760   ;; note: Got rid of the nondeterministic version of /=-RULE.
4761   (let ((x (value-of x))
4762         (y (value-of y)))
4763     (if (and (not (variable? x)) (not (variable? y)) (= x y)) (fail))))
4764
4765 ;;; Lifted Arithmetic Functions (Two argument optimized)
4766
4767 (defun +v2 (x y)
4768   (assert!-numberpv x)
4769   (assert!-numberpv y)
4770   ;; needs work: The first two optimizations below violate CommonLisp type
4771   ;;             propagation conventions.
4772   (cond ((and (bound? x) (zerop (value-of x))) (value-of y))
4773         ((and (bound? y) (zerop (value-of y))) (value-of x))
4774         ((and (bound? x) (bound? y)) (+ (value-of x) (value-of y)))
4775         (t (let ((x (variablize x))
4776                  (y (variablize y))
4777                  (z (a-numberv)))
4778              (attach-noticer!
4779               #'(lambda () (+-rule-up z x y) (+-rule-down z y x)) x)
4780              (attach-noticer!
4781               #'(lambda () (+-rule-up z x y) (+-rule-down z x y)) y)
4782              (attach-noticer!
4783               #'(lambda () (+-rule-down z x y) (+-rule-down z y x)) z)
4784              z))))
4785
4786 (defun -v2 (x y)
4787   (assert!-numberpv x)
4788   (assert!-numberpv y)
4789   ;; needs work: The first optimization below violates CommonLisp type
4790   ;;             propagation conventions.
4791   (cond ((and (bound? y) (zerop (value-of y))) (value-of x))
4792         ((and (bound? x) (bound? y)) (- (value-of x) (value-of y)))
4793         (t (let ((x (variablize x))
4794                  (y (variablize y))
4795                  (z (a-numberv)))
4796              (attach-noticer!
4797               #'(lambda () (+-rule-down x y z) (+-rule-down x z y)) x)
4798              (attach-noticer!
4799               #'(lambda () (+-rule-up x y z) (+-rule-down x z y)) y)
4800              (attach-noticer!
4801               #'(lambda () (+-rule-up x y z) (+-rule-down x y z)) z)
4802              z))))
4803
4804 (defun *v2 (x y)
4805   (assert!-numberpv x)
4806   (assert!-numberpv y)
4807   ;; needs work: The first four optimizations below violate CommonLisp type
4808   ;;             propagation conventions.
4809   (cond ((and (bound? x) (zerop (value-of x))) 0)
4810         ((and (bound? y) (zerop (value-of y))) 0)
4811         ((and (bound? x) (= (value-of x) 1)) (value-of y))
4812         ((and (bound? y) (= (value-of y) 1)) (value-of x))
4813         ((and (bound? x) (bound? y)) (* (value-of x) (value-of y)))
4814         (t (let ((x (variablize x))
4815                  (y (variablize y))
4816                  (z (a-numberv)))
4817              (attach-noticer!
4818               #'(lambda () (*-rule-up z x y) (*-rule-down z y x)) x)
4819              (attach-noticer!
4820               #'(lambda () (*-rule-up z x y) (*-rule-down z x y)) y)
4821              (attach-noticer!
4822               #'(lambda () (*-rule-down z x y) (*-rule-down z y x)) z)
4823              z))))
4824
4825 (defun /v2 (x y)
4826   (assert!-numberpv x)
4827   (assert!-numberpv y)
4828   ;; needs work: The first three optimizations below violate CommonLisp type
4829   ;;             propagation conventions.
4830   (cond ((and (bound? x) (zerop (value-of x))) 0)
4831         ((and (bound? y) (zerop (value-of y))) (fail))
4832         ((and (bound? y) (= (value-of y) 1)) (value-of x))
4833         ((and (bound? x) (bound? y)) (/ (value-of x) (value-of y)))
4834         (t (let ((x (variablize x))
4835                  (y (variablize y))
4836                  (z (a-numberv)))
4837              (attach-noticer!
4838               #'(lambda () (*-rule-down x y z) (*-rule-down x z y)) x)
4839              (attach-noticer!
4840               #'(lambda () (*-rule-up x y z) (*-rule-down x z y)) y)
4841              (attach-noticer!
4842               #'(lambda () (*-rule-up x y z) (*-rule-down x y z)) z)
4843              z))))
4844
4845 (defun minv2 (x y)
4846   (assert!-realpv x)
4847   (assert!-realpv y)
4848   (cond ((known?-<=v2-internal x y) (value-of x))
4849         ((known?-<=v2-internal y x) (value-of y))
4850         (t (let ((x (variablize x))
4851                  (y (variablize y))
4852                  (z (a-realv)))
4853              (attach-noticer!
4854               #'(lambda () (min-rule-up z x y) (min-rule-down z y x)) x)
4855              (attach-noticer!
4856               #'(lambda () (min-rule-up z x y) (min-rule-down z x y)) y)
4857              (attach-noticer!
4858               #'(lambda () (min-rule-down z x y) (min-rule-down z y x)) z)
4859              z))))
4860
4861 (defun maxv2 (x y)
4862   (assert!-realpv x)
4863   (assert!-realpv y)
4864   (cond ((known?-<=v2-internal y x) (value-of x))
4865         ((known?-<=v2-internal x y) (value-of y))
4866         (t (let ((x (variablize x))
4867                  (y (variablize y))
4868                  (z (a-realv)))
4869              (attach-noticer!
4870               #'(lambda () (max-rule-up z x y) (max-rule-down z y x)) x)
4871              (attach-noticer!
4872               #'(lambda () (max-rule-up z x y) (max-rule-down z x y)) y)
4873              (attach-noticer!
4874               #'(lambda () (max-rule-down z x y) (max-rule-down z y x)) z)
4875              z))))
4876
4877 ;;; Lifted Type Functions (KNOWN? optimized)
4878
4879 (defun known?-integerpv (x)
4880   (let ((x (value-of x)))
4881     (typecase x
4882       (integer t)
4883       (variable (variable-integer? x))
4884       (otherwise nil))))
4885
4886 (defun known?-notv-integerpv (x)
4887   (let ((x (value-of x)))
4888     (typecase x
4889       (integer nil)
4890       (variable (variable-noninteger? x))
4891       (otherwise t))))
4892
4893 (defun known?-realpv (x)
4894   (let ((x (value-of x)))
4895     (typecase x
4896       (real t)
4897       (variable (variable-real? x))
4898       (otherwise nil))))
4899
4900 (defun known?-notv-realpv (x)
4901   (let ((x (value-of x)))
4902     (typecase x
4903       (real nil)
4904       (variable (variable-nonreal? x))
4905       (otherwise t))))
4906
4907 (defun known?-numberpv (x)
4908   (let ((x (value-of x)))
4909     (typecase x
4910       (number t)
4911       (variable (variable-number? x))
4912       (otherwise nil))))
4913
4914 (defun known?-notv-numberpv (x)
4915   (let ((x (value-of x)))
4916     (typecase x
4917       (number nil)
4918       (variable (variable-nonnumber? x))
4919       (otherwise t))))
4920
4921 (defun known?-booleanpv (x)
4922   (let ((x (value-of x)))
4923     (typecase x
4924       (boolean t)
4925       (variable (variable-boolean? x))
4926       (otherwise nil))))
4927
4928 (defun known?-notv-booleanpv (x)
4929   (let ((x (value-of x)))
4930     (typecase x
4931       (boolean nil)
4932       (variable (variable-nonboolean? x))
4933       (otherwise t))))
4934
4935 ;;; Lifted Arithmetic Comparison Functions (Two argument KNOWN? optimized)
4936
4937 (defun known?-<=v2-variable (x y)
4938   (and (variable-upper-bound x)
4939        (variable-lower-bound y)
4940        (<= (variable-upper-bound x) (variable-lower-bound y))))
4941
4942 (defun known?-<v2-variable (x y)
4943   (and (variable-upper-bound x)
4944        (variable-lower-bound y)
4945        (< (variable-upper-bound x) (variable-lower-bound y))))
4946
4947 (defun known?-=v2-variable (x y)
4948   (or (and (variable-real? x)
4949            (variable-real? y)
4950            (known?-<=v2-variable x y)
4951            (known?-<=v2-variable y x))
4952       (and (not (eq x (variable-value x)))
4953            (not (eq y (variable-value y)))
4954            (= (variable-value x) (variable-value y)))))
4955
4956 (defun known?-/=v2-variable (x y)
4957   (or (and (variable-real? x)
4958            (variable-real? y)
4959            (or (known?-<v2-variable x y) (known?-<v2-variable y x)))
4960       (and (not (eq x (variable-value x)))
4961            (not (eq y (variable-value y)))
4962            (/= (variable-value x) (variable-value y)))))
4963
4964 (defun known?-=v2-internal (x y)
4965   (known?-=v2-variable (variablize x) (variablize y)))
4966
4967 (defun known?-<=v2-internal (x y)
4968   (known?-<=v2-variable (variablize x) (variablize y)))
4969
4970 (defun known?-<v2-internal (x y)
4971   (known?-<v2-variable (variablize x) (variablize y)))
4972
4973 (defun known?-/=v2-internal (x y)
4974   (known?-/=v2-variable (variablize x) (variablize y)))
4975
4976 (defun known?-=v2 (x y)
4977   (assert!-numberpv x)
4978   (assert!-numberpv y)
4979   (known?-=v2-internal x y))
4980
4981 (defun known?-<=v2 (x y)
4982   (assert!-realpv x)
4983   (assert!-realpv y)
4984   (known?-<=v2-internal x y))
4985
4986 (defun known?-<v2 (x y)
4987   (assert!-realpv x)
4988   (assert!-realpv y)
4989   (known?-<v2-internal x y))
4990
4991 (defun known?-/=v2 (x y)
4992   (assert!-numberpv x)
4993   (assert!-numberpv y)
4994   (known?-/=v2-internal x y))
4995
4996 ;;; Lifted Type Functions (ASSERT! optimized)
4997
4998 (defun assert!-integerpv (x)
4999   (let ((x (value-of x)))
5000     (typecase x
5001       (integer)
5002       (variable (restrict-integer! x))
5003       (otherwise (fail)))))
5004
5005 (defun assert!-notv-integerpv (x)
5006   (let ((x (value-of x)))
5007     (typecase x
5008       (integer (fail))
5009       (variable (restrict-noninteger! x))
5010       (otherwise))))
5011
5012 (defun assert!-realpv (x)
5013   (let ((x (value-of x)))
5014     (typecase x
5015       (real)
5016       (variable (restrict-real! x))
5017       (otherwise (fail)))))
5018
5019 (defun assert!-notv-realpv (x)
5020   (let ((x (value-of x)))
5021     (typecase x
5022       (real (fail))
5023       (variable (restrict-nonreal! x))
5024       (otherwise))))
5025
5026 (defun assert!-numberpv (x)
5027   (let ((x (value-of x)))
5028     (typecase x
5029       (number)
5030       (variable (restrict-number! x))
5031       (otherwise (fail)))))
5032
5033 (defun assert!-notv-numberpv (x)
5034   (let ((x (value-of x)))
5035     (typecase x
5036       (number (fail))
5037       (variable (restrict-nonnumber! x))
5038       (otherwise))))
5039
5040 (defun assert!-booleanpv (x)
5041   (let ((x (value-of x)))
5042     (typecase x
5043       (boolean)
5044       (variable (restrict-boolean! x))
5045       (otherwise (fail)))))
5046
5047 (defun assert!-notv-booleanpv (x)
5048   (let ((x (value-of x)))
5049     (typecase x
5050       (boolean (fail))
5051       (variable (restrict-nonboolean! x))
5052       (otherwise))))
5053
5054 ;;; Lifted Arithmetic Comparison Functions (Two argument ASSERT! optimized)
5055
5056 (defun assert!-=v2 (x y)
5057   (assert!-numberpv x)
5058   (assert!-numberpv y)
5059   (let ((x (variablize x))
5060         (y (variablize y)))
5061     (attach-noticer! #'(lambda () (=-rule x y)) x)
5062     (attach-noticer! #'(lambda () (=-rule x y)) y)))
5063
5064 (defun assert!-<=v2 (x y)
5065   (assert!-realpv x)
5066   (assert!-realpv y)
5067   (let ((x (variablize x))
5068         (y (variablize y)))
5069     (attach-noticer! #'(lambda () (<=-rule x y)) x)
5070     (attach-noticer! #'(lambda () (<=-rule x y)) y)))
5071
5072 (defun assert!-<v2 (x y)
5073   (assert!-realpv x)
5074   (assert!-realpv y)
5075   (let ((x (variablize x))
5076         (y (variablize y)))
5077     (attach-noticer! #'(lambda () (<-rule x y)) x)
5078     (attach-noticer! #'(lambda () (<-rule x y)) y)))
5079
5080 (defun assert!-/=v2 (x y)
5081   (assert!-numberpv x)
5082   (assert!-numberpv y)
5083   (let ((x (variablize x))
5084         (y (variablize y)))
5085     ;; note: Got rid of the nondeterministic version that called the
5086     ;;       nondeterministic version of /=-RULE.
5087     (attach-noticer! #'(lambda () (/=-rule x y)) x)
5088     (attach-noticer! #'(lambda () (/=-rule x y)) y)))
5089
5090 ;;; Lifted Type Functions
5091
5092 (defun integerpv (x)
5093   (cond ((known?-integerpv x) t)
5094         ((known?-notv-integerpv x) nil)
5095         (t (let ((x (variablize x))
5096                  (z (a-booleanv)))
5097              (attach-noticer!
5098               #'(lambda ()
5099                   (cond ((variable-integer? x) (restrict-true! z))
5100                         ((variable-noninteger? x) (restrict-false! z))))
5101               x)
5102              (attach-noticer!
5103               #'(lambda ()
5104                   (cond ((variable-true? z) (restrict-integer! x))
5105                         ((variable-false? z) (restrict-noninteger! x))))
5106               z)
5107              z))))
5108
5109 (defun realpv (x)
5110   (cond ((known?-realpv x) t)
5111         ((known?-notv-realpv x) nil)
5112         (t (let ((x (variablize x))
5113                  (z (a-booleanv)))
5114              (attach-noticer!
5115               #'(lambda ()
5116                   (cond ((variable-real? x) (restrict-true! z))
5117                         ((variable-nonreal? x) (restrict-false! z))))
5118               x)
5119              (attach-noticer!
5120               #'(lambda ()
5121                   (cond ((variable-true? z) (restrict-real! x))
5122                         ((variable-false? z) (restrict-nonreal! x))))
5123               z)
5124              z))))
5125
5126 (defun numberpv (x)
5127   (cond ((known?-numberpv x) t)
5128         ((known?-notv-numberpv x) nil)
5129         (t (let ((x (variablize x))
5130                  (z (a-booleanv)))
5131              (attach-noticer!
5132               #'(lambda ()
5133                   (cond ((variable-number? x) (restrict-true! z))
5134                         ((variable-nonnumber? x) (restrict-false! z))))
5135               x)
5136              (attach-noticer!
5137               #'(lambda ()
5138                   (cond ((variable-true? z) (restrict-number! x))
5139                         ((variable-false? z) (restrict-nonnumber! x))))
5140               z)
5141              z))))
5142
5143 (defun booleanpv (x)
5144   (cond ((known?-booleanpv x) t)
5145         ((known?-notv-booleanpv x) nil)
5146         (t (let ((x (variablize x))
5147                  (z (a-booleanv)))
5148              (attach-noticer!
5149               #'(lambda ()
5150                   (cond ((variable-boolean? x) (restrict-true! z))
5151                         ((variable-nonboolean? x) (restrict-false! z))))
5152               x)
5153              (attach-noticer!
5154               #'(lambda ()
5155                   (cond ((variable-true? z) (restrict-boolean! x))
5156                         ((variable-false? z) (restrict-nonboolean! x))))
5157               z)
5158              z))))
5159
5160 ;;; Lifted MEMBERV
5161
5162 (defun known?-memberv-list-internal (x y)
5163   (and (consp y)
5164        (or (known?-equalv x (first y))
5165            (known?-memberv-list-internal x (rest y)))))
5166
5167 (defun known?-memberv-list (x y)
5168   (typecase y
5169     (cons (or (known?-equalv x (first y)) (known?-memberv-list x (rest y))))
5170     (variable
5171      (if (eq (variable-value y) y)
5172          (and (not (eq (variable-enumerated-domain y) t))
5173               (every
5174                #'(lambda (element) (known?-memberv-list-internal x element))
5175                (variable-enumerated-domain y)))
5176          (known?-memberv-list x (variable-value y))))
5177     (otherwise nil)))
5178
5179 (defun known?-memberv-internal (x y)
5180   (typecase y
5181     (list (known?-memberv-list x y))
5182     (vector (some #'(lambda (element) (known?-equalv x element)) y))
5183     (variable
5184      (if (eq (variable-value y) y)
5185          (and (not (eq (variable-enumerated-domain y) t))
5186               (every
5187                #'(lambda (element)
5188                    (typecase element
5189                      (list (known?-memberv-list-internal x element))
5190                      (vector (some #'(lambda (e) (known?-equalv x e)) element))
5191                      (otherwise nil)))
5192                (variable-enumerated-domain y)))
5193          (known?-memberv-internal x (variable-value y))))
5194     (otherwise (fail))))
5195
5196 (defun known?-memberv (x y)
5197   (cond ((and (variable? x) (not (eq (variable-value x) x)))
5198          (known?-memberv (variable-value x) y))
5199         ((and (variable? x) (not (eq (variable-enumerated-domain x) t)))
5200          ;; note: This first alternative is an optimization in case membership
5201          ;;       can be determined simply through sharing relationships.
5202          (or (known?-memberv-internal x y)
5203              (every #'(lambda (element) (known?-memberv-internal element y))
5204                     (variable-enumerated-domain x))))
5205         (t (known?-memberv-internal x y))))
5206
5207 (defun known?-notv-memberv-list-internal (x y)
5208   (or (not (consp y))
5209       (and (known?-notv-equalv x (first y))
5210            (known?-notv-memberv-list-internal x (rest y)))))
5211
5212 (defun known?-notv-memberv-list (x y)
5213   (typecase y
5214     (cons (and (known?-notv-equalv x (first y))
5215                (known?-notv-memberv-list x (rest y))))
5216     (variable
5217      (if (eq (variable-value y) y)
5218          (and (not (eq (variable-enumerated-domain y) t))
5219               (every #'(lambda (element)
5220                          (known?-notv-memberv-list-internal x element))
5221                      (variable-enumerated-domain y)))
5222          (known?-notv-memberv-list x (variable-value y))))
5223     (otherwise t)))
5224
5225 (defun known?-notv-memberv-internal (x y)
5226   (typecase y
5227     (list (known?-notv-memberv-list x y))
5228     (vector (every #'(lambda (element) (known?-notv-equalv x element)) y))
5229     (variable
5230      (if (eq (variable-value y) y)
5231          (and (not (eq (variable-enumerated-domain y) t))
5232               (every
5233                #'(lambda (element)
5234                    (typecase element
5235                      (list (known?-notv-memberv-list-internal x element))
5236                      (vector
5237                       (every #'(lambda (e) (known?-notv-equalv x e)) element))
5238                      (otherwise nil)))
5239                (variable-enumerated-domain y)))
5240          (known?-notv-memberv-internal x (variable-value y))))
5241     (otherwise (fail))))
5242
5243 (defun known?-notv-memberv (x y)
5244   (cond
5245     ((and (variable? x) (not (eq (variable-value x) x)))
5246      (known?-notv-memberv (variable-value x) y))
5247     ((and (variable? x) (not (eq (variable-enumerated-domain x) t)))
5248      ;; note: This first alternative is an optimization in case membership
5249      ;;       can be determined simply through sharing relationships.
5250      (or (known?-notv-memberv-internal x y)
5251          (every #'(lambda (element) (known?-notv-memberv-internal element y))
5252                 (variable-enumerated-domain x))))
5253     (t (known?-notv-memberv-internal x y))))
5254
5255 (defun assert!-memberv-internal (x y)
5256   (let ((x (value-of x)))
5257     (if (known?-notv-memberv x y) (fail))
5258     (if (variable? x)
5259         (let ((y (value-of y)))
5260           (unless (variable? y) (restrict-enumerated-domain! x y))))))
5261
5262 (defun assert!-memberv (x y)
5263   (let ((y (value-of y)))
5264     (if (vectorp y)
5265         (dotimes (i (length y))
5266           (attach-noticer! #'(lambda () (assert!-memberv-internal x y))
5267                            (aref y i)))
5268         (attach-noticer! #'(lambda () (assert!-memberv-internal x y)) y))))
5269
5270 (defun assert!-notv-memberv-internal (x y)
5271   (let ((x (value-of x)))
5272     (if (known?-memberv x y) (fail))
5273     (if (variable? x)
5274         (let ((y (value-of y)))
5275           (unless (variable? y) (restrict-enumerated-antidomain! x y))))))
5276
5277 (defun assert!-notv-memberv (x y)
5278   (let ((y (value-of y)))
5279     (if (vectorp y)
5280         (dotimes (i (length y))
5281           (attach-noticer! #'(lambda () (assert!-notv-memberv-internal x y))
5282                            (aref y i)))
5283         (attach-noticer! #'(lambda () (assert!-notv-memberv-internal x y)) y))))
5284
5285 (defun memberv (x y)
5286   (cond ((known?-memberv x y) t)
5287         ((known?-notv-memberv x y) nil)
5288         (t (let ((x (variablize x))
5289                  (z (a-booleanv)))
5290              (attach-noticer!
5291               #'(lambda ()
5292                   (cond ((known?-memberv x y) (restrict-true! z))
5293                         ((known?-notv-memberv x y) (restrict-false! z))))
5294               x)
5295              (if (vectorp y)
5296                  (dolist (element y)
5297                    (attach-noticer!
5298                     #'(lambda ()
5299                         (cond ((known?-memberv x y) (restrict-true! z))
5300                               ((known?-notv-memberv x y) (restrict-false! z))))
5301                     element))
5302                  (attach-noticer!
5303                   #'(lambda ()
5304                       (cond ((known?-memberv x y) (restrict-true! z))
5305                             ((known?-notv-memberv x y) (restrict-false! z))))
5306                   y))
5307              (attach-noticer!
5308               #'(lambda ()
5309                   (cond ((variable-true? z) (assert!-memberv x y))
5310                         ((variable-false? z) (assert!-notv-memberv x y))))
5311               z)
5312              z))))
5313
5314 ;;; Lifted Arithmetic Comparison Functions (Two argument optimized)
5315
5316 (defun =v2 (x y)
5317   (assert!-numberpv x)
5318   (assert!-numberpv y)
5319   (cond ((known?-=v2-internal x y) t)
5320         ((known?-/=v2-internal x y) nil)
5321         (t (let ((x (variablize x))
5322                  (y (variablize y))
5323                  (z (a-booleanv)))
5324              (attach-noticer!
5325               #'(lambda ()
5326                   (cond ((known?-=v2-variable x y) (restrict-true! z))
5327                         ((known?-/=v2-variable x y) (restrict-false! z))))
5328               x)
5329              (attach-noticer!
5330               #'(lambda ()
5331                   (cond ((known?-=v2-variable x y) (restrict-true! z))
5332                         ((known?-/=v2-variable x y) (restrict-false! z))))
5333               y)
5334              (attach-noticer!
5335               #'(lambda ()
5336                   (cond ((variable-true? z) (assert!-=v2 x y))
5337                         ((variable-false? z) (assert!-/=v2 x y))))
5338               z)
5339              z))))
5340
5341 (defun <=v2 (x y)
5342   (assert!-realpv x)
5343   (assert!-realpv y)
5344   (cond ((known?-<=v2-internal x y) t)
5345         ((known?-<v2-internal y x) nil)
5346         (t (let ((x (variablize x))
5347                  (y (variablize y))
5348                  (z (a-booleanv)))
5349              (attach-noticer!
5350               #'(lambda ()
5351                   (cond ((known?-<=v2-variable x y) (restrict-true! z))
5352                         ((known?-<v2-variable y x) (restrict-false! z))))
5353               x)
5354              (attach-noticer!
5355               #'(lambda ()
5356                   (cond ((known?-<=v2-variable x y) (restrict-true! z))
5357                         ((known?-<v2-variable y x) (restrict-false! z))))
5358               y)
5359              (attach-noticer!
5360               #'(lambda ()
5361                   (cond ((variable-true? z) (assert!-<=v2 x y))
5362                         ((variable-false? z) (assert!-<v2 y x))))
5363               z)
5364              z))))
5365
5366 (defun <v2 (x y)
5367   (assert!-realpv x)
5368   (assert!-realpv y)
5369   (cond ((known?-<v2-internal x y) t)
5370         ((known?-<=v2-internal y x) nil)
5371         (t (let ((x (variablize x))
5372                  (y (variablize y))
5373                  (z (a-booleanv)))
5374              (attach-noticer!
5375               #'(lambda ()
5376                   (cond ((known?-<v2-variable x y) (restrict-true! z))
5377                         ((known?-<=v2-variable y x) (restrict-false! z))))
5378               x)
5379              (attach-noticer!
5380               #'(lambda ()
5381                   (cond ((known?-<v2-variable x y) (restrict-true! z))
5382                         ((known?-<=v2-variable y x) (restrict-false! z))))
5383               y)
5384              (attach-noticer!
5385               #'(lambda ()
5386                   (cond ((variable-true? z) (assert!-<v2 x y))
5387                         ((variable-false? z) (assert!-<=v2 y x))))
5388               z)
5389              z))))
5390
5391 (defun /=v2 (x y)
5392   (assert!-numberpv x)
5393   (assert!-numberpv y)
5394   (cond ((known?-/=v2-internal x y) t)
5395         ((known?-=v2-internal x y) nil)
5396         (t (let ((x (variablize x))
5397                  (y (variablize y))
5398                  (z (a-booleanv)))
5399              (attach-noticer!
5400               #'(lambda ()
5401                   (cond ((known?-/=v2-variable x y) (restrict-true! z))
5402                         ((known?-=v2-variable x y) (restrict-false! z))))
5403               x)
5404              (attach-noticer!
5405               #'(lambda ()
5406                   (cond ((known?-/=v2-variable x y) (restrict-true! z))
5407                         ((known?-=v2-variable x y) (restrict-false! z))))
5408               y)
5409              (attach-noticer!
5410               #'(lambda ()
5411                   (cond ((variable-true? z) (assert!-/=v2 x y))
5412                         ((variable-false? z) (assert!-=v2 x y))))
5413               z)
5414              z))))
5415
5416 ;;; Lifted NOTV, ANDV and ORV
5417
5418 (defun notv (x)
5419   (assert!-booleanpv x)
5420   (let ((x (value-of x)))
5421     (cond ((eq x t) nil)
5422           ((eq x nil) t)
5423           (t (let ((z (a-booleanv)))
5424                (attach-noticer!
5425                 #'(lambda ()
5426                     (cond ((variable-true? x) (restrict-false! z))
5427                           ((variable-false? x) (restrict-true! z))))
5428                 x)
5429                (attach-noticer!
5430                 #'(lambda ()
5431                     (cond ((variable-true? z) (restrict-false! x))
5432                           ((variable-false? z) (restrict-true! x))))
5433                 z)
5434                z)))))
5435
5436 (defun andv-internal (xs)
5437   (dolist (x xs) (assert!-booleanpv x))
5438   (let ((xs (mapcar #'value-of xs)))
5439     (if (member nil xs :test #'eq)
5440         nil
5441         (let* ((xs (remove t xs :test #'eq))
5442                (count (length xs)))
5443           (cond
5444             ((zerop count) t)
5445             ((= count 1) (first xs))
5446             (t (let ((z (a-booleanv)))
5447                  (attach-noticer!
5448                   #'(lambda ()
5449                       (cond ((variable-true? z) (dolist (x xs) (restrict-true! x)))
5450                             ((and (= count 1) (variable-false? z))
5451                              (dolist (x xs)
5452                                (unless (variable-true? x) (restrict-false! x))))))
5453                   z)
5454                  (dolist (x xs)
5455                    (let ((x x))
5456                      (attach-noticer!-internal
5457                       #'(lambda ()
5458                           (cond ((variable-false? x) (restrict-false! z))
5459                                 ((variable-true? x)
5460                                  (local (decf count))
5461                                  (cond ((zerop count) (restrict-true! z))
5462                                        ((and (= count 1) (variable-false? z))
5463                                         (dolist (x xs)
5464                                           (unless (variable-true? x)
5465                                             (restrict-false! x))))))))
5466                       x)))
5467                  z)))))))
5468
5469 (defun andv (&rest xs) (andv-internal xs))
5470
5471 (defun assert!-notv-andv-internal (xs)
5472   (dolist (x xs) (assert!-booleanpv x))
5473   (let ((xs (mapcar #'value-of xs)))
5474     (unless (member nil xs :test #'eq)
5475       (let* ((xs (remove t xs :test #'eq))
5476              (count (length xs)))
5477         (cond ((zerop count) (fail))
5478               ((= count 1) (restrict-false! (first xs)))
5479               (t (dolist (x xs)
5480                    (let ((x x))
5481                      (attach-noticer!-internal
5482                       #'(lambda ()
5483                           (cond ((variable-false? x))
5484                                 ((variable-true? x)
5485                                  (local (decf count))
5486                                  (cond ((zerop count) (fail))
5487                                        ((= count 1)
5488                                         (dolist (x xs)
5489                                           (unless (variable-true? x)
5490                                             (restrict-false! x))))))))
5491                       x)))))))))
5492
5493 (defun assert!-notv-andv (&rest xs) (assert!-notv-andv-internal xs))
5494
5495 (defun orv-internal (xs)
5496   (dolist (x xs) (assert!-booleanpv x))
5497   (let ((xs (mapcar #'value-of xs)))
5498     (if (member t xs :test #'eq)
5499         t
5500         (let* ((xs (remove nil xs :test #'eq))
5501                (count (length xs)))
5502           (cond
5503             ((zerop count) nil)
5504             ((= count 1) (first xs))
5505             (t (let ((z (a-booleanv)))
5506                  (attach-noticer!
5507                   #'(lambda ()
5508                       (cond ((variable-false? z)
5509                              (dolist (x xs) (restrict-false! x)))
5510                             ((and (= count 1) (variable-true? z))
5511                              (dolist (x xs)
5512                                (unless (variable-false? x) (restrict-true! x))))))
5513                   z)
5514                  (dolist (x xs)
5515                    (let ((x x))
5516                      (attach-noticer!-internal
5517                       #'(lambda ()
5518                           (cond ((variable-true? x) (restrict-true! z))
5519                                 ((variable-false? x)
5520                                  (local (decf count))
5521                                  (cond ((zerop count) (restrict-false! z))
5522                                        ((and (= count 1) (variable-true? z))
5523                                         (dolist (x xs)
5524                                           (unless (variable-false? x)
5525                                             (restrict-true! x))))))))
5526                       x)))
5527                  z)))))))
5528
5529 (defun orv (&rest xs) (orv-internal xs))
5530
5531 (defun assert!-orv-internal (xs)
5532   (dolist (x xs) (assert!-booleanpv x))
5533   (let ((xs (mapcar #'value-of xs)))
5534     (unless (member t xs :test #'eq)
5535       (let* ((xs (remove nil xs :test #'eq))
5536              (count (length xs)))
5537         (cond ((zerop count) (fail))
5538               ((= count 1) (restrict-true! (first xs)))
5539               (t (dolist (x xs)
5540                    (let ((x x))
5541                      (attach-noticer!-internal
5542                       #'(lambda ()
5543                           (cond ((variable-true? x))
5544                                 ((variable-false? x)
5545                                  (local (decf count))
5546                                  (cond ((zerop count) (fail))
5547                                        ((= count 1)
5548                                         (dolist (x xs)
5549                                           (unless (variable-false? x)
5550                                             (restrict-true! x))))))))
5551                       x)))))))))
5552
5553 (defun assert!-orv (&rest xs) (assert!-orv-internal xs))
5554
5555 (defun assert!-clause (xs ps)
5556   (dolist (x xs) (assert!-booleanpv x))
5557   (let ((xs (mapcar #'value-of xs)))
5558     (unless (some #'eq xs ps)
5559       (let (new-xs new-ps)
5560         (do ((xrest xs (rest xrest))
5561              (prest ps (rest prest)))
5562             ((or (null xrest) (null prest)))
5563           (let ((x (first xrest))
5564                 (p (first prest)))
5565             (unless (eq x (not p))
5566               (push x new-xs)
5567               (push p new-ps))))
5568         (let ((count (length new-xs)))
5569           (cond ((zerop count) (fail))
5570                 ((= count 1)
5571                  (if (first new-ps)
5572                      (restrict-true! (first new-xs))
5573                      (restrict-false! (first new-xs))))
5574                 (t (do ((xrest new-xs (rest xrest))
5575                         (prest new-ps (rest prest)))
5576                        ((null xrest))
5577                      (let ((x (first xrest)))
5578                        (attach-noticer!-internal
5579                         (if (first prest)
5580                             #'(lambda ()
5581                                 (cond ((variable-true? x))
5582                                       ((variable-false? x)
5583                                        (local (decf count))
5584                                        (cond ((zerop count) (fail))
5585                                              ((= count 1)
5586                                               (do ((xrest new-xs (rest xrest))
5587                                                    (prest new-ps (rest prest)))
5588                                                   ((null xrest))
5589                                                 (let ((x (first xrest)))
5590                                                   (unless (bound? x)
5591                                                     (if (first prest)
5592                                                         (restrict-true! x)
5593                                                         (restrict-false! x))))))))))
5594                             #'(lambda ()
5595                                 (cond ((variable-false? x))
5596                                       ((variable-true? x)
5597                                        (local (decf count))
5598                                        (cond
5599                                          ((zerop count) (fail))
5600                                          ((= count 1)
5601                                           (do ((xrest new-xs (rest xrest))
5602                                                (prest new-ps (rest prest)))
5603                                               ((null xrest))
5604                                             (let ((x (first xrest)))
5605                                               (unless (bound? x)
5606                                                 (if (first prest)
5607                                                     (restrict-true! x)
5608                                                     (restrict-false! x)))))))))))
5609                         x))))))))))
5610
5611 (defun count-trues-internal (xs) (count-if #'identity xs))
5612
5613 (defun count-trues (&rest xs) (count-trues-internal xs))
5614
5615 (defun count-truesv-internal (xs)
5616   (dolist (x xs) (assert!-booleanpv x))
5617   (let ((xs (mapcar #'value-of xs))
5618         (lower 0)
5619         (upper (length xs)))
5620     (dolist (x xs)
5621       (cond ((eq x t) (incf lower))
5622             ((eq x nil) (decf upper))))
5623     (if (= lower upper)
5624         lower
5625         (let ((z (an-integer-betweenv lower upper))
5626               (xs (remove-if #'bound? xs)))
5627           (attach-noticer!
5628            #'(lambda ()
5629                (if (= upper (variable-lower-bound z))
5630                    (dolist (x xs)
5631                      (unless (variable-false? x) (restrict-true! x))))
5632                (if (= lower (variable-upper-bound z))
5633                    (dolist (x xs)
5634                      (unless (variable-true? x) (restrict-false! x)))))
5635            z)
5636           (dolist (x xs)
5637             (let ((x x))
5638               (attach-noticer!
5639                #'(lambda ()
5640                    (cond ((variable-false? x)
5641                           (local (decf upper))
5642                           (restrict-upper-bound! z upper)
5643                           (if (= upper (variable-lower-bound z))
5644                               (dolist (x xs)
5645                                 (unless (variable-false? x) (restrict-true! x)))))
5646                          ((variable-true? x)
5647                           (local (incf lower))
5648                           (restrict-lower-bound! z lower)
5649                           (if (= lower (variable-upper-bound z))
5650                               (dolist (x xs)
5651                                 (unless (variable-true? x) (restrict-false! x)))))))
5652                x)))
5653           z))))
5654
5655 (defun count-truesv (&rest xs) (count-truesv-internal xs))
5656
5657 ;;; Lifted FUNCALLV and APPLYV
5658
5659 (defun finite-domain? (variable)
5660   (let ((variable (value-of variable)))
5661     (or (not (variable? variable))
5662         (not (eq (variable-enumerated-domain variable) t))
5663         (and (variable-integer? variable)
5664              (variable-lower-bound variable)
5665              (variable-upper-bound variable)))))
5666
5667 ;;; note: SOLUTION, LINEAR-FORCE and STATIC-ORDERING were moved here to be
5668 ;;;       before KNOWN?-CONSTRAINT to avoid forward references to
5669 ;;;       nondeterministic functions.
5670
5671 (defun solution (x force-function)
5672   (funcall-nondeterministic
5673    (value-of force-function) (variables-in (value-of x)))
5674   (apply-substitution x))
5675
5676 (defun linear-force (variable)
5677   (let ((variable (value-of variable)))
5678     (if (variable? variable)
5679         (restrict-value!
5680          variable
5681          (cond ((not (eq (variable-enumerated-domain variable) t))
5682                 (a-member-of (variable-enumerated-domain variable)))
5683                ((variable-integer? variable)
5684                 (if (variable-lower-bound variable)
5685                     (if (variable-upper-bound variable)
5686                         (an-integer-between
5687                          (variable-lower-bound variable)
5688                          (variable-upper-bound variable))
5689                         (an-integer-above (variable-lower-bound variable)))
5690                     (if (variable-upper-bound variable)
5691                         (an-integer-below (variable-upper-bound variable))
5692                         (an-integer))))
5693                (t (error "It is only possible to linear force a variable that~%~
5694                         has a countable domain"))))))
5695   (value-of variable))
5696
5697 (defun static-ordering-internal (variables force-function)
5698   (if variables
5699       (let ((variable (value-of (first variables))))
5700         (cond ((variable? variable)
5701                (funcall-nondeterministic force-function variable)
5702                (static-ordering-internal variables force-function))
5703               (t (static-ordering-internal (rest variables) force-function))))))
5704
5705 (defun static-ordering (force-function)
5706   ;; note: This closure will heap cons.
5707   (let ((force-function (value-of force-function)))
5708     #'(lambda (variables) (static-ordering-internal variables force-function))))
5709
5710 (defun known?-constraint (f polarity? x)
5711   (let ((f (value-of f)))
5712     (if (variable? f)
5713         (error "The current implementation does not allow the first argument~%~
5714               of FUNCALLV or APPLYV to be an unbound variable"))
5715     (unless (functionp f)
5716       (error "The first argument to FUNCALLV or APPLYV must be a deterministic~%~
5717            function"))
5718     (and (every #'finite-domain? x)
5719          (block exit
5720            (for-effects
5721              (if (if polarity?
5722                      (not (apply f (solution x (static-ordering #'linear-force))))
5723                      (apply f (solution x (static-ordering #'linear-force))))
5724                  (return-from exit nil)))
5725            t))))
5726
5727 (defun propagate-gfc (predicate polarity? variables unassigned-variable)
5728   ;; note: UNASSIGNED-VARIABLE must be a variable which is not bound and
5729   ;;       all of the VARIABLES except the UNASSIGNED-VARIABLE must be bound.
5730   (let ((unassigned-variable (value-of unassigned-variable)))
5731     ;; There is no way to propagate a value to a variable that doesn't have an
5732     ;; enumerated domain.
5733     (if (and (not (eq (variable-enumerated-domain unassigned-variable) t))
5734              (not (null (rest (variable-enumerated-domain
5735                                unassigned-variable)))))
5736         ;; note: Could do less consing if had LOCAL DELETE-IF-NOT.
5737         ;; note: Consing.
5738         (let* ((variable-values (mapcar #'value-of variables))
5739                (new-enumerated-domain
5740                 (if polarity?
5741                     (remove-if-not
5742                      #'(lambda (value)
5743                          (apply predicate
5744                                 ;; note: Consing.
5745                                 (mapcar #'(lambda (variable variable-value)
5746                                             (if (eq variable unassigned-variable)
5747                                                 value
5748                                                 variable-value))
5749                                         variables
5750                                         variable-values)))
5751                      (variable-enumerated-domain unassigned-variable))
5752                     (remove-if
5753                      #'(lambda (value)
5754                          (apply predicate
5755                                 ;; note: Consing.
5756                                 (mapcar #'(lambda (variable variable-value)
5757                                             (if (eq variable unassigned-variable)
5758                                                 value
5759                                                 variable-value))
5760                                         variables
5761                                         variable-values)))
5762                      (variable-enumerated-domain unassigned-variable)))))
5763           (if (set-enumerated-domain! unassigned-variable new-enumerated-domain)
5764               (run-noticers unassigned-variable))))))
5765
5766 (defun a-tuple (variables variable value)
5767   (if (null variables)
5768       nil
5769       (cons (cond ((eq (first variables) variable) value)
5770                   ((variable? (first variables))
5771                    (a-member-of (variable-enumerated-domain (first variables))))
5772                   (t (first variables)))
5773             (a-tuple (rest variables) variable value))))
5774
5775 (defun propagate-ac (predicate polarity? variables)
5776   (unless (some #'(lambda (variable)
5777                     (and (variable? variable)
5778                          (eq (variable-enumerated-domain variable) t)))
5779                 variables)
5780     (dolist (variable variables)
5781       ;; note: Could do less consing if had LOCAL DELETE-IF-NOT.
5782       (if (variable? variable)
5783           (let ((new-enumerated-domain
5784                  (if polarity?
5785                      (remove-if-not
5786                       #'(lambda (value)
5787                           (possibly?
5788                             ;; note: Consing.
5789                             (apply predicate (a-tuple variables variable value))))
5790                       (variable-enumerated-domain variable))
5791                      (remove-if
5792                       #'(lambda (value)
5793                           (possibly?
5794                             ;; note: Consing.
5795                             (apply predicate (a-tuple variables variable value))))
5796                       (variable-enumerated-domain variable)))))
5797             (if (set-enumerated-domain! variable new-enumerated-domain)
5798                 (run-noticers variable)))))))
5799
5800 (defun assert!-constraint-gfc (predicate polarity? variables)
5801   (let ((predicate (value-of predicate))
5802         (multiple-unassigned-variables? nil)
5803         (unassigned-variable nil))
5804     (if (variable? predicate)
5805         (error "The current implementation does not allow the first argument~%~
5806               of FUNCALLV or APPLYV to be an unbound variable"))
5807     (unless (functionp predicate)
5808       (error "The first argument to FUNCALLV or APPLYV must be a deterministic~%~
5809            function"))
5810     (dolist (variable variables)
5811       (unless (bound? variable)
5812         (if unassigned-variable (setf multiple-unassigned-variables? t))
5813         (setf unassigned-variable variable)))
5814     (cond
5815       (multiple-unassigned-variables?
5816        ;; The case where two or more variables are unbound
5817        (let ((variables (copy-list variables)))
5818          (dolist (variable variables)
5819            (unless (bound? variable)
5820              (let ((variable variable))
5821                (attach-noticer!
5822                 #'(lambda ()
5823                     (global
5824                       (block exit
5825                         (let ((unassigned-variable nil))
5826                           (dolist (variable variables)
5827                             (unless (bound? variable)
5828                               (if unassigned-variable (return-from exit))
5829                               (setf unassigned-variable variable)))
5830                           (if unassigned-variable
5831                               (propagate-gfc
5832                                predicate polarity? variables unassigned-variable)
5833                               (unless (if polarity?
5834                                           (apply predicate (mapcar #'value-of variables))
5835                                           (not (apply predicate
5836                                                       (mapcar #'value-of variables))))
5837                                 (fail)))))))
5838                 variable))))))
5839       (unassigned-variable
5840        ;; The case where all but one of the variables are bound
5841        (propagate-gfc predicate polarity? variables unassigned-variable))
5842       ;; The case where all variables are bound
5843       ;; note: Consing.
5844       (t (unless (if polarity?
5845                      (apply predicate (mapcar #'value-of variables))
5846                      (not (apply predicate (mapcar #'value-of variables))))
5847            (fail))))))
5848
5849 (defun assert!-constraint-ac (predicate polarity? variables)
5850   (let ((predicate (value-of predicate)))
5851     (if (variable? predicate)
5852         (error "The current implementation does not allow the first argument~%~
5853               of FUNCALLV or APPLYV to be an unbound variable"))
5854     (unless (functionp predicate)
5855       (error "The first argument to FUNCALLV or APPLYV must be a deterministic~%~
5856            function"))
5857     (dolist (variable variables)
5858       (attach-noticer!
5859        #'(lambda () (propagate-ac predicate polarity? variables))
5860        variable))
5861     (propagate-ac predicate polarity? variables)))
5862
5863 (defun assert!-constraint (predicate polarity? variables)
5864   (ecase *strategy*
5865     (:gfc (assert!-constraint-gfc predicate polarity? variables))
5866     (:ac (assert!-constraint-ac predicate polarity? variables))))
5867
5868 (defun known?-funcallv (f &rest x) (known?-constraint f t x))
5869
5870 (defun known?-notv-funcallv (f &rest x) (known?-constraint f nil x))
5871
5872 (defun assert!-funcallv (f &rest x) (assert!-constraint f t x))
5873
5874 (defun assert!-notv-funcallv (f &rest x) (assert!-constraint f nil x))
5875
5876 (defun funcallv (f &rest x)
5877   (let ((f (value-of f)))
5878     (if (variable? f)
5879         (error "The current implementation does not allow the first argument~%~
5880               of FUNCALLV to be an unbound variable"))
5881     (unless (functionp f)
5882       (error "The first argument to FUNCALLV must be a deterministic function"))
5883     (if (every #'bound? x)
5884         (apply f (mapcar #'value-of x))
5885         (let ((z (make-variable)))
5886           (assert!-constraint
5887            #'(lambda (&rest x) (equal (first x) (apply f (rest x)))) t (cons z x))
5888           (dolist (argument x)
5889             (attach-noticer!
5890              #'(lambda ()
5891                  (if (every #'bound? x)
5892                      (assert!-equalv z (apply f (mapcar #'value-of x)))))
5893              argument))
5894           z))))
5895
5896 (defun arguments-for-applyv (x xs)
5897   (unless (bound? (first (last (cons x xs))))
5898     (error "The current implementation does not allow the last argument to~%~
5899           APPLYV to be an unbound variable"))
5900   (apply #'list* (mapcar #'value-of (cons x xs))))
5901
5902 (defun known?-applyv (f x &rest xs)
5903   (known?-constraint f t (arguments-for-applyv x xs)))
5904
5905 (defun known?-notv-applyv (f x &rest xs)
5906   (known?-constraint f nil (arguments-for-applyv x xs)))
5907
5908 (defun assert!-applyv (f x &rest xs)
5909   (assert!-constraint f t (arguments-for-applyv x xs)))
5910
5911 (defun assert!-notv-applyv (f x &rest xs)
5912   (assert!-constraint f nil (arguments-for-applyv x xs)))
5913
5914 (defun applyv (f x &rest xs)
5915   (let ((f (value-of f)))
5916     (if (variable? f)
5917         (error "The current implementation does not allow the first argument~%~
5918               of APPLYV to be an unbound variable"))
5919     (unless (functionp f)
5920       (error "The first argument to APPLYV must be a deterministic function"))
5921     (let ((arguments (arguments-for-applyv x xs)))
5922       (if (every #'bound? arguments)
5923           (apply f (mapcar #'value-of arguments))
5924           (let ((z (make-variable)))
5925             (assert!-constraint
5926              #'(lambda (&rest x) (equal (first x) (apply f (rest x))))
5927              t
5928              (cons z arguments))
5929             (dolist (argument arguments)
5930               (attach-noticer!
5931                #'(lambda ()
5932                    (if (every #'bound? arguments)
5933                        (assert!-equalv z (apply f (mapcar #'value-of arguments)))))
5934                argument))
5935             z)))))
5936
5937 ;;; Lifted EQUALV
5938
5939 (defun known?-equalv (x y)
5940   (or (eql x y)
5941       (cond ((variable? x)
5942              (and (not (eq (variable-value x) x))
5943                   (known?-equalv (variable-value x) y)))
5944             ((variable? y)
5945              (and (not (eq (variable-value y) y))
5946                   (known?-equalv x (variable-value y))))
5947             (t (and (consp x)
5948                     (consp y)
5949                     (known?-equalv (car x) (car y))
5950                     (known?-equalv (cdr x) (cdr y)))))))
5951
5952 (defun assert!-equalv (x y)
5953   (unless (eql x y)
5954     (cond ((variable? x)
5955            (cond ((not (eq (variable-value x) x))
5956                   (assert!-equalv (variable-value x) y))
5957                  ((variable? y)
5958                   (if (eq (variable-value y) y)
5959                       (share! x y)
5960                       (assert!-equalv x (variable-value y))))
5961                  (t (restrict-value! x y))))
5962           ((variable? y)
5963            (if (eq (variable-value y) y)
5964                (restrict-value! y x)
5965                (assert!-equalv x (variable-value y))))
5966           ((and (consp x) (consp y))
5967            (assert!-equalv (car x) (car y))
5968            (assert!-equalv (cdr x) (cdr y)))
5969           (t (fail)))))
5970
5971 (defun known?-notv-equalv (x y) (one-value (progn (assert!-equalv x y) nil) t))
5972
5973 (defun assert!-notv-equalv (x y)
5974   ;; note: Can be made more efficient so that if you later find out that
5975   ;;       X and Y are KNOWN?-NUMBERPV you can then ASSERT!-/=V2.
5976   (if (known?-equalv x y) (fail))
5977   (unless (known?-notv-equalv x y)
5978     (let ((x (variablize x))
5979           (y (variablize y)))
5980       (attach-noticer! #'(lambda () (if (known?-equalv x y) (fail))) x)
5981       (attach-noticer! #'(lambda () (if (known?-equalv x y) (fail))) y))))
5982
5983 (defun equalv (x y)
5984   ;; note: Can be made more efficient and return an AND tree of individual
5985   ;;       constraints needed to make EQUALV true. This can be done also for
5986   ;;       the KNOWN? and ASSERT! versions.
5987   (cond ((known?-equalv x y) t)
5988         ((known?-notv-equalv x y) nil)
5989         (t (let ((x (variablize x))
5990                  (y (variablize y))
5991                  (z (a-booleanv)))
5992              (attach-noticer!
5993               #'(lambda ()
5994                   (cond ((known?-equalv x y) (restrict-true! z))
5995                         ((known?-notv-equalv x y) (restrict-false! z))))
5996               x)
5997              (attach-noticer!
5998               #'(lambda ()
5999                   (cond ((known?-equalv x y) (restrict-true! z))
6000                         ((known?-notv-equalv x y) (restrict-false! z))))
6001               y)
6002              (attach-noticer!
6003               #'(lambda ()
6004                   (cond ((variable-true? z) (assert!-equalv x y))
6005                         ((variable-false? z) (assert!-notv-equalv x y))))
6006               z)
6007              z))))
6008
6009 ;;; Lifted Arithmetic Functions
6010
6011 (defun +v-internal (xs)
6012   (if (null xs) 0 (+v2 (first xs) (+v-internal (rest xs)))))
6013
6014 (defun +v (&rest xs) (+v-internal xs))
6015
6016 (defun -v-internal (x xs)
6017   (if (null xs) x (-v-internal (-v2 x (first xs)) (rest xs))))
6018
6019 (defun -v (x &rest xs) (if (null xs) (-v2 0 x) (-v-internal x xs)))
6020
6021 (defun *v-internal (xs)
6022   (if (null xs) 1 (*v2 (first xs) (*v-internal (rest xs)))))
6023
6024 (defun *v (&rest xs) (*v-internal xs))
6025
6026 (defun /v-internal (x xs)
6027   (if (null xs) x (/v-internal (/v2 x (first xs)) (rest xs))))
6028
6029 (defun /v (x &rest xs) (if (null xs) (/v2 1 x) (/v-internal x xs)))
6030
6031 (defun minv-internal (x xs)
6032   (if (null xs) x (minv-internal (minv2 x (first xs)) (rest xs))))
6033
6034 (defun minv (x &rest xs) (if (null xs) x (minv-internal x xs)))
6035
6036 (defun maxv-internal (x xs)
6037   (if (null xs) x (maxv-internal (maxv2 x (first xs)) (rest xs))))
6038
6039 (defun maxv (x &rest xs) (if (null xs) x (maxv-internal x xs)))
6040
6041 ;;; Lifted Arithmetic Comparison Functions (KNOWN? optimized)
6042
6043 (defun known?-=v-internal (x xs)
6044   (if (null xs)
6045       t
6046       (and (known?-=v2 x (first xs))
6047            (known?-=v-internal (first xs) (rest xs)))))
6048
6049 (defun known?-=v (x &rest xs) (known?-=v-internal x xs))
6050
6051 (defun known?-<v-internal (x xs)
6052   (if (null xs)
6053       t
6054       (and (known?-<v2 x (first xs))
6055            (known?-<v-internal (first xs) (rest xs)))))
6056
6057 (defun known?-<v (x &rest xs) (known?-<v-internal x xs))
6058
6059 (defun known?-<=v-internal (x xs)
6060   (if (null xs)
6061       t
6062       (and (known?-<=v2 x (first xs))
6063            (known?-<=v-internal (first xs) (rest xs)))))
6064
6065 (defun known?-<=v (x &rest xs) (known?-<=v-internal x xs))
6066
6067 (defun known?->v-internal (x xs)
6068   (if (null xs)
6069       t
6070       (and (known?-<v2 (first xs) x)
6071            (known?->v-internal (first xs) (rest xs)))))
6072
6073 (defun known?->v (x &rest xs) (known?->v-internal x xs))
6074
6075 (defun known?->=v-internal (x xs)
6076   (if (null xs)
6077       t
6078       (and (known?-<=v2 (first xs) x)
6079            (known?->=v-internal (first xs) (rest xs)))))
6080
6081 (defun known?->=v (x &rest xs) (known?->=v-internal x xs))
6082
6083 (defun known?-/=v-internal (x xs)
6084   (if (null xs)
6085       t
6086       (and (known?-/=v2 x (first xs))
6087            (known?-/=v-internal x (rest xs))
6088            (known?-/=v-internal (first xs) (rest xs)))))
6089
6090 (defun known?-/=v (x &rest xs) (known?-/=v-internal x xs))
6091
6092 ;;; Lifted Arithmetic Comparison Functions (ASSERT! optimized)
6093
6094 (defun assert!-=v-internal (x xs)
6095   (unless (null xs)
6096     (assert!-=v2 x (first xs))
6097     (assert!-=v-internal (first xs) (rest xs))))
6098
6099 (defun assert!-=v (x &rest xs) (assert!-=v-internal x xs))
6100
6101 (defun assert!-<v-internal (x xs)
6102   (unless (null xs)
6103     (assert!-<v2 x (first xs))
6104     (assert!-<v-internal (first xs) (rest xs))))
6105
6106 (defun assert!-<v (x &rest xs) (assert!-<v-internal x xs))
6107
6108 (defun assert!-<=v-internal (x xs)
6109   (unless (null xs)
6110     (assert!-<=v2 x (first xs))
6111     (assert!-<=v-internal (first xs) (rest xs))))
6112
6113 (defun assert!-<=v (x &rest xs) (assert!-<=v-internal x xs))
6114
6115 (defun assert!->v-internal (x xs)
6116   (unless (null xs)
6117     (assert!-<v2 (first xs) x)
6118     (assert!->v-internal (first xs) (rest xs))))
6119
6120 (defun assert!->v (x &rest xs) (assert!->v-internal x xs))
6121
6122 (defun assert!->=v-internal (x xs)
6123   (unless (null xs)
6124     (assert!-<=v2 (first xs) x)
6125     (assert!->=v-internal (first xs) (rest xs))))
6126
6127 (defun assert!->=v (x &rest xs) (assert!->=v-internal x xs))
6128
6129 (defun assert!-/=v-internal (x xs)
6130   (unless (null xs)
6131     (assert!-/=v2 x (first xs))
6132     (assert!-/=v-internal x (rest xs))
6133     (assert!-/=v-internal (first xs) (rest xs))))
6134
6135 (defun assert!-/=v (x &rest xs) (assert!-/=v-internal x xs))
6136
6137 ;;; Lifted Arithmetic Comparisons Functions
6138
6139 (defun =v-internal (x xs)
6140   (if (null xs)
6141       t
6142       (andv (=v2 x (first xs)) (=v-internal (first xs) (rest xs)))))
6143
6144 (defun =v (x &rest xs) (=v-internal x xs))
6145
6146 (defun <v-internal (x xs)
6147   (if (null xs)
6148       t
6149       (andv (<v2 x (first xs)) (<v-internal (first xs) (rest xs)))))
6150
6151 (defun <v (x &rest xs) (<v-internal x xs))
6152
6153 (defun <=v-internal (x xs)
6154   (if (null xs)
6155       t
6156       (andv (<=v2 x (first xs)) (<=v-internal (first xs) (rest xs)))))
6157
6158 (defun <=v (x &rest xs) (<=v-internal x xs))
6159
6160 (defun >v-internal (x xs)
6161   (if (null xs)
6162       t
6163       (andv (<v2 (first xs) x) (>v-internal (first xs) (rest xs)))))
6164
6165 (defun >v (x &rest xs) (>v-internal x xs))
6166
6167 (defun >=v-internal (x xs)
6168   (if (null xs)
6169       t
6170       (andv (<=v2 (first xs) x) (>=v-internal (first xs) (rest xs)))))
6171
6172 (defun >=v (x &rest xs) (>=v-internal x xs))
6173
6174 (defun /=v-internal (x xs)
6175   (if (null xs)
6176       t
6177       (andv (/=v2 x (first xs))
6178             (/=v-internal x (rest xs))
6179             (/=v-internal (first xs) (rest xs)))))
6180
6181 (defun /=v (x &rest xs) (/=v-internal x xs))
6182
6183 ;;; The Optimizer Macros for ASSERT!, KNOWN? and DECIDE
6184
6185 (defun known?-true (x) (assert!-booleanpv x) (eq (value-of x) t))
6186
6187 (defun known?-false (x) (assert!-booleanpv x) (null (value-of x)))
6188
6189 (defun-compile-time transform-known? (form polarity?)
6190   (if (and (consp form) (null (rest (last form))))
6191       (cond
6192         ((and (eq (first form) 'notv)
6193               (= (length form) 2))
6194          (transform-known? (second form) (not polarity?)))
6195         ((eq (first form) 'andv)
6196          (cons (if polarity? 'and 'or)
6197                (mapcar #'(lambda (form) (transform-known? form polarity?))
6198                        (rest form))))
6199         ((eq (first form) 'orv)
6200          (cons (if polarity? 'or 'and)
6201                (mapcar #'(lambda (form) (transform-known? form polarity?))
6202                        (rest form))))
6203         ((member (first form)
6204                  '(integerpv realpv numberpv memberv booleanpv
6205                    =v <v <=v >v >=v /=v funcallv applyv equalv)
6206                  :test #'eq)
6207          (cons (cdr (assoc (first form)
6208                            (if polarity?
6209                                '((integerpv . known?-integerpv)
6210                                  (realpv . known?-realpv)
6211                                  (numberpv . known?-numberpv)
6212                                  (memberv . known?-memberv)
6213                                  (booleanpv . known?-booleanpv)
6214                                  (=v . known?-=v)
6215                                  (<v . known?-<v)
6216                                  (<=v . known?-<=v)
6217                                  (>v . known?->v)
6218                                  (>=v . known?->=v)
6219                                  (/=v . known?-/=v)
6220                                  (funcallv . known?-funcallv)
6221                                  (applyv . known?-applyv)
6222                                  (equalv . known?-equalv))
6223                                '((integerpv . known?-notv-integerpv)
6224                                  (realpv . known?-notv-realpv)
6225                                  (numberpv . known?-notv-numberpv)
6226                                  (memberv . known?-notv-memberv)
6227                                  (booleanpv . known?-notv-booleanpv)
6228                                  (=v . known?-/=v)
6229                                  (<v . known?->=v)
6230                                  (<=v . known?->v)
6231                                  (>v . known?-<=v)
6232                                  (>=v . known?-<v)
6233                                  (/=v . known?-=v)
6234                                  (funcallv . known?-notv-funcallv)
6235                                  (applyv . known?-notv-applyv)
6236                                  (equalv . known?-notv-equalv)))
6237                            :test #'eq))
6238                (rest form)))
6239         (polarity? `(known?-true ,form))
6240         (t `(known?-false ,form)))
6241       (if polarity? `(known?-true ,form) `(known?-false ,form))))
6242
6243 (defmacro-compile-time known? (form) (transform-known? form t))
6244
6245 (defun assert!-true (x) (assert!-equalv x t))
6246
6247 (defun assert!-false (x) (assert!-equalv x nil))
6248
6249 (defun-compile-time transform-assert! (form polarity?)
6250   (if (and (consp form) (null (rest (last form))))
6251       (cond
6252         ((and (eq (first form) 'notv)
6253               (= (length form) 2))
6254          (transform-assert! (second form) (not polarity?)))
6255         ((eq (first form) 'andv)
6256          (if polarity?
6257              `(progn ,@(mapcar
6258                         #'(lambda (form) (transform-assert! form polarity?))
6259                         (rest form)))
6260              (cond ((null (rest form)) `(fail))
6261                    ((null (rest (rest form))) `(assert!-false ,(second form)))
6262                    (t `(assert!-notv-andv ,@(rest form))))))
6263         ((eq (first form) 'orv)
6264          (if polarity?
6265              (cond ((null (rest form)) `(fail))
6266                    ((null (rest (rest form))) `(assert!-true ,(second form)))
6267                    (t `(assert!-orv ,@(rest form))))
6268              `(progn ,@(mapcar
6269                         #'(lambda (form) (transform-assert! form polarity?))
6270                         (rest form)))))
6271         ((member (first form)
6272                  '(integerpv realpv numberpv memberv booleanpv
6273                    =v <v <=v >v >=v /=v funcallv applyv equalv)
6274                  :test #'eq)
6275          (cons (cdr (assoc (first form)
6276                            (if polarity?
6277                                '((integerpv . assert!-integerpv)
6278                                  (realpv . assert!-realpv)
6279                                  (numberpv . assert!-numberpv)
6280                                  (memberv . assert!-memberv)
6281                                  (booleanpv . assert!-booleanpv)
6282                                  (=v . assert!-=v)
6283                                  (<v . assert!-<v)
6284                                  (<=v . assert!-<=v)
6285                                  (>v . assert!->v)
6286                                  (>=v . assert!->=v)
6287                                  (/=v . assert!-/=v)
6288                                  (funcallv . assert!-funcallv)
6289                                  (applyv . assert!-applyv)
6290                                  (equalv . assert!-equalv))
6291                                '((integerpv . assert!-notv-integerpv)
6292                                  (realpv . assert!-notv-realpv)
6293                                  (numberpv . assert!-notv-numberpv)
6294                                  (memberv . assert!-notv-memberv)
6295                                  (booleanpv . assert!-notv-booleanpv)
6296                                  (=v . assert!-/=v)
6297                                  (<v . assert!->=v)
6298                                  (<=v . assert!->v)
6299                                  (>v . assert!-<=v)
6300                                  (>=v . assert!-<v)
6301                                  (/=v . assert!-=v)
6302                                  (funcallv . assert!-notv-funcallv)
6303                                  (applyv . assert!-notv-applyv)
6304                                  (equalv . assert!-notv-equalv)))
6305                            :test #'eq))
6306                (rest form)))
6307         (polarity? `(assert!-true ,form))
6308         (t `(assert!-false ,form)))
6309       (if polarity? `(assert!-true ,form) `(assert!-false ,form))))
6310
6311 (defmacro-compile-time assert! (form) (transform-assert! form t))
6312
6313 (defun-compile-time transform-decide (form polarity?)
6314   (if (and (consp form) (null (rest (last form))))
6315       (cond
6316         ((and (eq (first form) 'notv)
6317               (= (length form) 2))
6318          (transform-decide (second form) (not polarity?)))
6319         ((eq (first form) 'andv)
6320          (let ((result (mapcar #'(lambda (form)
6321                                    (multiple-value-list
6322                                     (transform-decide form polarity?)))
6323                                (rest form))))
6324            (values (reduce #'append (mapcar #'first result))
6325                    (cons (if polarity? 'progn 'either)
6326                          (mapcar #'second result))
6327                    (cons (if polarity? 'either 'progn)
6328                          (mapcar #'third result)))))
6329         ((eq (first form) 'orv)
6330          (let ((result (mapcar #'(lambda (form)
6331                                    (multiple-value-list
6332                                     (transform-decide form polarity?)))
6333                                (rest form))))
6334            (values (reduce #'append (mapcar #'first result))
6335                    (cons (if polarity? 'either 'progn)
6336                          (mapcar #'second result))
6337                    (cons (if polarity? 'progn 'either)
6338                          (mapcar #'third result)))))
6339         ((member (first form)
6340                  '(integerpv realpv numberpv memberv booleanpv
6341                    =v <v <=v >v >=v /=v funcallv applyv equalv)
6342                  :test #'eq)
6343          (let ((arguments (mapcar #'(lambda (argument)
6344                                       (declare (ignore argument))
6345                                       (gensym "ARGUMENT-"))
6346                                   (rest form))))
6347            (values (mapcar #'list arguments (rest form))
6348                    (cons (cdr (assoc (first form)
6349                                      (if polarity?
6350                                          '((integerpv . assert!-integerpv)
6351                                            (realpv . assert!-realpv)
6352                                            (numberpv . assert!-numberpv)
6353                                            (memberv . assert!-memberv)
6354                                            (booleanpv . assert!-booleanpv)
6355                                            (=v . assert!-=v)
6356                                            (<v . assert!-<v)
6357                                            (<=v . assert!-<=v)
6358                                            (>v . assert!->v)
6359                                            (>=v . assert!->=v)
6360                                            (/=v . assert!-/=v)
6361                                            (funcallv . assert!-funcallv)
6362                                            (applyv . assert!-applyv)
6363                                            (equalv . assert!-equalv))
6364                                          '((integerpv . assert!-notv-integerpv)
6365                                            (realpv . assert!-notv-realpv)
6366                                            (numberpv . assert!-notv-numberpv)
6367                                            (memberv . assert!-notv-memberv)
6368                                            (booleanpv . assert!-notv-booleanpv)
6369                                            (=v . assert!-/=v)
6370                                            (<v . assert!->=v)
6371                                            (<=v . assert!->v)
6372                                            (>v . assert!-<=v)
6373                                            (>=v . assert!-<v)
6374                                            (/=v . assert!-=v)
6375                                            (funcallv . assert!-notv-funcallv)
6376                                            (applyv . assert!-notv-applyv)
6377                                            (equalv . assert!-notv-equalv)))
6378                                      :test #'eq))
6379                          arguments)
6380                    (cons (cdr (assoc (first form)
6381                                      (if polarity?
6382                                          '((integerpv . assert!-notv-integerpv)
6383                                            (realpv . assert!-notv-realpv)
6384                                            (numberpv . assert!-notv-numberpv)
6385                                            (memberv . assert!-notv-memberv)
6386                                            (booleanpv . assert!-notv-booleanpv)
6387                                            (=v . assert!-/=v)
6388                                            (<v . assert!->=v)
6389                                            (<=v . assert!->v)
6390                                            (>v . assert!-<=v)
6391                                            (>=v . assert!-<v)
6392                                            (/=v . assert!-=v)
6393                                            (funcallv . assert!-notv-funcallv)
6394                                            (applyv . assert!-notv-applyv)
6395                                            (equalv . assert!-notv-equalv))
6396                                          '((integerpv . assert!-integerpv)
6397                                            (realpv . assert!-realpv)
6398                                            (numberpv . assert!-numberpv)
6399                                            (memberv . assert!-memberv)
6400                                            (booleanpv . assert!-booleanpv)
6401                                            (=v . assert!-=v)
6402                                            (<v . assert!-<v)
6403                                            (<=v . assert!-<=v)
6404                                            (>v . assert!->v)
6405                                            (>=v . assert!->=v)
6406                                            (/=v . assert!-/=v)
6407                                            (funcallv . assert!-funcallv)
6408                                            (applyv . assert!-applyv)
6409                                            (equalv . assert!-equalv)))
6410                                      :test #'eq))
6411                          arguments))))
6412         (t (let ((argument (gensym "ARGUMENT-")))
6413              (values (list (list argument form))
6414                      (if polarity?
6415                          `(assert!-true ,argument)
6416                          `(assert!-false ,argument))
6417                      (if polarity?
6418                          `(assert!-false ,argument)
6419                          `(assert!-true ,argument))))))
6420       (let ((argument (gensym "ARGUMENT-")))
6421         (values
6422          (list (list argument form))
6423          (if polarity? `(assert!-true ,argument) `(assert!-false ,argument))
6424          (if polarity? `(assert!-false ,argument) `(assert!-true ,argument))))))
6425
6426 (defmacro-compile-time decide (form)
6427   (cl:multiple-value-bind (arguments true false)
6428       (transform-decide form t)
6429     `(let ,arguments (either (progn ,true t) (progn ,false nil)))))
6430
6431 ;;; Lifted Generators
6432 ;;; note: The following functions could be handled more efficiently as special
6433 ;;;       cases.
6434
6435 (defun a-booleanv (&optional (name nil name?))
6436   (let ((v (if name? (make-variable name) (make-variable))))
6437     (assert! (booleanpv v))
6438     v))
6439
6440 (defun an-integerv (&optional (name nil name?))
6441   (let ((v (if name? (make-variable name) (make-variable))))
6442     (assert! (integerpv v))
6443     v))
6444
6445 (defun an-integer-abovev (low &optional (name nil name?))
6446   (let ((v (if name? (make-variable name) (make-variable))))
6447     (assert! (andv (integerpv v) (>=v v low)))
6448     v))
6449
6450 (defun an-integer-belowv (high &optional (name nil name?))
6451   (let ((v (if name? (make-variable name) (make-variable))))
6452     (assert! (andv (integerpv v) (<=v v high)))
6453     v))
6454
6455 (defun an-integer-betweenv (low high &optional (name nil name?))
6456   (let ((v (if name? (make-variable name) (make-variable))))
6457     (assert! (andv (integerpv v) (>=v v low) (<=v v high)))
6458     (value-of v)))
6459
6460 (defun a-realv (&optional (name nil name?))
6461   (let ((v (if name? (make-variable name) (make-variable))))
6462     (assert! (realpv v))
6463     v))
6464
6465 (defun a-real-abovev (low &optional (name nil name?))
6466   (let ((v (if name? (make-variable name) (make-variable))))
6467     (assert! (andv (realpv v) (>=v v low)))
6468     v))
6469
6470 (defun a-real-belowv (high &optional (name nil name?))
6471   (let ((v (if name? (make-variable name) (make-variable))))
6472     (assert! (andv (realpv v) (<=v v high)))
6473     v))
6474
6475 (defun a-real-betweenv (low high &optional (name nil name?))
6476   (let ((v (if name? (make-variable name) (make-variable))))
6477     (assert! (andv (realpv v) (>=v v low) (<=v v high)))
6478     v))
6479
6480 (defun a-numberv (&optional (name nil name?))
6481   (let ((v (if name? (make-variable name) (make-variable))))
6482     (assert! (numberpv v))
6483     v))
6484
6485 (defun a-member-ofv (values &optional (name nil name?))
6486   (let ((v (if name? (make-variable name) (make-variable))))
6487     (assert! (memberv v values))
6488     (value-of v)))
6489
6490 ;;; Search Control
6491
6492 (defun variables-in (x)
6493   (typecase x
6494     (cons (append (variables-in (car x)) (variables-in (cdr x))))
6495     (variable (list x))
6496     (otherwise nil)))
6497
6498 ;;; note: SOLUTION and LINEAR-FORCE used to be here but was moved to be before
6499 ;;;       KNOWN?-CONSTRAINT to avoid forward references to nondeterministic
6500 ;;;       functions.
6501
6502 (defun divide-and-conquer-force (variable)
6503   (let ((variable (value-of variable)))
6504     (if (variable? variable)
6505         (cond
6506           ((not (eq (variable-enumerated-domain variable) t))
6507            (let ((n (floor (length (variable-enumerated-domain variable)) 2)))
6508              (set-enumerated-domain!
6509               variable
6510               (either (subseq (variable-enumerated-domain variable) 0 n)
6511                       (subseq (variable-enumerated-domain variable) n)))
6512              (run-noticers variable)))
6513           ((and (variable-real? variable)
6514                 (variable-lower-bound variable)
6515                 (variable-upper-bound variable))
6516            (if (variable-integer? variable)
6517                (let ((midpoint (floor (+ (variable-lower-bound variable)
6518                                          (variable-upper-bound variable))
6519                                       2)))
6520                  (either (let ((old-bound (variable-upper-bound variable)))
6521                            (restrict-upper-bound! variable midpoint)
6522                            (if (= old-bound (variable-upper-bound variable))
6523                                (fail)))
6524                          (let ((old-bound (variable-lower-bound variable)))
6525                            (restrict-lower-bound! variable (1+ midpoint))
6526                            (if (= old-bound (variable-lower-bound variable))
6527                                (fail)))))
6528                (let ((midpoint (/ (+ (variable-lower-bound variable)
6529                                      (variable-upper-bound variable))
6530                                   2)))
6531                  (either (let ((old-bound (variable-upper-bound variable)))
6532                            (restrict-upper-bound! variable midpoint)
6533                            (if (= old-bound (variable-upper-bound variable))
6534                                (fail)))
6535                          (let ((old-bound (variable-lower-bound variable)))
6536                            (restrict-lower-bound! variable midpoint)
6537                            (if (= old-bound (variable-lower-bound variable))
6538                                (fail)))))))
6539           (t (error "It is only possible to divide and conquer force a~%~
6540                   variable that has a countable domain or a finite range")))))
6541   (value-of variable))
6542
6543 ;;; note: STATIC-ORDERING used to be here but was moved to be before
6544 ;;;       KNOWN?-CONSTRAINT to avoid a forward reference to a nondeterministic
6545 ;;;       function.
6546
6547 (defun domain-size (x)
6548   (let ((x (value-of x)))
6549     (typecase x
6550       (cons (infinity-* (domain-size (car x)) (domain-size (cdr x))))
6551       (variable
6552        (cond ((not (eq (variable-enumerated-domain x) t))
6553               (length (variable-enumerated-domain x)))
6554              ((and (variable-lower-bound x)
6555                    (variable-upper-bound x)
6556                    (variable-integer? x))
6557               (1+ (- (variable-upper-bound x) (variable-lower-bound x))))
6558              (t nil)))
6559       (otherwise 1))))
6560
6561 (defun range-size (x)
6562   (let ((x (value-of x)))
6563     (typecase x
6564       (integer 0)
6565       (real 0.0)
6566       (variable (and (variable-real? x)
6567                      (variable-lower-bound x)
6568                      (variable-upper-bound x)
6569                      (- (variable-upper-bound x) (variable-lower-bound x))))
6570       (otherwise nil))))
6571
6572 (defun corrupted? (variable)
6573   (let* ((lower-bound (variable-lower-bound variable))
6574          (upper-bound (variable-upper-bound variable)))
6575     (and lower-bound
6576          upper-bound
6577          (/= lower-bound upper-bound)
6578          (let ((midpoint (/ (+ lower-bound upper-bound) 2)))
6579            (or (= midpoint lower-bound) (= midpoint upper-bound))))))
6580
6581 (defun find-best (cost order list)
6582   (let ((best nil)
6583         (best-cost nil))
6584     (dolist (x list)
6585       (let ((x (value-of x)))
6586         (if (and (variable? x) (not (corrupted? x)))
6587             (let ((cost (funcall cost x)))
6588               (when (and (not (null cost))
6589                          (or (null best-cost) (funcall order cost best-cost)))
6590                 (setf best x)
6591                 (setf best-cost cost))))))
6592     best))
6593
6594 (defun reorder-internal
6595     (variables cost-function terminate? order force-function)
6596   (let ((variable (find-best cost-function order variables)))
6597     (when (and variable
6598                (not (funcall terminate? (funcall cost-function variable))))
6599       (funcall-nondeterministic force-function (value-of variable))
6600       (reorder-internal
6601        variables cost-function terminate? order force-function))))
6602
6603 (defun reorder (cost-function terminate? order force-function)
6604   ;; note: This closure will heap cons.
6605   (let ((cost-function (value-of cost-function))
6606         (terminate? (value-of terminate?))
6607         (order (value-of order))
6608         (force-function (value-of force-function)))
6609     #'(lambda (variables)
6610         (reorder-internal
6611          variables cost-function terminate? order force-function))))
6612
6613 (defmacro-compile-time best-value
6614     (form1 objective-form &optional (form2 nil form2?))
6615   (let ((bound (gensym "BOUND-"))
6616         (best (gensym "BEST-"))
6617         (objective (gensym "OBJECTIVE-")))
6618     `(let ((,bound nil)
6619            (,best nil)
6620            (,objective (variablize ,objective-form)))
6621        (attach-noticer!
6622         #'(lambda ()
6623             (if (and ,bound (<= (variable-upper-bound ,objective) ,bound)) (fail)))
6624         ,objective)
6625        (for-effects
6626          (let ((value ,form1))
6627            (global (setf ,bound (variable-upper-bound ,objective))
6628                    (setf ,best value))))
6629        (if ,bound (list ,best ,bound) ,(if form2? form2 '(fail))))))
6630
6631 (defun template-internal (template variables)
6632   (cond
6633     ((and (symbolp template) (char= #\? (aref (string template) 0)))
6634      (let ((binding (assoc template variables :test #'eq)))
6635        (if binding
6636            (values (cdr binding) variables)
6637            (let ((variable (make-variable template)))
6638              (values variable (cons (cons template variable) variables))))))
6639     ((consp template)
6640      (cl:multiple-value-bind (car-template car-variables)
6641          (template-internal (car template) variables)
6642        (cl:multiple-value-bind (cdr-template cdr-variables)
6643            (template-internal (cdr template) car-variables)
6644          (values (cons car-template cdr-template) cdr-variables))))
6645     (t (values template variables))))
6646
6647 (defun template (template)
6648   (template-internal (value-of template) '()))
6649
6650 (eval-when (:compile-toplevel :load-toplevel :execute)
6651   (setf *screamer?* nil))
6652
6653 (eval-when (:compile-toplevel :load-toplevel :execute)
6654   (pushnew :screamer *features* :test #'eq))
6655
6656 ;;; Tam V'Nishlam Shevah L'El Borei Olam