X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fconstantp.lisp;h=0e2f4af8be975a0bff9b251531695ed4d20ba97b;hb=bd455348d39bee562296741689882dcb97c46ba3;hp=41a69d68a6393eb9c5b6931c1601f572d0923bad;hpb=444d2072bc52e60a41af62ee22e343e76109212f;p=sbcl.git

diff --git a/src/compiler/constantp.lisp b/src/compiler/constantp.lisp
index 41a69d6..0e2f4af 100644
--- 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
@@ -195,15 +201,18 @@ constantness of the FORM in ENVIRONMENT."
 
  (defconstantp multiple-value-prog1 (first-form &body forms)
    :test (every #'constantp* (cons first-form forms))
-   :test (constant-form-value* first-form))
+   :eval (constant-form-value* first-form))
 
  (defconstantp progv (symbols values &body forms)
    :test (and (constantp* symbols)
               (constantp* values)
-              (let ((*special-constant-variables*
-                     (append (constant-form-value* symbols)
-                              *special-constant-variables*)))
-                (every #'constantp* forms)))
+              (let* ((symbol-values (constant-form-value* symbols))
+                     (*special-constant-variables*
+                      (append symbol-values *special-constant-variables*)))
+                (progv
+                    symbol-values
+                    (constant-form-value* values)
+                  (every #'constantp* forms))))
    :eval (progv
              (constant-form-value* symbols)
              (constant-form-value* values)