0.9.10.17: fix bug #400, aka more correct CONSTANTP

 * To know that a function call is a constant we need to check that
    it doesn't signal an error in addition to knowing that the function
    is foldable.
 * To know that a THE form is constant we need to check that the
    value is of the right type and be prepared to deal with malformed
    type specifiers.
 * Tests, tests, tests.

 ...all in all, I'm starting to miss the evaluator branch.

diff --git a/BUGS b/BUGS
index b5f60a6..1960b90 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -2074,9 +2074,6 @@ WORKAROUND:
   the right fix is to remove the abstraction violation in the
   compiler's type deriver.
 
-392: slot-accessor for subclass misses obsoleted superclass
-  (fixed in sbcl-0.9.7.9)
-
 393: Wrong error from methodless generic function
     (DEFGENERIC FOO (X))
     (FOO 1 2)
@@ -2151,9 +2148,6 @@ WORKAROUND:
   For some more details see comments for (define-alien-type-method
   (c-string :deport-gen) ...)  in host-c-call.lisp.
 
-399: LOOP FOR ACROSS and full call to DATA-VECTOR-REF
-  (fixed in sbcl-0.9.9.x)
-
 400: "aggressive constant folding"
-    (compile nil '(lambda () (or t (the integer (/ 1 0)))))
-  signals an error.
+  (fixed in sbcl-0.9.10.17)
+

diff --git a/src/compiler/constantp.lisp b/src/compiler/constantp.lisp
index 97e27a9..0e2f4af 100644 (file)
--- a/src/compiler/constantp.lisp
+++ b/src/compiler/constantp.lisp
@@ -81,9 +81,16 @@
          (let ((info (info :function :info name)))
            (and info (ir1-attributep (fun-info-attributes info)
                                      foldable)))
-         (every (lambda (arg)
-                  (%constantp arg environment envp))
-                (cdr form)))))
+         (and (every (lambda (arg)
+                       (%constantp arg environment envp))
+                     (cdr form))
+              ;; Even though the function may be marked as foldable
+              ;; the call may still signal an error -- eg: (CAR 1).
+              (handler-case
+                  (progn
+                    (constant-function-call-value form environment envp)
+                    t)
+                (error () nil))))))
 
 (defun constant-function-call-value (form environment envp)
   (apply (fdefinition (car form))
@@ -172,14 +179,13 @@ constantness of the FORM in ENVIRONMENT."
    :test (every #'constantp* (cons protected-form cleanup-forms))
    :eval (constant-form-value* protected-form))
 
- (defconstantp the (value-type form)
-   :test (constantp* form)
-   :eval (let ((value (constant-form-value* form)))
-           (if (typep value value-type)
-               value
-               (error 'type-error
-                      :datum value
-                      :expected-type value-type))))
+ (defconstantp the (type form)
+   :test (and (constantp* form)
+              (handler-case
+                  ;; in case the type-spec is malformed!
+                  (typep (constant-form-value* form) type)
+                (error () nil)))
+   :eval (constant-form-value* form))
 
  (defconstantp block (name &body forms)
    ;; We currently fail to detect cases like

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 282cdb0..e0b1f61 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -1988,3 +1988,7 @@
                 (space 2) (safety 0) (compilation-speed 0)))
       (unwind-protect 0
         (* (/ (multiple-value-prog1 -29457482 -5602513511) 1))))))))
+
+;; aggressive constant folding (bug #400)
+(assert
+ (eq t (funcall (compile nil '(lambda () (or t (the integer (/ 1 0))))))))

diff --git a/tests/eval.impure.lisp b/tests/eval.impure.lisp
index 3708433..da75fb0 100644 (file)
--- a/tests/eval.impure.lisp
+++ b/tests/eval.impure.lisp
@@ -136,6 +136,16 @@
                 ((the integer 1)        t         1)
                 ((the integer (+ 1 1))  t         2)
                 ((the integer (foo))    nil)
+                ((the symbol 1)         nil)
+                ((the "bad type" 1)     nil)
+                ((multiple-value-prog1
+                     (+ 1 1)
+                   :nada)               t         2)
+                ((multiple-value-prog1
+                     :nada
+                   (/ 1 0))             nil)
+                ((/ 1 0)                nil)
+                ((/ 1 1)                t         1)
                 ((+ 1 2)                t         3)))
   (destructuring-bind (form c &optional v) test
     (assert (eql (constantp form) c))

diff --git a/version.lisp-expr b/version.lisp-expr
index 16174f8..0744e3b 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.9.10.16"
+"0.9.10.17"