;;; -*- Mode: LISP; Package: (SCREAMER :USE CL :COLON-MODE :EXTERNAL); Base: 10; Syntax: Ansi-common-lisp -*- ;;; LaHaShem HaAretz U'Mloah ;;; Screamer ;;; A portable efficient implementation of nondeterministic CommonLisp ;;; Version 3.24 ;;; Copyright 1991 Massachusetts Institute of Technology. All rights reserved. ;;; Copyright 1992, 1993 University of Pennsylvania. All rights reserved. ;;; Copyright 1993, 1994, and 1995 University of Toronto. All rights reserved. ;;; Copyright 1996 Technion. All rights reserved. ;;; Copyright 1996 and 1997 University of Vermont. All rights reserved. ;;; Copyright 1997 NEC Research Institute, Inc. All rights reserved. ;;; Written by: ;;; Jeffrey Mark Siskind ;;; NEC Research Institute, Inc. ;;; 4 Independence Way ;;; Princeton NJ 08540 USA ;;; Qobi@research.nj.nec.com ;;; 609/951-2705 ;;; and: ;;; David Allen McAllester ;;; MIT Artificial Intelligence Laboratory ;;; 545 Technology Square Room NE43-412 ;;; Cambridge MA 02139 ;;; DAM@AI.MIT.EDU ;;; 617/253-6599 ;;; You are free to use, copy and distribute this software provided that: ;;; 1. You report *ALL* bugs to Bug-Screamer@AI.MIT.EDU whether or not you ;;; need them fixed. Include the version number (3.24) in the message. ;;; 2. You report *ALL* bugs that you fixed to Bug-Screamer@AI.MIT.EDU. ;;; Include the version number (3.24) in the message. ;;; 3. Every time you run Screamer on a machine or using a Lisp compiler not ;;; mentioned below, you send a message stating the new environment and the ;;; version number (3.24) to Bug-Screamer@AI.MIT.EDU. ;;; 4. You inform us that you obtained a copy of Screamer by sending a message ;;; to Info-Screamer-Request@AI.MIT.EDU to be put on the ;;; Info-Screamer@AI.MIT.EDU mailing list. ;;; Important notice: In this version of Screamer, if Screamer is already ;;; loaded and you wish to recompile the entire file, the recompilation will ;;; proceed much faster if you first do: ;;; (CLRHASH SCREAMER::*FUNCTION-RECORD-TABLE*) ;;; Machines Supported or Not Supported ;;; Please send mail to Bug-Screamer@AI.MIT.EDU whenever you discover a new ;;; machine or CommonLisp implementation that either DOES or DOESN'T run ;;; Screamer correctly so I can update this list. ;;; 1. Genera 8.1.1 and 8.3 on Symbolics 36xx and Ivory: ;;; No known bugs. ;;; Updates to 8.1.1 and 8.3 based on modifications graciously provided by ;;; Marty Hall of the Applied Physics Laboratory. ;;; 2. Lucid 4.0.2 and 4.1 on Sun SPARC, ;;; Lucid 4.1 on SGI MIPS, ;;; Lucid 4.1 on HP PA, ;;; Lucid 4.1 on DEC MIPS, and ;;; Lucid 4.0.1 on IBM RS/6000: ;;; No known bugs except the following. Lucid has a royal screw however. ;;; Macros like INCF and PUSH expand directly into internal structure ;;; updating operations when called on generalized variables. The ;;; expansion does not go indirectly through SETF so that (LOCAL (INCF X)) ;;; will compile into a global increment rather than a local increment. ;;; This is technically allowed by the CommonLisp spec but shouldn't be. ;;; For greater efficiency, you should load the patch mbmfe.sbin into ;;; 4.0.2/SPARC. This optional patch fixes a bug which prevents tail ;;; recursion optimization. This patch should not be loaded into 4.1/SPARC ;;; since 4.1/SPARC already contains this patch. Lucid 4.1/HP requires that ;;; the patch file bug-5511.hbin be loaded. Lucid 4.1/DEC requires that ;;; the patch file bug-5511.mbin be loaded. ;;; 3. MCL 2.0 and 2.0p2 on Apple Macintosh: ;;; No known bugs except that 2.0 needs not-so-trivial-patch.fasl to be ;;; loaded. This patch should not be loaded into 2.0p2 since 2.0p2 already ;;; contains this patch. ;;; This port based on an earlier port graciously provided by Volker ;;; Haarslev of the Computer Science Department, University of Hamburg. ;;; 4. Harlequin 3.0.3+ on Sun SPARC: ;;; No known bugs. ;;; Assitance for this port graciously provided by Marty Hall of the ;;; Applied Physics Laboratory. ;;; 5. Allegro 4.1 and 4.2 on Sun SPARC and SGI MIPS, ;;; Allegro 4.1 on DEC MIPS, and ;;; Allegro 4.3 on Linux/x86: ;;; No known bugs. ;;; Assistance for this port graciously provided by Brad Miller of the ;;; Computer Science Department, University of Rochester. ;;; 6. Poplog 14.2 on Sun SPARC: ;;; No known bugs. ;;; This port based on an earlier port graciously provided by Aaron Sloman ;;; of the Computer Science Department, University of Birmingham. ;;; 7. AKCL 1.605 and 1.615 on Sun SPARC: ;;; No known bugs. ;;; 8. CMU Common Lisp 17b on Sun SPARC: ;;; No known bugs. ;;; TTMTTD ;;; 1. Manual. ;;; 2. Should have way of having a stream of values. ;;; 3. Kashket's constraint additions Fall90-158. ;;; 4. Compress trail after repeated LOCAL SETF/SETQ to same variable ;;; 5. LOCAL SETF/SETQ on symbol can use special variable binding stack ;;; instead of unwind-protect. ;;; 6. (F (G (H (EITHER X Y)))) where F, G and H are deterministic can ;;; CPS-CONVERT to (FUNCALL #'(LAMBDA (Z) (F (G (H Z)))) (EITHER X Y)). ;;; 7. Should give warning when it recompiles functions due to changing ;;; determinism status. ;;; 8. =V V and >=V should do congruence/monotone closure. ;;; 9. =V should propagate domains. ;;; 10. BEST-VALUE ;;; 11. Should cache VARIABLE-LOWER-BOUND/VARIABLE-UPPER-BOUND for domain ;;; variables. ;;; 12. Faster version of BIND! which doesn't cons. ;;; 13. Get DIAGNOSIS and MONTAGUE to work. ;;; 14. Get GROW-UP and NONLINEAR examples to work. ;;; 15. FUNCALLV and APPLYV need to assert the domains of the variable that ;;; they return. ;;; 16. Check that +V, -V, *V, /V, MINV and MAXV work and do the right thing ;;; with type propagation. ;;; 17. Check that PROPAGATE does the right thing with bounds of integers. ;;; 18. MEMBERV and derivatives should support vectors. ;;; 19. Backtracking out of INTEGER-BETWEENV and the like will yield an ;;; unconstrained variable since the constraints are asserted locally. ;;; Bugs to fix ;;; 1. LOCAL SETF does the wrong thing with GETHASH. ;;; 2. LOCAL (SETF/SETQ X e) will signal an error if X is unbound because it ;;; needs to trail the previous value of X and it has none. ;;; 3. Deterministic/nondeterministic LOCAL SETF/SETQ undone out of order. ;;; 4. Changing determinism status can cause code from a different file to ;;; be included causing wierd behavior. ;;; 5. Will signal an obscure error if FAIL is called in a deterministic ;;; context which is not nested in a choice point. ;;; 6. May loop when expressions contain circular lists. ;;; 7. APPLY-NONDETERMINISTIC conses. ;;; Limitations ;;; 1. Does not handle SETF methods with multiple values for LOCAL SETF. ;;; 2. If you do a (SETF (SYMBOL-FUNCTION 'FOO) ...) to a nondeterministic ;;; function you will lose when you attempt to evaluate (FOO ...). ;;; 3. If you do a (SETF (SYMBOL-FUNCTION 'FOO) ...) to a deterministic ;;; function when FOO was previously defined as a nondeterministic ;;; function you will lose when you attempt to evaluate (FOO ...). ;;; 4. The function record table will not work if we ever support FLET and ;;; LABELS and in particular, if we ever support FLET and LABELS of ;;; nondeterministic functions. ;;; 5. There is no way to force Screamer into compiling a deterministic ;;; function as a nondeterministic one. A wizard might want to do this to ;;; take advantage of the fact that a LOCAL SETF/SETQ in a nondeterministic ;;; function does not cons up closures. ;;; 6. Doesn't handle most CommonLisp special forms. ;;; Currently handle: ;;; BLOCK ;;; FUNCTION ;;; GO ;;; IF ;;; LET ;;; LET* ;;; MULTIPLE-VALUE-CALL ;;; MULTIPLE-VALUE-PROG1 ;;; PROGN ;;; QUOTE ;;; RETURN-FROM ;;; SETQ ;;; TAGBODY ;;; THE ;;; Probably will never handle: ;;; CATCH ;;; DECLARE ;;; EVAL-WHEN ;;; FLET ;;; LABELS ;;; MACROLET ;;; PROGV ;;; THROW ;;; UNWIND-PROTECT ;;; CLtL1 obsolete: ;;; COMPILER-LET ;;; CLtL2 additions: ;;; GENERIC-FLET ;;; GENERIC-LABELS ;;; LOAD-TIME-VALUE ;;; LOCALLY ;;; WITH-ADDED-METHODS ;;; SYMBOL-MACROLET ;;; Change Log ;;; W25Sep91 Qobi ;;; Changed the who calls database code to fix the bug whereby after loading ;;; the definition of a nondeterministic function FOO ;;; (ALL-VALUES (FOO ...)) would not work because FOO would not be recognized ;;; as nondeterministic until at least one DEFUN was expanded. In the process ;;; changed the OLD/NEW-DETERMINISTIC? terminology. ;;; W25Sep91 Qobi ;;; Fixed the bug whereby a function FOO which referenced #'BAR or ;;; #'(LAMBDA (...) ... (BAR ...) ...) would not be recompiled when the ;;; deterministic status of BAR changed. This involved a polarity switch on ;;; NESTED?. This also fixed the bug whereby STATIC-ORDERING and REORDER were ;;; incorrectly classified as nondeterministic. ;;; W25Sep91 Qobi ;;; Made SOLUTION walk its argument. ;;; W25Sep91 Qobi ;;; Separated USE-PACKAGE from IN-PACKAGE. ;;; W25Sep91 Qobi ;;; Added *SCREAMER-VERSION*. Set it to 2.1 ;;; H28Sep91 Qobi ;;; Added FLIP. Changed EITHER to a macro which expands into FLIP. Expunged ;;; from the code walker, any notion of EITHER being a special form. Removed ;;; the optimization that inline expanded calls to FAIL. Version 2.2. ;;; W2Oct91 Qobi ;;; Fixed bug in VARIABLES-IN. Version 2.3. ;;; R3Oct91 Qobi ;;; Added COUNT-FAILURES. Version 2.4. ;;; S13Oct91 Qobi ;;; Added :SCREAMER to *FEATURES* at the request of CGDEMARC. Version 2.5. ;;; F25Oct91 Qobi ;;; Fixed bug with FUTURE-COMMON-LISP on Symbolics with SETF, FUNCTION and ;;; LAMBDA. Version 2.6. ;;; M4Nov91 Qobi ;;; Fixed INTEGER-BETWEEN to work correctly with noninteger arguments. ;;; Removed SUBST form of Beta-conversion. Version 2.7. ;;; S1Dec91 Qobi ;;; Changed -NOT- to -NOTV- naming convention to be consistent. ;;; Changed INTEGERV to INTEGERPV, REALV to REALPV, NUMBERV to NUMBERPV and ;;; BOOLEANV to BOOLEANPV to be consistent. ;;; Can now walk EVAL-WHEN, FLET, LABELS, PROGV and THE. ;;; Can now CPS convert THE. Also added types to CPS conversion. ;;; Added WHEN-FAILING and rewrote COUNT-FAILURES. ;;; Added POSSIBLY? ;;; Added LOCAL-I/O ;;; Version 2.8. ;;; T11Feb92 Qobi ;;; Fixed PROCESS-SUBFORMS to fix bug whereby it didn't correctly walk ;;; EVAL-WHEN, FLET and LABELS. ;;; Fixed DEFUN FUNCTION-NAME to support RETURN-FROM FUNCTION-NAME in its ;;; body for both deterministic and nondeterministic cases. ;;; Fixed PEAL-OFF-DOCUMENTATION-STRING-AND-DECLARATIONS to not consider a ;;; lone string in the body as a documentation string. ;;; Version 2.9. ;;; M16Mar92 Qobi ;;; Removed redundant "Improper form" error. ;;; Changed all ''NIL and 'NIL to NIL. ;;; Reorganized FORM-TYPEs. ;;; Changed CONSTANT to QUOTE. ;;; Aesthetic capitalization of ALLOW-OTHER-KEYS. ;;; Renamed BLOCK to SEGMENT to be consistent. ;;; Added SELF-EVALUATING? and QUOTIFY and changed processing of QUOTE and ;;; VARIABLE. ;;; Enforce non-NIL function names. ;;; Added SCREAMER? argument to WALK. ;;; Allow FLET/LABELS to bind SETF functions. ;;; Version 2.10. ;;; T17Mar92 Qobi ;;; Built new mechanism to determine when to recompile functions due to ;;; changing determinism status to solve a long standing bug. ;;; PERFORM-SUBSTITUTIONS had a call to itself rather than a FUNCALL to ;;; FUNCTION. ;;; Removed redundant check for NEEDS-SUBSTITUTION? in CPS-CONVERT since that ;;; was checked by PERFORM-SUBSTITUTION anyway. ;;; Made the check performed by NEEDS-SUBSTITUTION? tighter so that fewer ;;; needless macro expansions take place for deterministic DEFUNs. ;;; Version 2.11. ;;; M6Apr92, T7Apr92, R9Apr92, M13Apr92 Qobi ;;; Changed DEFUN-COMPILE-TIME to compile functions. ;;; Fixed bug in CPS-CONVERT introduced by QUOTE change. ;;; Fixed polarity bug of FUNCTION-LAMBDA in NEEDS-SUBSTITUTION? ;;; Got rid of POSITIVE/NEGATIVE-INFINITY and (OR RATIONAL FLOAT) bogosity. ;;; Changed rules to use (NOT (VARIABLE? X)) instead of prior bogosity. ;;; Fixed fence-post error in trail unwinding. ;;; Added UNWIND-TRAIL. ;;; Added COST-FUNCTION and PREDICATE parameters to REORDER ;;; Fixed bug in DOMAIN-SIZE. ;;; Added RANGE-SIZE. ;;; Moved consistency checks to ends of rules to fix a bug. ;;; Removed unsound type propagation from rules relating to Gaussian integers. ;;; Changed naming conventions: MIN->LOWER-BOUND, MAX->UPPER-BOUND. ;;; Added fuzzy comparisons to bounds restrictions. ;;; Added *MINIMUM-SHRINK-RATIO*. ;;; Moved type consistency checks in ASSERT!-INTEGERPV etc. to beginning. ;;; Removed all fuzziness except for RANGE-SIZE. Fuzzy noninteger-real ;;; variables no longer dereference. REORDER cost function must now return ;;; non-NIL value for a variable to be forced. ;;; Fixed =-RULE to `support' complex numbers. ;;; Fixed CHECK-MEMBERV-RESTRICTION to check for groundness rather than ;;; variables. ;;; Fixed RESTRICT-UPPER/LOWER-BOUND! and ASSERT!-INTEGERPV to have integer ;;; bounds for integer variables fixing (INTEGER-BETWEENV 2.1 2.2) problem. ;;; Added RESTRICT-BOUNDS! ;;; Differentiated up versus down rules. ;;; Version 2.12. ;;; R30Apr92 Qobi ;;; Added NECESSARILY? and FOR-EFFECTS. ;;; Changed MAP-VALUES to accept multiple forms. ;;; Changed PRINT-VALUES and ALL-VALUES to use new version of MAP-VALUES. ;;; Changed all &BODY BODY to &BODY FORMS. ;;; Version 2.13 ;;; S24May92 Qobi ;;; Changed failure strategy for INTEGER-BETWEEN and MEMBER-OF. ;;; Removed (DECLARE (IGNORE FORM)) from NEEDS-SUBSTITUTION?. ;;; Removed MAP-VALUES and changed all callers to use FOR-EFFECTS. ;;; Added AN-INTEGER, INTEGER-ABOVE, INTEGER-BELOW, A-REALV and AN-INTEGERV. ;;; Changed LINEAR-FORCE to no longer require that an integer variable have ;;; bounds. ;;; Fixed CPS conversion of TAGBODY so that CPS converted code always ;;; evaluates to NIL. ;;; Redid dependency calculations yet again to fix a latent bug. ;;; Removed error messages so that now can RETURN-FROM or GO to deterministic ;;; code from nondeterministic code wrapped in a FOR-EFFECTS but not in a ;;; DEFUN. ;;; Version 2.14 ;;; T26May92 Qobi ;;; Fixed a bug in the redone dependency calculations. ;;; Version 2.15 ;;; R28May92 Qobi ;;; Fixed a bug in CHECK-MEMBERV-RESTRICTION that prevented BIND! to a ;;; variable. Wrapped FORMS in PROGN in ALL-VALUES and PRINT-VALUES to fix a ;;; bug introduced by the elimination of MAP-VALUES. ;;; Version 2.16 ;;; S14Jun92 Qobi ;;; Redid fix for CHECK-MEMBERV-RESTRICTION. Fixed a bug in dependency ;;; calculations so that mutually recursive nondeterministic functions can ;;; become deterministic. Also fixed bug so that macroexpand without compile ;;; doesn't cache definition. Redid PRINT-VARIABLE. Changed NON- to NON. ;;; Fixed bug in EQUALV. Versions of KNOWN?-TRUE-INTERNAL and ;;; KNOWN?-FALSE-INTERNAL without ASSERT!-BOOLEANPV. Type noticers. ;;; Fixed bug in RESTRICT-BOUNDS!. Fixed +V2 -V2 *V2 /V2 MINV2 MAXV2 ;;; ASSERT!-=V2 ASSERT!-<=V2 ASSERT!- 0 to ZEROP, MINUSP ;;; and PLUSP. Changed INT-CHAR to CODE-CHAR. Changed /-RULE to not divide by ;;; zero. Also *-RULE-UP/DOWN now just FAIL on divide by zero. ;;; Version 3.3 ;;; W26Aug92 Qobi ;;; Changed references to COMMON-LISP and COMMON-LISP-USER to CL and CL-USER. ;;; Added DEFINE-SCREAMER-PACKAGE and modified definition of SCREAMER-USER to ;;; use it. All calls to GET-SETF-METHOD and MACRO-FUNCTION now pass ;;; ENVIRONMENT since GENERA 8.1, Lucid 4.0.2 and MCL 2.0 all support this ;;; argument. Added Kludge to support Lucid 4.0.2 without CLIM 1.1 loaded. ;;; Added compile-time switch option whereby variables can be represented ;;; either using DEFSTRUCT or using DEFCLASS. Changed FUTURE-COMMON-LISP to ;;; LISP since now using Ansi-common-lisp syntax for Symbolics. ;;; Version 3.4 ;;; F11Sep92 Qobi ;;; Implemented the missing cases of BCP from ANDV and ORV. Changed ;;; VALUE-OF as per suggestions of Volker Haarslev. Removed check whether ;;; *QUERY-IO* was same as *TERMINAL-IO* from Y-OR-N-P since *QUERY-IO* is ;;; usually a synonym stream and Lucid doesn't implement ;;; SYNONYM-STREAM-SYMBOL and even if it did, there would be no way to ;;; determine whether or not a steam is a a synonym stream. ;;; Version 3.5 ;;; T27Oct92 Qobi ;;; ATTACH-NOTICER! now runs it. Load extended LOOP macro for MCL since ;;; regular MCL LOOP expands into a MACROLET which WALK can't handle. ;;; Undid change which turned LOOP into TAGBODY. Don't trail unnested LOCAL ;;; SETF and LOCAL-OUTPUT. Special case BOOLEANS. Fixed bug whereby ANDV ;;; didn't return NIL when one argument was known to be NIL and ORV didn't ;;; return T when one argument was known to be T. Added ASSERT!-ORV and ;;; ASSERT!-NOTV-ANDV optimizations. Fixed a really obscure bug in ;;; PERFORM-SUBSTITUTIONS where it didn't perform substitutions on a ;;; RETURN-FROM. ;;; Version 3.6 ;;; W3Nov92 Qobi ;;; Fixed bug in DETERMINE-WHETHER-CALLERS-ARE-DETERMINISTIC. Fixed the fix ;;; to the obscure bug in PERFORM-SUBSTITUTIONS. Changed the call to ;;; CPS-CONVERT inside CPS-CONVERT-RETURN-FROM to pass (FOURTH TAG) as VALUE? ;;; to fix an obscure bug due to John Eric Fosler. ;;; Version 3.7 ;;; R12Nov92 Qobi ;;; More efficient ANDV, ORV, ASSERT!-NOTV-ANDV and ASSERT!-ORV. Added ;;; COUNT-TRUES and COUNT-TRUESV. Fixed bug in TRANSFORM-ASSERT!. Added ;;; INTERNAL versions of ANDV, ORV, ASSERT!-NOTV-ANDV, ASSERT!-ORV, ;;; COUNT-TRUES and COUNT-TRUESV. Fixed bug in FUNCALLV and APPLYV. Fixed ;;; efficiency bug in CPS-CONVERT-CALL. Fixed bug in RESTRICT-INTEGER!. ;;; Version 3.8 ;;; T22Dec92--R25Feb93 Qobi ;;; Exported REAL, REALP, BOOLEAN and BOOLEANP. Added support for partial ;;; evaluator. T is now SELF-EVALUATING. Fixed bug in NEEDS-SUBSTITUTION? ;;; so that NESTED? is T. Fixed CACHE-DEFINITION. Added #||# to IN-PACKAGE. ;;; Added EVAL-WHEN to REQUIRE :LOOP for MCL. Fixed bug in RESTRICT-VALUE!. ;;; Version 3.9 ;;; M15Mar93 Qobi ;;; Changed meaning of POLARITY? in KNOWN?-CONSTRAINT, PROPAGATE, and ;;; ASSERT!-CONSTRAINT so that non-NIL result of FUNCALLV or APPLYV is ;;; considered to satisfy constraint. ;;; Version 3.10 ;;; S9May93--S11Jul93 Qobi ;;; Added initial values for LAMBDA-LIST, BODY, ENVIRONMENT, CALLEES, and ;;; OLD-DETERMINISTIC? of FUNCTION-RECORD to allow to run under Genera 8.1.1. ;;; Changed WALK of IF to support Genera 8.3. Conditionalized ;;; SPECIAL-OPERATOR-P and GET-SETF-EXPANSION to support both CLtL2 and dpANS. ;;; CACHE-DEFINITION and friends no longer save ENVIRONMENT. Got rid of code ;;; which saved environments in FUNCTION-RECORD in CACHE-ENVIRONMENT and got ;;; rid of COPY-LIST of environments in DEFUN since that was not portable. ;;; Added #-POPLOG ENVIRONMENT to calls to GET-SETF-METHOD and MACRO-FUNCTION. ;;; Added some other conditionalization to support Poplog. Walker ;;; conditionalization for COND now just used for Explorer and not Allegro. ;;; Added wraps around MACRO-FUNCTION to support Allegro. Added support for ;;; nondeterministic functions that return multiple values. Added support for ;;; AKCL. Fixed efficiency bug in ASSERT!-CONSTRAINT. Fixed error messages ;;; for FUNCALLV/APPLYV. FUNCALLV/APPLYV now return ground value when ;;; manifest. Added arc consistency. DEFUN now returns function name. ;;; Completely obliterated all traces of FUNCTION-RECORD-ENVIRONMENT and ;;; commented all cases where current rather than saved environment is used. ;;; Various machinations to get Screamer to run under Harlequin, Allegro, MCL, ;;; and AKCL. Fixed bugs in ASSERT!-MEMBERV-INTERNAL, ASSERT!-MEMBERV, ;;; ASSERT!-NOTV-MEMBERV-INTERNAL, and ASSERT!-NOTV-MEMBERV. FUNCALLV and ;;; APPLYV now propagate to Z when all arguments become bound. ;;; Version 3.11 ;;; S12Jul93 Qobi ;;; To consolidate version skew on version 3.11. ;;; Version 3.12 ;;; T20Jul93 Qobi ;;; Fixed bug in -V2 (i.e. (-V2 0 )) by removing bogus special case. ;;; Version 3.13 ;;; T27Jul93 Qobi ;;; Since ATTACH-NOTICER! now runs the noticer after attaching it removed the ;;; cases where the noticers were explicitly run by lifted functions. ;;; Version 3.14 ;;; W22Sep93 Qobi ;;; Iterate no longer exports FINISH under AKCL since it conflicts with PCL. ;;; TERMINATE is a synonym anyway. ;;; Version 3.15 ;;; T28Sep93-M4Oct93 Qobi ;;; Ported to CMU CommonLisp 17b. This change necesitated converting the ;;; LOOPs in Y-OR-N-P, UNWIND-TRAIL, VALUE-OF, VARIABLIZE, and ;;; CHOICE-POINT-INTERNAL into TAGBODY/GO combintations since CMU CommonLisp ;;; expands LOOP into MACROLET. Changed POSSIBLY-BETA-REDUCE-FUNCALL to again ;;; do SUBST optimization. Changed CPS-CONVERT-BLOCK, CPS-CONVERT-IF, ;;; CPS-CONVERT-TAGBODY, and CPS-CONVERT-CALL to use ;;; POSSIBLY-BETA-REDUCE-FUNCALL to encapsulate the *DYNAMIC-EXTENT?* ;;; interface and fix some efficiency bugs. Even Symbolics port now uses ;;; MAGIC. Set *DYNAMIC-EXTENT?* to NIL for Symbolics. Added patch files for ;;; Lucid bug-5511. *TRAIL* now has an initial size of 4096 and a growth rate ;;; of 1024 so that we don't spend much time growing it on implementations ;;; where that is inefficient. ;;; Version 3.16 ;;; T26Oct93 Qobi ;;; PERFORM-SUBSTITUTIONS didn't handle FOR-EFFECTS which caused a bug when ;;; a deterministic DEFUN contained a FOR-EFFECTS which had a nested LOCAL ;;; side effect. ;;; Version 3.17 ;;; M22Nov93 Qobi ;;; Fixed bug in CPS-CONVERT-RETURN-FROM that surfaced due to the previous ;;; bug fix. ;;; Version 3.18 ;;; M27Dec93 Qobi ;;; Fixed bug in WHEN-FAILING so that it now nests. ;;; Version 3.19 ;;; T8Mar94 Qobi ;;; Fixes to make work under Allegro 4.2 and Genera 8.3. ;;; Future work includes integrating the Allegro\PC and CLISP mods, ;;; fixing the conditionalization on the DEFTYPE BOOLEAN, and checking that ;;; the new official DEFTYPE BOOLEAN corresponds to what Screamer expects. ;;; Version 3.20 ;;; T24May94 Qobi ;;; Added comment stating that Screamer runs under CMU CommonLisp. ;;; Version 3.21 ;;; R26May94 Qobi ;;; Fixed bug renaming allegro-4.1 to allegro-v4.1. ;;; Version 3.22 ;;; R25Sep97 Qobi ;;; Changed #-allegro-v4.2 to #-(or allegro-v4.2 x3j13). ;;; Fixed bug in APPLY-NONDETERMINISTIC-NONDETERMINISTIC ;;; Version 3.23 ;;; M7Sep98 Qobi ;;; Changed (< (VARIABLE-LOWER-BOUND Y) (VARIABLE-UPPER-BOUND Y)) to ;;; (<= (VARIABLE-LOWER-BOUND Y) (VARIABLE-UPPER-BOUND Y)) in SHARE! as per ;;; swhite@csd.abdn.ac.uk ;;; Version 3.24 ;;; F11Jul03 Kevin Rosenberg ;;; Add gensyms to avoid variable capture in a number of macros ;;; Version 3.24.1 ;;; A kludge to get Screamer to run under Lucid 4.0.2 without CLIM 1.1 loaded ;;; or Poplog or AKCL. #+(and lucid (not lcl4.1)) (in-package :user) #-(or (and lucid (not lcl4.1)) poplog akcl) (in-package :cl-user) ;;; A kludge to get Screamer to run under Lucid 4.0.2 without CLIM 1.1 loaded #+lucid (eval-when (compile load eval) (unless (find-package :cl) (let* ((lisp-package (find-package :lisp)) (lisp-package-name (package-name lisp-package)) (lisp-package-nicknames (package-nicknames lisp-package)) (foo-package (gensym))) (rename-package lisp-package foo-package) (rename-package lisp-package lisp-package-name (list* :cl :common-lisp lisp-package-nicknames)))) (unless (find-package :cl-user) (let* ((user-package (find-package :user)) (user-package-name (package-name user-package)) (user-package-nicknames (package-nicknames user-package)) (foo-package (gensym))) (rename-package user-package foo-package) (rename-package user-package user-package-name (list* :cl-user :common-lisp-user user-package-nicknames))))) ;;; MCL needs the extended LOOP macro since the default one expands into ;;; MACROLET which WALK can't handle. #+mcl (eval-when (compile load eval) (require :loop)) ;;; note: This EVAL-WHEN shouldn't be necessary but it is due to a bug in ;;; Lucid. #-(or poplog akcl) (eval-when (compile load eval) (defpackage :screamer (:shadow :defun :multiple-value-bind :y-or-n-p :variable) (:use :cl #+lucid :lcl) (:export :either :fail :local :global :for-effects :multiple-value-call-nondeterministic :one-value :possibly? :necessarily? :all-values :ith-value :print-values :nondeterministic-function? :funcall-nondeterministic :apply-nondeterministic :unwind-trail :purge :unwedge-screamer :local-output :a-boolean :an-integer :an-integer-above :an-integer-below :an-integer-between :a-member-of :when-failing :count-failures :boolean :booleanp :make-variable :numberpv :realpv :integerpv :booleanpv :memberv :assert! :known? :decide :=v :v :>=v :/=v :a-booleanv :an-integerv :an-integer-abovev :an-integer-belowv :an-integer-betweenv :a-realv :a-real-abovev :a-real-belowv :a-real-betweenv :a-numberv :a-member-ofv :notv :andv :orv :count-trues :count-truesv :+v :-v :*v :/v :minv :maxv :funcallv :applyv :equalv :bound? :value-of :ground? :apply-substitution :linear-force :divide-and-conquer-force :static-ordering :domain-size :range-size :reorder :solution :best-value :template :define-screamer-package :*screamer-version* :*dynamic-extent?* :*iscream?* :*minimum-shrink-ratio* :*maximum-discretization-range* :*strategy*))) (in-package :screamer) #+(or poplog akcl) (shadow '(defun multiple-value-bind y-or-n-p variable)) #+(or poplog akcl) (export '(either fail local global for-effects multiple-value-call-nondeterministic one-value possibly? necessarily? all-values ith-value print-values nondeterministic-function? funcall-nondeterministic apply-nondeterministic unwind-trail purge unwedge-screamer local-output a-boolean an-integer an-integer-above an-integer-below an-integer-between a-member-of when-failing count-failures boolean booleanp make-variable numberpv realpv integerpv booleanpv memberv assert! known? decide =v v >=v /=v a-booleanv an-integerv an-integer-abovev an-integer-belowv an-integer-betweenv a-realv a-real-abovev a-real-belowv a-real-betweenv a-numberv a-member-ofv notv andv orv count-trues count-truesv +v -v *v /v minv maxv funcallv applyv equalv bound? value-of ground? apply-substitution linear-force divide-and-conquer-force static-ordering domain-size range-size reorder solution best-value template define-screamer-package *screamer-version* *dynamic-extent?* *iscream?* *minimum-shrink-ratio* *maximum-discretization-range* *strategy*)) #+(or poplog akcl) (use-package :lisp) ;;; A kludge to get Screamer to run under Poplog or AKCL #+(or poplog akcl) (eval-when (compile load eval) (unless (find-package :cl) (let* ((lisp-package (find-package :lisp)) (lisp-package-name (package-name lisp-package)) (lisp-package-nicknames (package-nicknames lisp-package)) (foo-package (gensym))) (rename-package lisp-package foo-package) (rename-package lisp-package lisp-package-name (list* :cl :common-lisp lisp-package-nicknames)))) (unless (find-package :cl-user) (let* ((user-package (find-package :user)) (user-package-name (package-name user-package)) (user-package-nicknames (package-nicknames user-package)) (foo-package (gensym))) (rename-package user-package foo-package) (rename-package user-package user-package-name (list* :cl-user :common-lisp-user user-package-nicknames))))) ;;; note: Need to remove conditional when Lucid, Poplog, and AKCL ;;; support CLtL2. #-(or lucid poplog akcl) (declaim (declaration magic)) #+(or lucid poplog akcl) (proclaim '(declaration magic)) #-(or poplog akcl) (defmacro define-screamer-package (defined-package-name &rest options) ;; note: This EVAL-WHEN shouldn't be necessary but it is due to a bug in ;; Lucid. `(eval-when (compile load eval) (defpackage ,defined-package-name ,@options (:shadowing-import-from :screamer :defun :multiple-value-bind :y-or-n-p) (:use :cl #+lucid :lcl :screamer)))) #-(or poplog akcl) (define-screamer-package :screamer-user) #+(or poplog akcl) (eval-when (load eval) (eval '(make-package :screamer-user :use '(:cl :screamer))) (eval '(shadowing-import '(defun multiple-value-bind y-or-n-p) :screamer-user))) (defmacro defstruct-compile-time (options &body items) `(eval-when (compile load eval) (defstruct ,options ,@items))) (defmacro defvar-compile-time (name &optional initial-value documentation) `(eval-when (compile load eval) (defvar ,name ,initial-value ,documentation))) (defmacro defun-compile-time (function-name lambda-list &body body) `(eval-when (compile load eval) (cl:defun ,function-name ,lambda-list ,@body) #-(or akcl harlequin-common-lisp clisp) (eval-when (compile) (compile ',function-name)))) ;;; Needed because Allegro has some bogosity whereby (MACRO-FUNCTION ) ;;; returns NIL during compile time when is a macro being defined for the ;;; first time in the file being compiled. (defmacro defmacro-compile-time (function-name lambda-list &body body) `(eval-when (compile load eval) (defmacro ,function-name ,lambda-list ,@body))) (defparameter *screamer-version* "3.24" "The version of Screamer which is loaded.") (defvar-compile-time *dynamic-extent?* #-(or poplog akcl symbolics) t #+(or poplog akcl symbolics) nil "T to enable the dynamic extent optimization.") (defvar *iscream?* nil "T if Screamer is running under ILisp/GNUEmacs with iscream.el loaded.") (defvar *nondeterministic?* nil "This must be globally NIL.") (defvar-compile-time *screamer?* nil "This must be NIL except when defining internal Screamer functions.") (defvar-compile-time *nondeterministic-context?* nil "This must be globally NIL.") (defvar-compile-time *local?* nil "This must be globally NIL.") (defvar-compile-time *block-tags* '() "This must be globally NIL.") (defvar-compile-time *tagbody-tags* '() "This must be globally NIL.") (defvar *trail* (make-array 4096 :adjustable t :fill-pointer 0) "The trail.") (defvar-compile-time *function-record-table* (make-hash-table :test #'equal) "The function record table.") (defvar-compile-time *ordered-lambda-list-keywords* '(&optional &rest &key &allow-other-keys &aux) "The allowed lambda list keywords in order.") (defmacro-compile-time choice-point-internal (form) ;; note: Is it really better to use VECTOR-PUSH-EXTEND than CONS for the ;; trail? `(catch 'fail (let ((*nondeterministic?* t)) (unwind-protect ,form (block nil (tagbody loop (if (= (fill-pointer *trail*) trail-pointer) (return)) (funcall (vector-pop *trail*)) ;; note: This is to allow the trail closures to be garbage ;; collected. (setf (aref *trail* (fill-pointer *trail*)) nil) (go loop))))))) (defmacro-compile-time choice-point-external (&rest forms) ;; note: Is it really better to use VECTOR-PUSH-EXTEND than CONS for the ;; trail? `(let ((trail-pointer (fill-pointer *trail*))) ,@forms)) (defmacro-compile-time choice-point (form) `(choice-point-external (choice-point-internal ,form))) (defstruct-compile-time function-record function-name (lambda-list nil) (body nil) (callees nil) (deterministic? t) (old-deterministic? nil) (screamer? *screamer?*)) (defstruct-compile-time (nondeterministic-function (:print-function print-nondeterministic-function) (:predicate nondeterministic-function?-internal)) function) (defun-compile-time screamer-error (header &rest args) (apply #'error (concatenate 'string header "~%There are eight types of nondeterministic contexts: the body of a~%~ function defined with DEFUN, the body of a call to the FOR-EFFECTS~%~ macro, the first argument of a call to the ONE-VALUE macro, the body of~%~ a call to the POSSIBLY? macro, the body of a call to the NECESSARILY?~%~ macro, the body of a call to the ALL-VALUES macro, the second argument~%~ of a call to the ITH-VALUE macro and the body of a call to the~%~ PRINT-VALUES macro. Note that, the default forms of &OPTIONAL and &KEY~%~ arguments and the initialization forms of &AUX variables, are always~%~ deterministic contexts even though they may appear inside a DEFUN.") args)) (defun-compile-time get-function-record (function-name) (let ((function-record (gethash function-name *function-record-table*))) (unless function-record (setf function-record (make-function-record :function-name function-name)) (setf (gethash function-name *function-record-table*) function-record)) function-record)) (defun-compile-time peal-off-documentation-string-and-declarations (body &optional documentation-string?) ;; note: This will need to be done as well for LOCALLY and MACROLET when we ;; eventually implement them. ;; needs work: This requires that the documentation string preceed all ;; declarations which needs to be fixed. (let (documentation-string declarations) (when (and documentation-string? (not (null body)) (not (null (rest body))) (stringp (first body))) (setf documentation-string (first body)) (setf body (rest body))) (loop (unless (and (not (null body)) (consp (first body)) (eq (first (first body)) 'declare)) (return)) (push (first body) declarations) (pop body)) (values body (reverse declarations) documentation-string))) (defun-compile-time self-evaluating? (thing) (and (not (consp thing)) (or (not (symbolp thing)) (null thing) (eq thing t) (eq (symbol-package thing) (symbol-package :x))))) (defun-compile-time quotify (thing) (if (self-evaluating? thing) thing `',thing)) (defun-compile-time lambda-expression? (form) (and (consp form) (or (eq (first form) 'lambda) #+symbolics (eq (first form) 'lisp:lambda)) (or (and (null (rest (last form))) (>= (length form) 2) (listp (second form))) (error "Invalid syntax for LAMBDA expression: ~S" form)))) (defun-compile-time valid-function-name? (function-name) (or (and (symbolp function-name) (not (null function-name))) (and (consp function-name) (or (eq (first function-name) 'setf) #+symbolics (eq (first function-name) 'lisp:setf)) (null (rest (last function-name))) (= (length function-name) 2) (symbolp (second function-name)) (not (null (second function-name)))))) (defun-compile-time check-function-name (function-name) (unless (valid-function-name? function-name) (error "Invalid function name: ~S" function-name))) (defun-compile-time every-other (list) (cond ((null list) list) ((null (rest list)) list) (t (cons (first list) (every-other (rest (rest list))))))) (defun-compile-time check-lambda-list-internal (lambda-list &optional mode) (cond ((null lambda-list)) ((member (first lambda-list) *ordered-lambda-list-keywords* :test #'eq) (check-lambda-list-internal (rest lambda-list) (first lambda-list))) (t (let ((parameter (first lambda-list))) (ecase mode ((nil) (unless (symbolp parameter) (error "Invalid parameter: ~S" parameter))) (&optional (unless (or (symbolp parameter) (and (consp parameter) (null (rest (last parameter))) (or (= (length parameter) 1) (= (length parameter) 2) (and (= (length parameter) 3) (symbolp (third parameter)))) (symbolp (first parameter)))) (error "Invalid &OPTIONAL parameter: ~S" parameter))) (&rest (unless (symbolp parameter) (error "Invalid &REST parameter: ~S" parameter))) (&key (unless (or (symbolp parameter) (and (consp parameter) (null (rest (last parameter))) (or (= (length parameter) 1) (= (length parameter) 2) (and (= (length parameter) 3) (symbolp (third parameter)))) (or (symbolp (first parameter)) (and (consp (first parameter)) (null (rest (last (first parameter)))) (= (length (first parameter)) 2) (symbolp (first (first parameter))) (symbolp (second (first parameter))))))) (error "Invalid &KEY parameter: ~S" parameter))) (&aux (unless (or (symbolp parameter) (and (consp parameter) (null (rest (last parameter))) (or (= (length parameter) 1) (= (length parameter) 2)) (symbolp (first parameter)))) (error "Invalid &AUX parameter: ~S" parameter))))) (check-lambda-list-internal (rest lambda-list) mode)))) (defun-compile-time check-lambda-list (lambda-list) (unless (null (rest (last lambda-list))) (error "Improper lambda-list: ~S" lambda-list)) (let ((rest (member '&rest lambda-list :test #'eq))) (if rest (let ((rest (rest rest))) (unless (not (member '&rest rest :test #'eq)) (error "&REST cannot appear more than once: ~S" lambda-list)) (unless (and (not (null rest)) (not (member (first rest) lambda-list-keywords :test #'eq)) (or (null (rest rest)) (member (first (rest rest)) lambda-list-keywords :test #'eq))) (error "&REST must be followed by exactly one variable: ~S" lambda-list))))) (let ((allow-other-keys (member '&allow-other-keys lambda-list :test #'eq))) (if allow-other-keys (unless (or (null (rest allow-other-keys)) (member (first (rest allow-other-keys)) lambda-list-keywords :test #'eq)) (error "&ALLOW-OTHER-KEYS must not be followed by a parameter: ~S" lambda-list)))) (let ((keywords (remove-if-not #'(lambda (argument) (member argument lambda-list-keywords :test #'eq)) lambda-list))) (unless (every #'(lambda (keyword) (member keyword *ordered-lambda-list-keywords* :test #'eq)) keywords) (error "Invalid lambda list keyword: ~S" lambda-list)) (unless (every #'(lambda (x y) (member y (member x *ordered-lambda-list-keywords* :test #'eq) :test #'eq)) keywords (rest keywords)) (error "Invalid order for lambda list keywords: ~S" lambda-list))) (check-lambda-list-internal lambda-list)) (defun-compile-time walk-lambda-list-reducing (map-function reduce-function screamer? partial? nested? lambda-list environment &optional mode) (cond ((null lambda-list) (funcall reduce-function)) ((member (first lambda-list) *ordered-lambda-list-keywords* :test #'eq) (walk-lambda-list-reducing map-function reduce-function screamer? partial? nested? (rest lambda-list) environment (first lambda-list))) (t (ecase mode ((nil &rest &allow-other-keys &aux) (walk-lambda-list-reducing map-function reduce-function screamer? partial? nested? (rest lambda-list) environment mode)) ((&optional &key) (if (and (consp (first lambda-list)) (consp (rest (first lambda-list)))) (funcall reduce-function (walk map-function reduce-function screamer? partial? nested? (second (first lambda-list)) environment) (walk-lambda-list-reducing map-function reduce-function screamer? partial? nested? (rest lambda-list) environment mode)) (walk-lambda-list-reducing map-function reduce-function screamer? partial? nested? (rest lambda-list) environment mode))))))) (defun-compile-time walk-lambda-list (map-function reduce-function screamer? partial? nested? lambda-list environment) (check-lambda-list lambda-list) (if reduce-function (funcall reduce-function (funcall map-function lambda-list 'lambda-list) (walk-lambda-list-reducing map-function reduce-function screamer? partial? nested? lambda-list environment)) (funcall map-function lambda-list 'lambda-list))) (defun-compile-time walk-block (map-function reduce-function screamer? partial? nested? form environment) (unless (null (rest (last form))) (error "Improper BLOCK: ~S" form)) (unless (>= (length form) 2) (error "BLOCK must have at least one argument, a NAME: ~S" form)) (unless (symbolp (second form)) (error "NAME must be a symbol: ~S" form)) (if reduce-function (funcall reduce-function (funcall map-function form 'block) (reduce reduce-function (mapcar #'(lambda (subform) (walk map-function reduce-function screamer? partial? nested? subform environment)) (rest (rest form))))) (funcall map-function form 'block))) (defun-compile-time walk-catch (map-function reduce-function screamer? partial? nested? form environment) (unless (null (rest (last form))) (error "Improper PROGN: ~S" form)) (unless (>= (length form) 2) (error "CATCH must have at least one argument, a TAG: ~S" form)) (if reduce-function (funcall reduce-function (funcall map-function form 'catch) (reduce reduce-function (mapcar #'(lambda (subform) (walk map-function reduce-function screamer? partial? nested? subform environment)) (rest form)))) (funcall map-function form 'catch))) (defun-compile-time walk-eval-when (map-function reduce-function screamer? partial? nested? form environment) (unless (null (rest (last form))) (error "Improper EVAL-WHEN: ~S" form)) (unless (>= (length form) 2) (error "EVAL-WHEN must have at least one argument: ~S" form)) (unless (listp (second form)) (error "First argument of EVAL-WHEN must be a list: ~S" form)) (unless (null (rest (last (second form)))) (error "Improper list of SITUATIONS: ~S" form)) (unless (every #'(lambda (situation) (member situation '(:compile-top-level :load-top-level :execute compile load evel) :test #'eq)) (second form)) (error "Invalid SITUATION: ~S" form)) (if (member :execute (second form) :test #'eq) (walk-progn map-function reduce-function screamer? partial? nested? `(progn ,@(rest (rest form))) environment) (funcall map-function nil 'quote))) (defun-compile-time walk-flet/labels (map-function reduce-function screamer? partial? nested? form environment form-type) (unless (null (rest (last form))) (error "Improper ~S: ~S" form-type form)) (unless (>= (length form) 2) (error "~S must have BINDINGS: ~S" form-type form)) (unless (and (listp (second form)) (null (rest (last (second form)))) (every #'(lambda (binding) (and (consp binding) (null (rest (last binding))) (>= (length binding) 2) (valid-function-name? (first binding)) (listp (second binding)))) (second form))) (error "Invalid BINDINGS for ~S: ~S" form-type form)) (if reduce-function (funcall reduce-function (funcall map-function form form-type) (if nested? (funcall reduce-function (reduce reduce-function (mapcar #'(lambda (binding) (funcall reduce-function (walk-lambda-list map-function reduce-function screamer? partial? nested? (second binding) environment) (mapcar #'(lambda (subform) (walk map-function reduce-function screamer? partial? nested? subform environment)) (peal-off-documentation-string-and-declarations (rest (rest binding)) t)))) (second form))) (reduce reduce-function (mapcar #'(lambda (subform) (walk map-function reduce-function screamer? partial? nested? subform environment)) (rest (rest form))))) (reduce reduce-function (mapcar #'(lambda (subform) (walk map-function reduce-function screamer? partial? nested? subform environment)) (rest (rest form)))))) (funcall map-function form form-type))) (defun-compile-time walk-function (map-function reduce-function screamer? partial? nested? form environment) (unless (null (rest (last form))) (error "Improper FUNCTION: ~S" form)) (unless (= (length form) 2) (error "FUNCTION must have one argument: ~S" form)) (cond ((lambda-expression? (second form)) (if (and reduce-function nested?) (funcall reduce-function (funcall map-function form 'function-lambda) (funcall reduce-function (walk-lambda-list map-function reduce-function screamer? partial? nested? (second (second form)) environment) (reduce reduce-function (mapcar #'(lambda (subform) (walk map-function reduce-function screamer? partial? nested? subform environment)) (peal-off-documentation-string-and-declarations (rest (rest (second form))) t))))) (funcall map-function form 'function-lambda))) ((valid-function-name? (second form)) (cond ((symbolp (second form)) (if (or (#+(not (or lucid ansi-90 ansi-cl allegro cmu)) special-form-p #+lucid lisp:special-form-p #+(or ansi-90 ansi-cl allegro cmu) special-operator-p (second form)) ;; note: Allegro has some braindamage in the way it treats ;; some macros as special forms and refuses to ;; provide a macro function for them. This ;; circumvents that problem. (let (#+allegro-v4.1 (sys:*macroexpand-for-compiler* nil)) ;; note: Poplog and AKCL only support CLtL1. (macro-function (second form) #-(or poplog akcl) environment))) (error "You can't reference the FUNCTION of a special form or~%~ macro: ~S" form)) (funcall map-function form 'function-symbol)) (t (funcall map-function form 'function-setf)))) (t (error "Invalid argument to FUNCTION: ~S" form)))) (defun-compile-time walk-go (map-function form) (unless (null (rest (last form))) (error "Improper GO: ~S" form)) (unless (= (length form) 2) (error "GO must have one argument: ~S" form)) (unless (or (symbolp (second form)) (integerp (second form))) (error "TAG of GO must be a symbol or integer: ~S" form)) (funcall map-function form 'go)) (defun-compile-time walk-if (map-function reduce-function screamer? partial? nested? form environment) (unless (null (rest (last form))) (error "Improper IF: ~S" form)) (unless (or (= (length form) 3) (= (length form) 4)) (error "IF must have two or three arguments: ~S" form)) (if reduce-function (if (= (length form) 4) (funcall reduce-function (funcall map-function form 'if) (funcall reduce-function (walk map-function reduce-function screamer? partial? nested? (second form) environment) (funcall reduce-function (walk map-function reduce-function screamer? partial? nested? (third form) environment) (walk map-function reduce-function screamer? partial? nested? (fourth form) environment)))) (funcall reduce-function (funcall map-function form 'if) (funcall reduce-function (walk map-function reduce-function screamer? partial? nested? (second form) environment) (walk map-function reduce-function screamer? partial? nested? (third form) environment)))) (funcall map-function form 'if))) (defun-compile-time walk-let/let* (map-function reduce-function screamer? partial? nested? form environment form-type) (unless (null (rest (last form))) (error "Improper ~S: ~S" form-type form)) (unless (>= (length form) 2) (error "~S must have BINDINGS: ~S" form-type form)) (unless (and (listp (second form)) (null (rest (last (second form)))) (every #'(lambda (binding) (or (symbolp binding) (and (consp binding) (null (rest (last binding))) (or (= (length binding) 1) (= (length binding) 2)) (symbolp (first binding))))) (second form))) (error "Invalid BINDINGS for ~S: ~S" form-type form)) (if reduce-function (funcall reduce-function (funcall map-function form form-type) (funcall reduce-function (reduce reduce-function (mapcar #'(lambda (binding) (walk map-function reduce-function screamer? partial? nested? (second binding) environment)) (remove-if-not #'(lambda (binding) (and (consp binding) (= (length binding) 2))) (second form)))) (reduce reduce-function (mapcar #'(lambda (subform) (walk map-function reduce-function screamer? partial? nested? subform environment)) (peal-off-documentation-string-and-declarations (rest (rest form))))))) (funcall map-function form form-type))) (defun-compile-time walk-multiple-value-call (map-function reduce-function screamer? partial? nested? form environment) (unless (null (rest (last form))) (error "Improper MULTIPLE-VALUE-CALL: ~S" form)) (unless (>= (length form) 2) (error "MULTIPLE-VALUE-CALL must have at least one argument, a FUNCTION: ~S" form)) (if reduce-function (funcall reduce-function (funcall map-function form 'multiple-value-call) (reduce reduce-function (mapcar #'(lambda (subform) (walk map-function reduce-function screamer? partial? nested? subform environment)) (rest form)))) (funcall map-function form 'multiple-value-call))) (defun-compile-time walk-multiple-value-prog1 (map-function reduce-function screamer? partial? nested? form environment) (unless (null (rest (last form))) (error "Improper MULTIPLE-VALUE-PROG1: ~S" form)) (unless (>= (length form) 2) (error "MULTIPLE-VALUE-PROG1 must have at least one argument, a FORM: ~S" form)) (if reduce-function (funcall reduce-function (funcall map-function form 'multiple-value-prog1) (reduce reduce-function (mapcar #'(lambda (subform) (walk map-function reduce-function screamer? partial? nested? subform environment)) (rest form)))) (funcall map-function form 'multiple-value-prog1))) (defun-compile-time walk-progn (map-function reduce-function screamer? partial? nested? form environment) (unless (null (rest (last form))) (error "Improper PROGN: ~S" form)) (if reduce-function (funcall reduce-function (funcall map-function form 'progn) (reduce reduce-function (mapcar #'(lambda (subform) (walk map-function reduce-function screamer? partial? nested? subform environment)) (rest form)))) (funcall map-function form 'progn))) (defun-compile-time walk-progv (map-function reduce-function screamer? partial? nested? form environment) (unless (null (rest (last form))) (error "Improper PROGV: ~S" form)) (unless (>= (length form) 3) (error "PROGV must have at least two arguments: ~S" form)) (if reduce-function (funcall reduce-function (funcall map-function form 'progv) (funcall reduce-function (funcall reduce-function (walk map-function reduce-function screamer? partial? nested? (second form) environment) (walk map-function reduce-function screamer? partial? nested? (third form) environment)) (reduce reduce-function (mapcar #'(lambda (subform) (walk map-function reduce-function screamer? partial? nested? subform environment)) (rest (rest (rest form))))))) (funcall map-function form 'progv))) (defun-compile-time walk-quote (map-function form) (unless (null (rest (last form))) (error "Improper QUOTE: ~S" form)) (unless (= (length form) 2) (error "QUOTE must have one argument: ~S" form)) (funcall map-function (second form) 'quote)) (defun-compile-time walk-return-from (map-function reduce-function screamer? partial? nested? form environment) (unless (null (rest (last form))) (error "Improper RETURN-FROM: ~S" form)) (unless (or (= (length form) 2) (= (length form) 3)) (error "RETURN-FROM must have one or two arguments,~%~ a NAME and an optional RESULT: ~S" form)) (unless (symbolp (second form)) (error "NAME must be a symbol: ~S" form)) (if reduce-function (funcall reduce-function (funcall map-function form 'return-from) (walk map-function reduce-function screamer? partial? nested? (if (= (length form) 3) (third form) nil) environment)) (funcall map-function form 'return-from))) (defun-compile-time walk-setq (map-function reduce-function screamer? partial? nested? form environment) (unless (null (rest (last form))) (error "Improper SETQ: ~S" form)) (unless (every #'symbolp (every-other (rest form))) (error "Invalid destination for SETQ: ~S" form)) (unless (evenp (length (rest form))) (error "Odd number of arguments to SETQ: ~S" form)) (if reduce-function (funcall reduce-function (funcall map-function form 'setq) (reduce reduce-function (mapcar #'(lambda (subform) (walk map-function reduce-function screamer? partial? nested? subform environment)) (every-other (rest (rest form)))))) (funcall map-function form 'setq))) (defun-compile-time walk-tagbody (map-function reduce-function screamer? partial? nested? form environment) (unless (null (rest (last form))) (error "Improper TAGBODY: ~S" form)) (unless (every #'(lambda (subform) (or (symbolp subform) (integerp subform) (listp subform))) (rest form)) (error "A subforms of a TAGBODY must be symbols, integers or lists: ~S" form)) (let ((tags (remove-if #'consp (rest form)))) (unless (= (length tags) (length (remove-duplicates tags))) (error "TAGBODY has duplicate TAGs: ~S" form))) (if reduce-function (funcall reduce-function (funcall map-function form 'tagbody) (reduce reduce-function (mapcar #'(lambda (subform) (walk map-function reduce-function screamer? partial? nested? subform environment)) (remove-if-not #'consp (rest form))))) (funcall map-function form 'tagbody))) (defun-compile-time walk-the (map-function reduce-function screamer? partial? nested? form environment) (unless (null (rest (last form))) (error "Improper THE: ~S" form)) (unless (= (length form) 3) (error "THE must have two arguments: ~S" form)) (if reduce-function (funcall reduce-function (walk map-function reduce-function screamer? partial? nested? (third form) environment) (funcall map-function form 'the)) (funcall map-function form 'the))) (defun-compile-time walk-throw (map-function reduce-function screamer? partial? nested? form environment) (unless (null (rest (last form))) (error "Improper THROW: ~S" form)) (unless (= (length form) 3) (error "THROW must have two arguments, a TAG and a RESULT: ~S" form)) (if reduce-function (funcall reduce-function (funcall map-function form 'throw) (funcall reduce-function (walk map-function reduce-function screamer? partial? nested? (second form) environment) (walk map-function reduce-function screamer? partial? nested? (third form) environment))) (funcall map-function form 'throw))) (defun-compile-time walk-unwind-protect (map-function reduce-function screamer? partial? nested? form environment) (unless (null (rest (last form))) (error "Improper UNWIND-PROTECT: ~S" form)) (unless (>= (length form) 2) (error "UNWIND-PROTECT must have at least one argument, a PROTECTED-FORM: ~S" form)) (if reduce-function (funcall reduce-function (funcall map-function form 'unwind-protect) (funcall reduce-function (walk map-function reduce-function screamer? partial? nested? (second form) environment) (reduce reduce-function (mapcar #'(lambda (subform) (walk map-function reduce-function screamer? partial? nested? subform environment)) (rest (rest form)))))) (funcall map-function form 'unwind-protect))) ;;; note: Symbolics needs this to handle DOTIMES. #+symbolics (defun-compile-time walk-invisible-references (map-function reduce-function screamer? partial? nested? form environment) (unless (null (rest (last form))) (error "Improper COMPILER:INVISIBLE-REFERENCES: ~S" form)) (unless (>= (length form) 2) (error "COMPILER:INVISIBLE-REFERENCES must have at least one argument,~%~ a list of VARIABLES: ~S" form)) (unless (and (listp (second form)) (every #'symbolp (second form))) (error "Invalid VARIABLE list: ~S" form)) (if reduce-function (funcall reduce-function (funcall map-function form 'compiler:invisible-references) (reduce reduce-function (mapcar #'(lambda (subform) (walk map-function reduce-function screamer? partial? nested? subform environment)) (rest (rest form))))) (funcall map-function form 'compiler:invisible-references))) (defun-compile-time walk-for-effects (map-function reduce-function screamer? partial? nested? form environment) (unless (null (rest (last form))) (error "Improper FOR-EFFECTS: ~S" form)) ;; note: We used to think that we should never walk the body of FOR-EFFECTS ;; as we thought that the walker would get confused on the code ;; generated by FOR-EFFECTS and that FOR-EFFECTS called ;; CPS-CONVERT-PROGN on its body and that CPS-CONVERT-PROGN did the ;; walk for us. But that was wrong since FORM-CALLEES also walks and ;; thus would miss functions called in the body of a FOR-EFFECTS. So now ;; we walk the body of a FOR-EFFECTS without macro-expanding it, but ;; only when NESTED? is true which is essentially only for FORM-CALLEES ;; since DETERMINISTIC? must not walk the body of FOR-EFFECTS or else ;; it will mistakingly report that that a FOR-EFFECTS form is ;; nondeterministic when its body is nondeterministic. (if (and reduce-function nested?) (funcall reduce-function (funcall map-function form 'for-effects) (reduce reduce-function (mapcar #'(lambda (subform) (walk map-function reduce-function screamer? partial? nested? subform environment)) (rest form)))) (funcall map-function form 'for-effects))) (defun-compile-time walk-setf (map-function reduce-function screamer? partial? nested? form environment) (unless (null (rest (last form))) (error "Improper SETF: ~S" form)) (unless (evenp (length (rest form))) (error "Odd number of arguments to SETF: ~S" form)) (if *local?* (if reduce-function (funcall reduce-function (funcall map-function form 'local-setf) (reduce reduce-function (mapcar #'(lambda (subform) (walk map-function reduce-function screamer? partial? nested? subform environment)) (every-other (rest (rest form)))))) (funcall map-function form 'local-setf)) (walk map-function reduce-function screamer? partial? nested? (let ((*macroexpand-hook* #'funcall)) (macroexpand-1 form environment)) environment))) (defun-compile-time walk-multiple-value-call-nondeterministic (map-function reduce-function screamer? partial? nested? form environment) (unless (null (rest (last form))) (error "Improper MULTIPLE-VALUE-CALL-NONDETERMINISTIC: ~S" form)) (unless (>= (length form) 2) (error "MULTIPLE-VALUE-CALL-NONDETERMINISTIC must have at least one ~ argument, a FUNCTION: ~S" form)) (if reduce-function (funcall reduce-function (funcall map-function form 'multiple-value-call-nondeterministic) (reduce reduce-function (mapcar #'(lambda (subform) (walk map-function reduce-function screamer? partial? nested? subform environment)) (rest form)))) (funcall map-function form 'multiple-value-call-nondeterministic))) (defun-compile-time walk-full (map-function form) (unless (null (rest (last form))) (error "Improper FULL: ~S" form)) (unless (= (length form) 2) (error "FULL must have exactly one argument, a FORM: ~S" form)) (funcall map-function form 'full)) (defun-compile-time walk-macro-call (map-function reduce-function screamer? partial? nested? form environment) (if reduce-function (funcall reduce-function (funcall map-function form 'macro-call) (walk map-function reduce-function screamer? partial? nested? (let ((*macroexpand-hook* #'funcall)) (macroexpand-1 form environment)) environment)) (walk map-function reduce-function screamer? partial? nested? (let ((*macroexpand-hook* #'funcall)) (macroexpand-1 form environment)) environment))) (defun-compile-time walk-function-call (map-function reduce-function screamer? partial? nested? form environment) (unless (null (rest (last form))) (error "Improper function call form: ~S" form)) (cond ((lambda-expression? (first form)) (if reduce-function (funcall reduce-function (funcall map-function form 'lambda-call) (funcall reduce-function (reduce reduce-function (mapcar #'(lambda (subform) (walk map-function reduce-function screamer? partial? nested? subform environment)) (rest form))) (funcall reduce-function (walk-lambda-list map-function reduce-function screamer? partial? nested? (second (first form)) environment) (reduce reduce-function (mapcar #'(lambda (subform) (walk map-function reduce-function screamer? partial? nested? subform environment)) (peal-off-documentation-string-and-declarations (rest (rest (first form))) t)))))) (funcall map-function form 'lambda-call))) ((valid-function-name? (first form)) (if (symbolp (first form)) (if reduce-function (funcall reduce-function (funcall map-function form 'symbol-call) (reduce reduce-function (mapcar #'(lambda (subform) (walk map-function reduce-function screamer? partial? nested? subform environment)) (rest form)))) (funcall map-function form 'symbol-call)) (if reduce-function (funcall reduce-function (funcall map-function form 'setf-call) (reduce reduce-function (mapcar #'(lambda (subform) (walk map-function reduce-function screamer? partial? nested? subform environment)) (rest form)))) (funcall map-function form 'setf-call)))) (t (error "CAR of form ~S is not a valid function" form)))) ;;; Possible FORM-TYPEs ;;; Other: ;;; LAMBDA-LIST VARIABLE ;;; Special forms: ;;; BLOCK CATCH EVAL-WHEN FLET FUNCTION-LAMBDA FUNCTION-SYMBOL FUNCTION-SETF ;;; GO IF LABELS LET LET* MULTIPLE-VALUE-CALL MULTIPLE-VALUE-PROG1 PROGN ;;; PROGV QUOTE RETURN-FROM SETQ TAGBODY THE THROW UNWIND-PROTECT ;;; Symbolics special forms: ;;; SYS:VARIABLE-LOCATION COMPILER:INVISIBLE-REFERENCES ;;; Screamer special forms: ;;; FOR-EFFECTS LOCAL-SETF ;;; Partial special forms: ;;; FULL ;;; Other: ;;; MACRO-CALL LAMBDA-CALL SYMBOL-CALL SETF-CALL (defun-compile-time walk (map-function reduce-function screamer? partial? nested? form environment) ;; needs work: Cannot walk MACROLET or special forms not in both CLtL1 and ;; CLtL2. (cond ((self-evaluating? form) (funcall map-function form 'quote)) ((symbolp form) (funcall map-function form 'variable)) ((eq (first form) 'block) (walk-block map-function reduce-function screamer? partial? nested? form environment)) ((eq (first form) 'catch) (walk-catch map-function reduce-function screamer? partial? nested? form environment)) ((eq (first form) 'eval-when) (walk-eval-when map-function reduce-function screamer? partial? nested? form environment)) ((eq (first form) 'flet) (walk-flet/labels map-function reduce-function screamer? partial? nested? form environment 'flet)) ((or (eq (first form) 'function) #+symbolics (eq (first form) 'lisp:function)) (walk-function map-function reduce-function screamer? partial? nested? form environment)) ((eq (first form) 'go) (walk-go map-function form)) ;; Change to support Genera 8.3 ((or (eq (first form) 'if) #+ansi-90 (eq (first form) 'lisp:if)) (walk-if map-function reduce-function screamer? partial? nested? form environment)) ((eq (first form) 'labels) (walk-flet/labels map-function reduce-function screamer? partial? nested? form environment 'labels)) ((eq (first form) 'let) (walk-let/let* map-function reduce-function screamer? partial? nested? form environment 'let)) ((eq (first form) 'let*) (walk-let/let* map-function reduce-function screamer? partial? nested? form environment 'let*)) ;; needs work: This is a temporary kludge to support MCL. ((and (eq (first form) 'locally) (null (fourth form))) (walk map-function reduce-function screamer? partial? nested? (third form) environment)) ((eq (first form) 'multiple-value-call) (walk-multiple-value-call map-function reduce-function screamer? partial? nested? form environment)) ((eq (first form) 'multiple-value-prog1) (walk-multiple-value-prog1 map-function reduce-function screamer? partial? nested? form environment)) ((eq (first form) 'progn) (walk-progn map-function reduce-function screamer? partial? nested? form environment)) ((eq (first form) 'progv) (walk-progv map-function reduce-function screamer? partial? nested? form environment)) ((eq (first form) 'quote) (walk-quote map-function form)) ((eq (first form) 'return-from) (walk-return-from map-function reduce-function screamer? partial? nested? form environment)) ((eq (first form) 'setq) (walk-setq map-function reduce-function screamer? partial? nested? form environment)) ((eq (first form) 'tagbody) (walk-tagbody map-function reduce-function screamer? partial? nested? form environment)) ((eq (first form) 'the) (walk-the map-function reduce-function screamer? partial? nested? form environment)) ((eq (first form) 'throw) (walk-throw map-function reduce-function screamer? partial? nested? form environment)) ((eq (first form) 'unwind-protect) (walk-unwind-protect map-function reduce-function screamer? partial? nested? form environment)) ;; note: Explorer has some braindamage and treats COND as a special form ;; and is unable to macroexpand it. #+explorer ((eq (first form) 'cond) (unless (null (rest (last form))) (error "Improper COND: ~S" form)) (unless (or (null (rest form)) (and (consp (rest form)) (consp (second form)))) (error "Improper COND clause: ~S" form)) (walk map-function reduce-function screamer? partial? nested? (if (null (rest form)) nil `(if ,(first (second form)) (progn ,@(rest (second form))) (cond ,@(rest (rest form))))) environment)) #+allegro-v4.1 ((eq (first form) 'multiple-value-list) (unless (null (rest (last form))) (error "Improper MULTIPLE-VALUE-LIST: ~S" form)) (unless (= (length form) 2) (error "MULTIPLE-VALUE-LIST must have one argument, a FORM: ~S" form)) (walk map-function reduce-function screamer? partial? nested? `(multiple-value-call #'list ,(second form)) environment)) ;; note: Symbolics needs this to handle LOOP COLLECT clauses. #+symbolics ((eq (first form) 'sys:variable-location) (unless (null (rest (last form))) (error "Improper SYS:VARIABLE-LOCATION: ~S" form)) (unless (= (length form) 2) (error "SYS:VARIABLE-LOCATION must have one argument, a VAR: ~S" form)) (funcall map-function form 'sys:variable-location)) ;; note: Symbolics needs this to handle DOTIMES. #+symbolics ((eq (first form) 'compiler:invisible-references) (walk-invisible-references map-function reduce-function screamer? partial? nested? form environment)) ((and screamer? (eq (first form) 'for-effects)) (walk-for-effects map-function reduce-function screamer? partial? nested? form environment)) ((and screamer? (or (eq (first form) 'setf) #+symbolics (eq (first form) 'lisp:setf))) (walk-setf map-function reduce-function screamer? partial? nested? form environment)) ((and screamer? (eq (first form) 'local)) (let ((*local?* t)) (walk-progn map-function reduce-function screamer? partial? nested? form environment))) ((and screamer? (eq (first form) 'global)) (let ((*local?* nil)) (walk-progn map-function reduce-function screamer? partial? nested? form environment))) ((and screamer? (eq (first form) 'multiple-value-call-nondeterministic)) (walk-multiple-value-call-nondeterministic map-function reduce-function screamer? partial? nested? form environment)) ((and partial? (eq (first form) 'full)) (walk-full map-function form)) ((and (symbolp (first form)) ;; note: Allegro has some braindamage in the way it treats some ;; macros as special forms and refuses to provide a macro ;; function for them. This circumvents that problem. (let (#+allegro-v4.1 (sys:*macroexpand-for-compiler* nil)) ;; note: Poplog and AKCL only support CLtL1. (macro-function (first form) #-(or poplog akcl) environment))) (walk-macro-call map-function reduce-function screamer? partial? nested? form environment)) ((and (symbolp (first form)) (#+(not (or lucid ansi-90 ansi-cl allegro cmu)) special-form-p #+lucid lisp:special-form-p #+(or ansi-90 ansi-cl allegro cmu) special-operator-p (first form))) (error "Cannot (currently) handle the special form ~S" (first form))) (t (walk-function-call map-function reduce-function screamer? partial? nested? form environment)))) (defun-compile-time process-subforms (function form form-type environment) (case form-type (lambda-list (error "This shouldn't happen")) ((variable go) form) ;; note: Symbolics needs this to handle DOTIMES. ((eval-when #+symbolics compiler:invisible-references) (cons (first form) (cons (second form) (mapcar #'(lambda (subform) (funcall function subform environment)) (rest (rest form)))))) ((flet labels) `(,(first form) ,(mapcar #'(lambda (binding) (cl:multiple-value-bind (body declarations documentation-string) (peal-off-documentation-string-and-declarations (rest (rest binding)) t) `(,(first binding) ;; needs work: To process subforms of lambda list. ,(second binding) ,@(if documentation-string (list documentation-string)) ,@declarations ,@(mapcar #'(lambda (subform) (funcall function subform environment)) body)))) (second form)) ,@(mapcar #'(lambda (subform) (funcall function subform environment)) (rest (rest form))))) ((let let*) (cl:multiple-value-bind (body declarations) (peal-off-documentation-string-and-declarations (rest (rest form))) `(,(first form) ,(mapcar #'(lambda (binding) (if (and (consp binding) (= (length binding) 2)) `(,(first binding) ,(funcall function (second binding) environment)) binding)) (second form)) ,@declarations ,@(mapcar #'(lambda (subform) (funcall function subform environment)) body)))) (progn `(progn ,@(mapcar #'(lambda (subform) (funcall function subform environment)) (rest form)))) (quote (quotify form)) (the `(the ,(second form) ,(funcall function (third form) environment))) (macro-call (error "This shouldn't happen")) (lambda-call (cl:multiple-value-bind (body declarations documentation-string) (peal-off-documentation-string-and-declarations (rest (rest (first form))) t) ;; needs work: To process subforms of lambda list. `((lambda ,(second (first form)) ,@(if documentation-string (list documentation-string)) ,@declarations ,@(mapcar #'(lambda (subform) (funcall function subform environment)) body)) ,@(mapcar #'(lambda (subform) (funcall function subform environment)) (rest form))))) (otherwise (cons (first form) (mapcar #'(lambda (subform) (funcall function subform environment)) (rest form)))))) (defun-compile-time deterministic? (form environment) (walk #'(lambda (form form-type) (case form-type ((symbol-call setf-call) (function-record-deterministic? (get-function-record (first form)))) (multiple-value-call-nondeterministic nil) ;; note: not really sure about CATCH, THROW and UNWIND-PROTECT (otherwise t))) ;; note: potentially inefficient because must walk entire form even ;; after it is known to be nondeterministic #'(lambda (&optional (x nil x?) y) (if x? (and x y) t)) t nil nil form environment)) (defun-compile-time deterministic-lambda-list? (lambda-list environment) (walk-lambda-list #'(lambda (form form-type) (case form-type ((symbol-call setf-call) (function-record-deterministic? (get-function-record (first form)))) (multiple-value-call-nondeterministic nil) ;; note: not really sure about CATCH, THROW and UNWIND-PROTECT (otherwise t))) ;; note: potentially inefficient because must walk entire form even ;; after it is known to be nondeterministic #'(lambda (&optional (x nil x?) y) (if x? (and x y) t)) t nil nil lambda-list environment)) (defun-compile-time needs-substitution? (form environment) (walk #'(lambda (form form-type) (case form-type (function-lambda (not (and (every #'(lambda (form) (deterministic? form environment)) (peal-off-documentation-string-and-declarations (rest (rest (second form))) t)) (deterministic-lambda-list? (second (second form)) environment)))) ((function-symbol function-setf) (not (function-record-deterministic? (get-function-record (second form))))) (return-from (let ((tag (assoc (second form) *block-tags* :test #'eq))) (and tag (second tag)))) (go (let ((tag (assoc (second form) *tagbody-tags*))) (and tag (second tag)))) (setq *local?*) (local-setf t) (otherwise nil))) ;; note: potentially inefficient because must walk entire form even ;; after it is known to need substitution #'(lambda (&optional (x nil x?) y) (if x? (or x y) '())) t nil t form environment)) (defun-compile-time contains-local-setf/setq? (form environment) (walk #'(lambda (form form-type) (declare (ignore form)) (or (and *local?* (eq form-type 'setq)) (eq form-type 'local-setf))) ;; note: potentially inefficient because must walk entire form even ;; after it is known to contain a LOCAL SETF/SETQ special form #'(lambda (&optional (x nil x?) y) (if x? (or x y) '())) t nil nil form environment)) (defun-compile-time form-callees (form environment) (walk #'(lambda (form form-type) (case form-type ((function-symbol function-setf) (list (second form))) ((symbol-call setf-call) (list (first form))) (otherwise '()))) #'(lambda (&optional (x nil x?) y) (if x? (union x y :test #'equal) '())) t nil t form environment)) (defun-compile-time callees (function-name) (function-record-callees (get-function-record function-name))) (defun-compile-time indirect-callees-internal (function-names callees) (if (null function-names) callees (let ((function-name (first function-names))) (if (member function-name callees :test #'equal) (indirect-callees-internal (rest function-names) callees) (indirect-callees-internal (rest function-names) (indirect-callees-internal (callees function-name) (cons function-name callees))))))) (defun-compile-time indirect-callees (function-name) (indirect-callees-internal (callees function-name) '())) (defun-compile-time callers (function-name) (let ((callers '()) (function-names '())) (maphash #'(lambda (function-name function-record) (declare (ignore function-record)) (push function-name function-names)) *function-record-table*) (dolist (caller function-names) (if (member function-name (callees caller) :test #'equal) (pushnew caller callers :test #'equal))) callers)) (defun-compile-time indirect-callers-internal (function-names callers) (if (null function-names) callers (let ((function-name (first function-names))) (if (member function-name callers :test #'equal) (indirect-callers-internal (rest function-names) callers) (indirect-callers-internal (rest function-names) (indirect-callers-internal (callers function-name) (cons function-name callers))))))) (defun-compile-time indirect-callers (function-name) (indirect-callers-internal (callers function-name) '())) (defun-compile-time expand-local-setf (pairs environment) (if (null pairs) '(progn) (let ((d (gensym "DUMMY-")) (dummy-argument (gensym "DUMMY-"))) (cl:multiple-value-bind (vars vals stores store-form access-form) (#+(not (or lucid ansi-90 ansi-cl allegro cmu)) get-setf-method #+lucid lisp:get-setf-method #+(or ansi-90 ansi-cl allegro cmu) get-setf-expansion ;; note: Poplog and AKCL only support CLtL1. (first pairs) #-(or poplog akcl) environment) `(let* (,@(mapcar #'list vars vals) (,dummy-argument ,(second pairs)) (,d ,access-form)) (trail #'(lambda () ,(subst d (first stores) store-form))) ,@(if (null (rest (rest pairs))) (list (subst dummy-argument (first stores) store-form)) (list (subst dummy-argument (first stores) store-form) (expand-local-setf (rest (rest pairs)) environment)))))))) (defun-compile-time expand-local-setq (pairs environment) (if (null pairs) '(progn) (let ((d (gensym "DUMMY-"))) `(let ((,d ,(first pairs))) (trail #'(lambda () (setq ,(first pairs) ,d))) ,@(if (null (rest (rest pairs))) (list `(setq ,(first pairs) ,(perform-substitutions (second pairs) environment))) (list `(setq ,(first pairs) ,(perform-substitutions (second pairs) environment)) (expand-local-setq (rest (rest pairs)) environment))))))) (defun-compile-time perform-substitutions (form environment) (if (needs-substitution? form environment) (walk #'(lambda (form form-type) (case form-type (lambda-list (error "This shouldn't happen")) (variable (error "This shouldn't happen")) (block (let ((*block-tags* (cons (list (second form) nil) *block-tags*))) (process-subforms #'perform-substitutions form form-type environment))) (function-lambda (unless (deterministic-lambda-list? (second (second form)) environment) (screamer-error "Cannot (currently) handle a LAMDBA expression with~%~ nondeterministic initializations forms for~%~ &OPTIONAL and &AUX parameters: ~S" form)) (cl:multiple-value-bind (body declarations documentation-string) (peal-off-documentation-string-and-declarations (rest (rest (second form))) t) (if (every #'(lambda (form) (deterministic? form environment)) body) ;; needs work: To process subforms of lambda list. `#'(lambda ,(second (second form)) ,@(if documentation-string (list documentation-string)) ,@declarations ,@(mapcar #'(lambda (subform) (perform-substitutions subform environment)) body)) (let ((continuation (gensym "CONTINUATION-"))) ;; note: This conses every time #'(LAMBDA (...) ...) is ;; accessed when it is nondeterministic. A small ;; price to pay for a lot of error checking. `(make-nondeterministic-function :function ;; needs work: To process subforms of lambda list. #'(lambda (,continuation ,@(second (second form))) ,@(if documentation-string (list documentation-string)) ,@declarations ,continuation ;ignore ,(cps-convert-progn body continuation '() t environment))))))) ((function-symbol function-setf) (if (function-record-deterministic? (get-function-record (second form))) form ;; note: This conses every time #'FOO or #'(SETF FOO) is ;; accessed when FOO or (SETF FOO) is nondeterministic. ;; A small price to pay for a lot of error checking. `(make-nondeterministic-function :function #',(cps-convert-function-name (second form))))) (go (let ((tag (assoc (second form) *tagbody-tags*))) ;; note: Can't issue an error here if tag not found since it ;; might be outside the scope of a FOR-EFFECTS. (if (and tag (second tag)) `(,(second tag)) form))) (quote (error "This shouldn't happen")) (return-from (let ((tag (assoc (second form) *block-tags* :test #'eq)) (value (perform-substitutions (if (= (length form) 3) (third form) nil) environment))) ;; note: Can't issue an error here if tag not found since it ;; might be outside the scope of a FOR-EFFECTS. (if (and tag (second tag)) (possibly-beta-reduce-funcall (second tag) '() value (fourth tag)) `(return-from ,(second form) ,value)))) (setq (if *local?* (expand-local-setq (rest form) environment) (process-subforms #'perform-substitutions form form-type environment))) (tagbody (let ((*tagbody-tags* (append (mapcar #'(lambda (tag) (list tag nil)) (remove-if #'consp (rest form))) *tagbody-tags*))) (process-subforms #'perform-substitutions form form-type environment))) ;; note: Symbolics needs this to handle LOOP COLLECT clauses. #+symbolics (sys:variable-location (error "This shouldn't happen")) (for-effects (perform-substitutions (let ((*macroexpand-hook* #'funcall)) (macroexpand-1 form environment)) environment)) (local-setf (perform-substitutions (expand-local-setf (rest form) environment) environment)) (macro-call (error "This shouldn't happen")) (otherwise (process-subforms #'perform-substitutions form form-type environment)))) nil t nil nil form environment) form)) (defun-compile-time is-magic-declaration? (form) (and (consp form) (eq (first form) 'declare) (consp (rest form)) (consp (second form)) (eq (first (second form)) 'magic))) (defun-compile-time is-magic-continuation? (continuation) ;; Checks that CONTINUATION is of the form: ;; #'(lambda (...) (declare (magic) ...) ...) (and (consp continuation) (or (eq (first continuation) 'function) #+symbolics (eq (first continuation) 'lisp:function)) (null (rest (last continuation))) (= (length continuation) 2) (lambda-expression? (second continuation)) (>= (length (second continuation)) 3) (is-magic-declaration? (third (second continuation))))) (defun-compile-time magic-continuation-argument (continuation) (if (or (eq (first (second (second continuation))) '&optional) (eq (first (second (second continuation))) '&rest)) (second (second (second continuation))) (first (second (second continuation))))) (defun-compile-time possibly-beta-reduce-funcall (continuation types form value?) (unless (or (and (symbolp continuation) (not (symbol-package continuation))) (and (consp continuation) (or (eq (first continuation) 'function) #+symbolics (eq (first continuation) 'lisp:function)) (null (rest (last continuation))) (= (length continuation) 2) (symbolp (second continuation))) (is-magic-continuation? continuation)) (error "Please report this bug; This shouldn't happen (A)")) (cond ((symbolp continuation) (if value? (if (null types) (if (consp form) `(multiple-value-call ,continuation ,form) ;; note: This optimization is technically unsound if FORM ;; is a symbol macro that returns multiple values. `(funcall ,continuation ,form)) ;; note: This optimization assumes that there are no VALUES ;; types. `(funcall ,continuation (the (and ,@types) ,form))) `(progn ,form (funcall ,continuation)))) ((symbolp (second continuation)) (if value? (if (null types) (if (consp form) `(multiple-value-call ,continuation ,form) ;; note: This optimization is technically unsound if FORM ;; is a symbol macro that returns multiple values. `(,(second continuation) ,form)) ;; note: This optimization assumes that there are no VALUES ;; types. `(,(second continuation) (the (and ,@types) ,form))) `(progn ,form (,(second continuation))))) (t (if value? (progn (if (null (second (second continuation))) (error "Please report this bug; This shouldn't happen (B)")) (cond ((eq (first (second (second continuation))) '&rest) (if (null types) `(let ((,(magic-continuation-argument continuation) (multiple-value-list ,form))) ;; Peal off LAMBDA, arguments, and DECLARE. ,@(rest (rest (rest (second continuation))))) `(let ((,(magic-continuation-argument continuation) (list (the (and ,@types) ,form)))) ;; Peal off LAMBDA, arguments, and DECLARE. ,@(rest (rest (rest (second continuation))))))) ((or (and (consp form) (not (and (or (eq (first form) 'function) #+symbolics (eq (first form) 'lisp:function)) (null (rest (last form))) (= (length form) 2) (symbolp (second form))))) (and (symbolp form) (symbol-package form)) (symbol-package (magic-continuation-argument continuation))) (if (null types) `(let ((,(magic-continuation-argument continuation) ,form)) ,@(if (and *dynamic-extent?* (is-magic-continuation? form)) `((declare (dynamic-extent ,(magic-continuation-argument continuation))))) ;; Peal off LAMBDA, arguments, and DECLARE. ,@(rest (rest (rest (second continuation))))) `(let ((,(magic-continuation-argument continuation) (the (and ,@types) ,form))) (declare (type (and ,@types) ,(magic-continuation-argument continuation))) ;; Peal off LAMBDA, arguments, and DECLARE. ,@(rest (rest (rest (second continuation))))))) ;; note: This case may be unsoundly taken in the following cases: ;; a. (MAGIC-CONTINUATION-ARGUMENT CONTINUATION) is a ;; non-Screamer GENSYM. This can only happen if a ;; a BINDING-VARIABLE is a GENSYM in CPS-CONVERT-LET*. ;; b. FORM is a non-Screamer GENSYM (t (if (null types) (subst form (magic-continuation-argument continuation) ;; Peal off LAMBDA, arguments, and DECLARE. `(progn ,@(rest (rest (rest (second continuation))))) :test #'eq) (subst `(the (and ,@types) ,form) (magic-continuation-argument continuation) ;; Peal off LAMBDA, arguments, and DECLARE. `(progn ,@(rest (rest (rest (second continuation))))) :test #'eq))))) (progn (unless (null (second (second continuation))) (error "Please report this bug; This shouldn't happen (C)")) ;; Peal off LAMBDA, arguments, and DECLARE. `(progn ,form ,@(rest (rest (rest (second continuation)))))))))) (defun-compile-time void-continuation (continuation) (unless (or (and (symbolp continuation) (not (symbol-package continuation))) (and (consp continuation) (or (eq (first continuation) 'function) #+symbolics (eq (first continuation) 'lisp:function)) (null (rest (last continuation))) (= (length continuation) 2) (symbolp (second continuation))) (is-magic-continuation? continuation)) (error "Please report this bug; This shouldn't happen (D)")) (let ((dummy-argument (gensym "DUMMY-"))) ;; note: We could get rid of this bogosity by having two versions of each ;; nondeterministic function, one which returned a value and one which ;; didn't. `#'(lambda (&rest ,dummy-argument) (declare (magic) #+symbolics (sys:downward-function) (ignore ,dummy-argument)) ,@(cond ((symbolp continuation) `((funcall ,continuation))) ((symbolp (second continuation)) `((,(second continuation)))) ;; Peal off LAMBDA, arguments, and DECLARE. (t (rest (rest (rest (second continuation))))))))) (defun-compile-time cps-convert-function-name (function-name) (if (symbolp function-name) (intern (format nil "~A-NONDETERMINISTIC" (string function-name)) (symbol-package function-name)) `(setf ,(intern (format nil "~A-NONDETERMINISTIC" (string (second function-name))) (symbol-package (second function-name)))))) (defun-compile-time cps-convert-block (name body continuation types value? environment) (let* ((c (gensym "CONTINUATION-")) (*block-tags* (cons (list name c types value?) *block-tags*))) (possibly-beta-reduce-funcall `#'(lambda (,c) (declare (magic) #+symbolics (sys:downward-function)) ,(cps-convert-progn body c types value? environment)) '() continuation t))) (defun-compile-time cps-convert-if (antecedent consequent alternate continuation types value? environment) (let ((c (gensym "CONTINUATION-")) (dummy-argument (gensym "DUMMY-")) (other-arguments (gensym "OTHER-"))) (possibly-beta-reduce-funcall `#'(lambda (,c) (declare (magic) #+symbolics (sys:downward-function)) ,(cps-convert antecedent `#'(lambda (&optional ,dummy-argument &rest ,other-arguments) (declare (magic) #+symbolics (sys:downward-function) (ignore ,other-arguments)) (if ,dummy-argument ,(cps-convert consequent c types value? environment) ,(cps-convert alternate c types value? environment))) '() t environment)) '() continuation t))) (defun-compile-time cps-convert-let (bindings body declarations continuation types value? environment &optional new-bindings) (if (null bindings) `(let ,new-bindings ,@declarations ,(cps-convert-progn body continuation types value? environment)) (let* ((binding (first bindings)) (binding-variable (if (symbolp binding) binding (first binding))) (binding-form (if (and (consp binding) (= (length binding) 2)) (second binding) nil)) (dummy-argument (gensym "DUMMY-")) (other-arguments (gensym "OTHER-"))) (cps-convert binding-form `#'(lambda (&optional ,dummy-argument &rest ,other-arguments) (declare (magic) #+symbolics (sys:downward-function) (ignore ,other-arguments)) ,(cps-convert-let (rest bindings) body declarations continuation types value? environment (cons (list binding-variable dummy-argument) new-bindings))) '() t environment)))) (defun-compile-time cps-convert-let* (bindings body declarations continuation types value? environment) (if (null bindings) (if (null declarations) (cps-convert-progn body continuation types value? environment) `(let () ,@declarations ,(cps-convert-progn body continuation types value? environment))) (let* ((binding (first bindings)) (binding-variable (if (symbolp binding) binding (first binding))) (binding-form (if (and (consp binding) (= (length binding) 2)) (second binding) nil)) (other-arguments (gensym "OTHER-"))) (cps-convert binding-form `#'(lambda (&optional ,binding-variable &rest ,other-arguments) (declare (magic) #+symbolics (sys:downward-function) (ignore ,other-arguments)) ,(cps-convert-let* (rest bindings) body declarations continuation types value? environment)) '() t environment)))) (defun-compile-time cps-convert-multiple-value-call-internal (nondeterministic? function forms continuation types value? environment &optional arguments) (if (null forms) (if nondeterministic? ;; needs work: TYPES is never actually used in this branch. `(apply-nondeterministic-nondeterministic ,(if value? continuation (void-continuation continuation)) ,function (append ,@(reverse arguments))) (possibly-beta-reduce-funcall continuation types `(apply ,function (append ,@(reverse arguments))) value?)) (let ((dummy-argument (gensym "DUMMY-"))) (cps-convert (first forms) `#'(lambda (&rest ,dummy-argument) (declare (magic) #+symbolics (sys:downward-function)) ,(cps-convert-multiple-value-call-internal nondeterministic? function (rest forms) continuation types value? environment (cons dummy-argument arguments))) nil t environment)))) (defun-compile-time cps-convert-multiple-value-call (nondeterministic? function forms continuation types value? environment) (let ((dummy-argument (gensym "DUMMY-")) (other-arguments (gensym "OTHER-"))) (cps-convert function `#'(lambda (&optional ,dummy-argument &rest ,other-arguments) (declare (magic) #+symbolics (sys:downward-function) (ignore ,other-arguments)) ,(cps-convert-multiple-value-call-internal nondeterministic? dummy-argument forms continuation types value? environment)) nil t environment))) (defun-compile-time cps-convert-multiple-value-prog1 (form forms continuation types value? environment) (if value? (let ((dummy-argument (gensym "DUMMY-"))) (cps-convert form `#'(lambda (&rest ,dummy-argument) (declare (magic) #+symbolics (sys:downward-function)) ,(cps-convert-progn forms `#'(lambda () (declare (magic) #+symbolics (sys:downward-function)) (possibly-beta-reduce-funcall continuation types `(values-list ,dummy-argument) t)) nil nil environment)) types t environment)) (cps-convert-progn (cons form forms) continuation types nil environment))) (defun-compile-time cps-convert-progn (body continuation types value? environment) (cond ((null body) (possibly-beta-reduce-funcall continuation types nil value?)) ((null (rest body)) (cps-convert (first body) continuation types value? environment)) (t (cps-convert (first body) `#'(lambda () (declare (magic) #+symbolics (sys:downward-function)) ,(cps-convert-progn (rest body) continuation types value? environment)) '() nil environment)))) (defun-compile-time cps-convert-return-from (name result environment) (let ((tag (assoc name *block-tags* :test #'eq))) (if (and tag (second tag)) (cps-convert result (second tag) (third tag) (fourth tag) environment) ;; note: Can't issue an error here if tag not found since it might be ;; outside the scope of a FOR-EFFECTS. Thus we must compile a ;; RETURN-FROM nondeterministic code to deterministic code. ;; Likewise, can't issue an error here if tag is found but ;; (SECOND TAG) is NIL since this arrises when you have a ;; RETURN-FROM inside a FOR-EFFECTS to a tag outside the ;; FOR-EFFECTS. (let ((dummy-argument (gensym "DUMMY-"))) (cps-convert result `#'(lambda (&rest ,dummy-argument) (declare (magic) #+symbolics (sys:downward-function)) (return-from ,name (values-list ,dummy-argument))) '() t environment))))) (defun-compile-time cps-convert-setq (arguments continuation types value? environment) (if (null arguments) (possibly-beta-reduce-funcall continuation types nil value?) (let ((dummy-argument (gensym "DUMMY-")) (other-arguments (gensym "OTHER-"))) (cps-convert (second arguments) `#'(lambda (&optional ,dummy-argument &rest ,other-arguments) (declare (magic) #+symbolics (sys:downward-function) (ignore ,other-arguments) ,@(if (and (null (rest (rest arguments))) (not (null types))) `((type (and ,@types) ,dummy-argument)))) ,(if (null (rest (rest arguments))) (possibly-beta-reduce-funcall continuation types `(setq ,(first arguments) ,dummy-argument) value?) `(progn (setq ,(first arguments) ,dummy-argument) ,(cps-convert-setq (rest (rest arguments)) continuation types value? environment)))) (if (null (rest (rest arguments))) types '()) t environment)))) (defun-compile-time cps-convert-tagbody (body continuation types value? environment) (let ((segments (list (list 'header))) (*tagbody-tags* *tagbody-tags*)) ;cool! (dolist (form body) (if (consp form) (push form (rest (first segments))) (let ((c (gensym "CONTINUATION-"))) (push (list form c) *tagbody-tags*) (push (list c) segments)))) (push nil (rest (first segments))) (let ((segments (reverse segments)) (dummy-argument (gensym "DUMMY-")) (other-arguments (gensym "OTHER-"))) ;; needs work: The closures created by LABELS functions aren't declared to ;; have DYNAMIC-EXTENT since I don't know how to do this in ;; CommonLisp. `(labels ,(mapcar #'(lambda (segment) (let ((next (rest (member segment segments :test #'eq)))) `(,(first segment) (&optional ,dummy-argument &rest ,other-arguments) (declare (ignore ,dummy-argument ,other-arguments)) ,(cps-convert-progn (reverse (rest segment)) (if next `#',(first (first next)) continuation) (if next '() types) (or next value?) environment)))) (rest segments)) ,(let ((next (rest segments))) (cps-convert-progn (reverse (rest (first segments))) (if next `#',(first (first next)) continuation) (if next '() types) (or next value?) environment)))))) (defun-compile-time cps-convert-local-setf/setq (arguments continuation types value? environment) (if (null arguments) (possibly-beta-reduce-funcall continuation types nil value?) (let ((d (gensym "DUMMY-")) (dummy-argument (gensym "DUMMY-")) (other-arguments (gensym "OTHER-"))) (cl:multiple-value-bind (vars vals stores store-form access-form) (#+(not (or lucid ansi-90 ansi-cl allegro cmu)) get-setf-method #+lucid lisp:get-setf-method #+(or ansi-90 ansi-cl allegro cmu) get-setf-expansion ;; note: Poplog and AKCL only support CLtL1. (first arguments) #-(or poplog akcl) environment) (cps-convert (second arguments) `#'(lambda (&optional ,dummy-argument &rest ,other-arguments) (declare (magic) #+symbolics (sys:downward-function) (ignore ,other-arguments) ,@(if (and (null (rest (rest arguments))) (not (null types))) `((type (and ,@types) ,dummy-argument)))) (let* (,@(mapcar #'list vars vals) (,d ,access-form)) (unwind-protect ,(if (null (rest (rest arguments))) (possibly-beta-reduce-funcall continuation types (subst dummy-argument (first stores) store-form) value?) `(progn ,(subst dummy-argument (first stores) store-form) ,(cps-convert-local-setf/setq (rest (rest arguments)) continuation types value? environment))) ,(subst d (first stores) store-form)))) (if (null (rest (rest arguments))) types '()) t environment))))) (defun-compile-time cps-convert-call (function-name arguments continuation types value? environment &optional dummy-arguments) ;; needs work: TYPES is never actually used here. (if (null arguments) (let ((c (gensym "CONTINUATION-"))) (possibly-beta-reduce-funcall `#'(lambda (,c) (declare (magic) #+symbolics (sys:downward-function)) (,(cps-convert-function-name function-name) ,c ,@(reverse dummy-arguments))) '() (if value? continuation (void-continuation continuation)) t)) (let ((dummy-argument (gensym "DUMMY-")) (other-arguments (gensym "OTHER-"))) (cps-convert (first arguments) `#'(lambda (&optional ,dummy-argument &rest ,other-arguments) (declare (magic) #+symbolics (sys:downward-function) (ignore ,other-arguments)) ,(cps-convert-call function-name (rest arguments) continuation types value? environment (cons dummy-argument dummy-arguments))) '() t environment)))) (defun-compile-time cps-non-convert-call (function-name arguments continuation types value? environment &optional dummy-arguments) (if (null arguments) (possibly-beta-reduce-funcall continuation types (if (not (null types)) `(the (and ,@types) (,function-name ,@(reverse dummy-arguments))) `(,function-name ,@(reverse dummy-arguments))) value?) (let ((dummy-argument (gensym "DUMMY-")) (other-arguments (gensym "OTHER-"))) (cps-convert (first arguments) `#'(lambda (&optional ,dummy-argument &rest ,other-arguments) (declare (magic) #+symbolics (sys:downward-function) (ignore ,other-arguments)) ,(cps-non-convert-call function-name (rest arguments) continuation types value? environment (cons dummy-argument dummy-arguments))) '() t environment)))) (defun-compile-time cps-convert (form continuation types value? environment) (walk #'(lambda (form form-type) (if (and (not (eq form-type 'quote)) (deterministic? form environment) (not (contains-local-setf/setq? form environment))) (possibly-beta-reduce-funcall continuation types (perform-substitutions form environment) value?) (case form-type (lambda-list (error "This shouldn't happen")) (variable (possibly-beta-reduce-funcall continuation types form value?)) (block (cps-convert-block (second form) (rest (rest form)) continuation types value? environment)) ((function-lambda function-symbol function-setf) (possibly-beta-reduce-funcall continuation types (perform-substitutions form environment) value?)) (go (error "This shouldn't happen")) (if (cps-convert-if (second form) (third form) (if (null (rest (rest (rest form)))) nil (fourth form)) continuation types value? environment)) (let (cl:multiple-value-bind (body declarations) (peal-off-documentation-string-and-declarations (rest (rest form))) (cps-convert-let (second form) body declarations continuation types value? environment))) (let* (cl:multiple-value-bind (body declarations) (peal-off-documentation-string-and-declarations (rest (rest form))) (cps-convert-let* (second form) body declarations continuation types value? environment))) (multiple-value-call (cps-convert-multiple-value-call nil (second form) (rest (rest form)) continuation types value? environment)) (multiple-value-prog1 (cps-convert-multiple-value-prog1 (second form) (rest (rest form)) continuation types value? environment)) (progn (cps-convert-progn (rest form) continuation types value? environment)) (quote (possibly-beta-reduce-funcall continuation types (quotify form) value?)) (return-from (cps-convert-return-from (second form) (if (= (length form) 2) nil (third form)) environment)) (setq (if *local?* (cps-convert-local-setf/setq (rest form) continuation types value? environment) (cps-convert-setq (rest form) continuation types value? environment))) (tagbody (cps-convert-tagbody (rest form) continuation types value? environment)) (the (cps-convert (third form) continuation (cons (second form) types) value? environment)) ;; note: Symbolics needs this to handle LOOP COLLECT clauses. #+symbolics (sys:variable-location (error "This shouldn't happen")) ;; note: Symbolics needs this to handle DOTIMES. #+symbolics (compiler:invisible-references `(compiler:invisible-references ,(second form) ,(cps-convert-progn (rest (rest form)) continuation types value? environment))) (for-effects (possibly-beta-reduce-funcall continuation types form value?)) (local-setf (cps-convert-local-setf/setq (rest form) continuation types value? environment)) (multiple-value-call-nondeterministic (cps-convert-multiple-value-call t (second form) (rest (rest form)) continuation types value? environment)) (macro-call (error "This shouldn't happen")) (lambda-call (unless (deterministic-lambda-list? (second (first form)) environment) (screamer-error "Cannot (currently) handle a LAMDBA expression with~%~ nondeterministic initializations forms for~%~ &OPTIONAL and &AUX parameters: ~S" form)) (unless (every #'(lambda (argument) (and (symbolp argument) (not (member argument lambda-list-keywords :test #'eq)))) (second (first form))) (error "Cannot (currently) handle a nondeterministic~%~ form whose CAR is a LAMBDA expression with~%~ lambda list keywords or arguments that are not~%~ symbols: ~S" form)) (unless (= (length (second (first form))) (length (rest form))) (error "The form ~S has a CAR which is a LAMBDA~%~ expression which takes a different number of~%~ arguments than it is called with" form)) (cl:multiple-value-bind (body declarations) (peal-off-documentation-string-and-declarations (rest (rest (first form))) t) ;; note: The documentation string is lost for lambda calls ;; that are CPS Converted. (cps-convert-let (mapcar #'list (second (first form)) (rest form)) body declarations continuation types value? environment))) ((symbol-call setf-call) (if (function-record-deterministic? (get-function-record (first form))) (cps-non-convert-call (first form) (rest form) continuation types value? environment) (cps-convert-call (first form) (rest form) continuation types value? environment))) (otherwise (screamer-error "Cannot (currently) handle the special form ~S inside a~%~ nondeterministic context." (first form)))))) nil t nil nil form environment)) (defun-compile-time declare-deterministic (function-name) (setf (function-record-deterministic? (get-function-record function-name)) t)) (defun-compile-time declare-nondeterministic (function-name) (setf (function-record-deterministic? (get-function-record function-name)) nil)) (defun-compile-time compute-callees (body environment) ;; note: What bogosity in CommonLisp! UNION should allow zero arguments and ;; return NIL as the identity element for use by REDUCE. (reduce #'union (mapcar #'(lambda (form) (form-callees form environment)) (peal-off-documentation-string-and-declarations body t)) :initial-value '())) (defun-compile-time cache-definition (function-name lambda-list body callees) (let ((function-record (get-function-record function-name))) (setf (function-record-lambda-list function-record) lambda-list) (setf (function-record-body function-record) body) (setf (function-record-callees function-record) callees))) (defun-compile-time determine-whether-deterministic (function-name environment) ;; note: This is using the current rather than the saved ENVIRONMENT. (let* ((function-record (get-function-record function-name))) (setf (function-record-deterministic? function-record) (and (every #'(lambda (form) (deterministic? form environment)) (peal-off-documentation-string-and-declarations (function-record-body function-record) t)) (deterministic-lambda-list? (function-record-lambda-list function-record) environment))))) (defun-compile-time determine-whether-callers-are-deterministic (function-name function-names environment) ;; note: This is using the current rather than the saved ENVIRONMENT. (dolist (caller (callers function-name)) (unless (member caller function-names :test #'equal) (determine-whether-deterministic caller environment) (determine-whether-callers-are-deterministic caller (cons caller function-names) environment)))) (defun-compile-time function-definition (function-name environment) ;; note: This is using the current rather than the saved ENVIRONMENT. (let* ((function-record (get-function-record function-name)) (lambda-list (function-record-lambda-list function-record)) (body (function-record-body function-record))) (cl:multiple-value-bind (body declarations documentation-string) (peal-off-documentation-string-and-declarations body t) (if (function-record-deterministic? function-record) (let ((*block-tags* (list (list function-name nil)))) ;; needs work: To process subforms of lambda list. (list `(cl:defun ,function-name ,lambda-list ,@(if documentation-string (list documentation-string)) ,@declarations ,@(mapcar #'(lambda (form) (perform-substitutions form environment)) body)) `(declare-deterministic ',function-name))) (let* ((continuation (gensym "CONTINUATION-")) ;; note: Could provide better TYPES and VALUE? here. (*block-tags* (list (list function-name continuation '() t)))) (list `(cl:defun ,function-name ,lambda-list ,@(if documentation-string (list documentation-string)) ,@declarations (declare (ignore ,@(reduce #'append (mapcar #'(lambda (argument) (if (consp argument) (if (and (consp (rest argument)) (consp (rest (rest argument)))) (list (first argument) (third argument)) (list (first argument))) (list argument))) (set-difference lambda-list lambda-list-keywords :test #'eq))))) (screamer-error "Function ~S is a nondeterministic function. As such, it~%~ must be called only from a nondeterministic context." ',function-name)) `(cl:defun ,(cps-convert-function-name function-name) (,continuation ,@lambda-list) ,@(if documentation-string (list documentation-string)) ,@declarations ,continuation ;ignore ,(cps-convert-progn body continuation '() t environment)) `(declare-nondeterministic ',function-name))))))) (defun-compile-time modified-function-definitions (function-name environment) ;; note: This is using the current rather than the saved ENVIRONMENT. (let ((function-record (get-function-record function-name)) (callers (indirect-callers function-name)) (function-records '())) (setf (function-record-old-deterministic? function-record) (function-record-deterministic? function-record)) (setf (function-record-deterministic? function-record) t) (push function-record function-records) (dolist (caller callers) (let ((function-record (get-function-record caller))) (unless (member function-record function-records :test #'eq) (setf (function-record-old-deterministic? function-record) (function-record-deterministic? function-record)) (setf (function-record-deterministic? function-record) t) (push function-record function-records)))) (dolist (caller callers) (dolist (callee (callees caller)) (let ((function-record (get-function-record callee))) (unless (member function-record function-records :test #'eq) (setf (function-record-old-deterministic? function-record) (function-record-deterministic? function-record)) (push function-record function-records))))) (determine-whether-deterministic function-name environment) (determine-whether-callers-are-deterministic function-name nil environment) (let ((definitions (function-definition function-name environment))) (unless (eq (not (function-record-deterministic? function-record)) (not (function-record-old-deterministic? function-record))) (dolist (caller callers) (if (and (not (equal caller function-name)) (some #'(lambda (callee) (let ((function-record (get-function-record callee))) (not (eq (not (function-record-deterministic? function-record)) (not (function-record-old-deterministic? function-record)))))) (callees caller))) (setf definitions (append (function-definition caller environment) definitions))))) ;; note: This is so that macroexpand without compile doesn't get out of ;; sync. (dolist (function-record function-records) (setf (function-record-deterministic? function-record) (function-record-old-deterministic? function-record))) definitions))) ;;; The protocol #+symbolics (setf (gethash 'defun zwei:*lisp-indentation-offset-hash-table*) '(2 1)) #+symbolics (setf (get 'defun 'zwei:definition-function-spec-parser) (get 'cl:defun 'zwei:definition-function-spec-parser)) (defmacro-compile-time defun (function-name lambda-list &body body &environment environment) (let ((*nondeterministic-context?* t)) (check-function-name function-name) (let* ((callees (compute-callees body environment)) (function-record (get-function-record function-name)) (function-record-lambda-list (function-record-lambda-list function-record)) (function-record-body (function-record-body function-record)) (function-record-callees (function-record-callees function-record)) (function-record-deterministic? (function-record-deterministic? function-record)) (function-record-old-deterministic? (function-record-old-deterministic? function-record)) (function-record-screamer? (function-record-screamer? function-record))) (cache-definition function-name lambda-list body callees) (let ((modified-function-definitions ;; note: This is using the current rather than the saved ENVIRONMENT. (modified-function-definitions function-name environment))) ;; note: This is so that macroexpand without compile doesn't get out of ;; sync. (setf (function-record-lambda-list function-record) function-record-lambda-list) (setf (function-record-body function-record) function-record-body) (setf (function-record-callees function-record) function-record-callees) (setf (function-record-deterministic? function-record) function-record-deterministic?) (setf (function-record-old-deterministic? function-record) function-record-old-deterministic?) (setf (function-record-screamer? function-record) function-record-screamer?) `(eval-when (compile load eval) (cache-definition ',function-name ',lambda-list ',body ',callees) ,@modified-function-definitions ',function-name))))) (defmacro-compile-time either (&body forms) (case (length forms) (0 '(fail)) (1 (first forms)) (otherwise `(if (a-boolean) ,(first forms) (either ,@(rest forms)))))) (defmacro-compile-time local (&body forms &environment environment) (let ((*local?* t)) `(progn ,@(mapcar #'(lambda (form) (perform-substitutions form environment)) forms)))) (defmacro-compile-time global (&body forms &environment environment) (let ((*local?* nil)) `(progn ,@(mapcar #'(lambda (form) (perform-substitutions form environment)) forms)))) (defmacro-compile-time for-effects (&body forms &environment environment) `(choice-point ,(let ((*nondeterministic-context?* t)) (cps-convert-progn forms '#'fail nil nil environment)))) (defmacro-compile-time one-value (form1 &optional (form2 nil form2?)) `(block one-value (for-effects (return-from one-value ,form1)) ,(if form2? form2 '(fail)))) (defmacro-compile-time possibly? (&body forms) `(one-value (let ((value (progn ,@forms))) (unless value (fail)) value) nil)) (defmacro-compile-time necessarily? (&body forms) (let ((result (gensym "RESULT-")) (value (gensym "VALUE-"))) `(let ((,result t)) (one-value (let ((,value (progn ,@forms))) (when ,value (setf ,result ,value) (fail)) ,value) ,result)))) (defmacro-compile-time all-values (&body forms) (let ((values (gensym "VALUES-")) (last-value-cons (gensym "LAST-VALUE-CONS-")) (value (gensym "VALUE-"))) `(let ((,values '()) (,last-value-cons nil)) (for-effects (let ((,value (progn ,@forms))) (global (cond ((null ,values) (setf ,last-value-cons (list ,value)) (setf ,values ,last-value-cons)) (t (setf (rest ,last-value-cons) (list ,value)) (setf ,last-value-cons (rest ,last-value-cons))))))) ,values))) (defmacro-compile-time ith-value (i form1 &optional (form2 nil form2?)) (let ((iv (gensym "IV-")) (value (gensym "VALUE-"))) `(block ith-value (let ((,iv (value-of ,i))) (for-effects (let ((,value ,form1)) (if (zerop ,iv) (return-from ith-value ,value)) (decf ,iv))) ,(if form2? form2 '(fail)))))) (defun trail (function) ;; note: Is it really better to use VECTOR-PUSH-EXTEND than CONS for the ;; trail? (if *nondeterministic?* (vector-push-extend function *trail* 1024))) (defun y-or-n-p (&optional (format-string nil format-string?) &rest format-args) (cond (*iscream?* (let ((query (if format-string? (format nil "~A (Y or N): " (apply #'format nil format-string format-args)) "(Y or N): "))) #-allegro (emacs-eval '(y-or-n-p-begin)) (unwind-protect (tagbody loop (format *query-io* "~%~A" query) (let ((char (read-char *query-io*))) (when (or (char= char #\y) (char= char #\Y)) (format *query-io* "Y") (return-from y-or-n-p t)) (when (or (char= char #\n) (char= char #\N)) (format *query-io* "N") (return-from y-or-n-p nil))) (format *query-io* "Please type a single character, Y or N") (go loop)) #-allegro (emacs-eval '(y-or-n-p-end))))) (format-string? (apply #'cl:y-or-n-p format-string format-args)) (t (cl:y-or-n-p)))) (defmacro-compile-time print-values (&body forms) (let ((value (gensym "VALUE-"))) `(catch 'succeed (for-effects (let ((,value (progn ,@forms))) (print ,value) (unless (y-or-n-p "Do you want another solution?") (throw 'succeed ,value))))))) ;;; note: Should have way of having a stream of values. (eval-when (compile load eval) (setf *screamer?* t)) (defun print-nondeterministic-function (nondeterministic-function stream print-level) (declare (ignore print-level)) (format stream "#<~A ~S>" 'nondeterministic (nondeterministic-function-function nondeterministic-function))) (eval-when (compile load eval) (declare-nondeterministic 'a-boolean)) (cl:defun a-boolean () (screamer-error "A-BOOLEAN is a nondeterministic function. As such, it must be called only~%~ from a nondeterministic context.")) (cl:defun a-boolean-nondeterministic (continuation) (choice-point (funcall continuation t)) (funcall continuation nil)) (defun fail () (throw 'fail nil)) (defmacro-compile-time when-failing ((&body failing-forms) &body forms) (let ((old-fail (gensym "FAIL-"))) `(let ((,old-fail #'fail)) (unwind-protect (progn (setf (symbol-function 'fail) #'(lambda () ,@failing-forms (funcall ,old-fail))) ,@forms) (setf (symbol-function 'fail) ,old-fail))))) (defmacro-compile-time count-failures (&body forms) (let ((values (gensym "VALUES-"))) `(let ((failure-count 0)) (when-failing ((incf failure-count)) (let ((,values (multiple-value-list (progn ,@forms)))) (format t "Failures = ~10<~;~d~>" failure-count) (values-list ,values)))))) (defun nondeterministic-function? (thing) (nondeterministic-function?-internal (value-of thing))) (eval-when (compile load eval) (declare-nondeterministic 'funcall-nondeterministic)) (cl:defun funcall-nondeterministic (function &rest arguments) (declare (ignore function arguments)) (screamer-error "FUNCALL-NONDETERMINISTIC is a nondeterministic function. As such, it~%~ must be called only from a nondeterministic context.")) (cl:defun funcall-nondeterministic-nondeterministic (continuation function &rest arguments) (let ((function (value-of function))) (if (nondeterministic-function? function) (apply (nondeterministic-function-function function) continuation arguments) (funcall continuation (apply function arguments))))) (eval-when (compile load eval) (declare-nondeterministic 'apply-nondeterministic)) (cl:defun apply-nondeterministic (function argument &rest arguments) (declare (ignore function argument arguments)) (screamer-error "APPLY-NONDETERMINISTIC is a nondeterministic function. As such, it must~%~ be called only from a nondeterministic context.")) (cl:defun apply-nondeterministic-nondeterministic (continuation function argument &rest arguments) (let ((function (value-of function))) (if (null arguments) (if (nondeterministic-function? function) (apply (nondeterministic-function-function function) continuation argument) (funcall continuation (apply function argument))) (if (nondeterministic-function? function) ;; note: I don't know how to avoid the consing here. (apply (nondeterministic-function-function function) continuation (apply #'list* (cons argument arguments))) (funcall continuation (apply function argument arguments)))))) (defmacro-compile-time multiple-value-bind (variables form &body body &environment environment) (if (every #'(lambda (form) (deterministic? form environment)) (peal-off-documentation-string-and-declarations body)) `(cl:multiple-value-bind ,variables ,form ,@body) (let ((other-arguments (gensym "OTHER-"))) `(multiple-value-call-nondeterministic #'(lambda (&optional ,@variables &rest ,other-arguments) (declare (ignore ,other-arguments)) ,@body) ,form)))) (defun unwind-trail () (tagbody loop (if (zerop (fill-pointer *trail*)) (return-from unwind-trail)) (funcall (vector-pop *trail*)) ;; note: This is to allow the trail closures to be garbage collected. (setf (aref *trail* (fill-pointer *trail*)) nil) (go loop))) (defun purge (function-name) (remhash (value-of function-name) *function-record-table*) t) (defun unwedge-screamer () (maphash #'(lambda (function-name function-record) (unless (function-record-screamer? function-record) (remhash function-name *function-record-table*))) *function-record-table*) t) ;;; note: These optimized versions of AN-INTEGER, AN-INTEGER-ABOVE, ;;; AN-INTEGER-BELOW, AN-INTEGER-BETWEEN and A-MEMBER-OF have different ;;; failure behavior as far as WHEN-FAILING is concerned than the ;;; original purely Screamer versions. This is likely to affect only ;;; failure counts generated by COUNT-FAILURES. A small price to pay for ;;; tail recursion optimization. (eval-when (compile load eval) (declare-nondeterministic 'an-integer)) (cl:defun an-integer () (screamer-error "AN-INTEGER is a nondeterministic function. As such, it must be called~%~ only from a nondeterministic context.")) (cl:defun an-integer-nondeterministic (continuation) (choice-point-external (choice-point-internal (funcall continuation 0)) (let ((i 1)) (loop (choice-point-internal (funcall continuation i)) (choice-poin