X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fconstantp.lisp;h=d06d22661e7b33b4f739f230f987616cf61656ef;hb=74cf7a4d01664fbf72a662ba093ad67ca243b524;hp=97e27a9325437dc7284d602ec6e681a90b20dd1a;hpb=a02f19f746ef4808147de0d3d72700eb06b2253c;p=sbcl.git

diff --git a/src/compiler/constantp.lisp b/src/compiler/constantp.lisp
index 97e27a9..d06d226 100644
--- a/src/compiler/constantp.lisp
+++ b/src/compiler/constantp.lisp
@@ -29,7 +29,7 @@
 
 (defun %constantp (form environment envp)
   (let ((form (if envp
-                  (sb!xc:macroexpand form environment)
+                  (%macroexpand form environment)
                   form)))
     (typecase form
       ;; This INFO test catches KEYWORDs as well as explicitly
@@ -40,16 +40,28 @@
       (list
        (or (constant-special-form-p form environment envp)
            #-sb-xc-host
-           (constant-function-call-p form environment envp)))
+           (values (constant-function-call-p form environment envp))))
       (t t))))
 
 (defun %constant-form-value (form environment envp)
   (let ((form (if envp
-                  (sb!xc:macroexpand form environment)
+                  (%macroexpand form environment)
                   form)))
     (typecase form
       (symbol
-       (symbol-value form))
+       ;; KLUDGE: superficially, this might look good enough: we grab
+       ;; the value from the info database, and if it isn't there (or
+       ;; is NIL, but hey) we use the host's value.  This works for
+       ;; MOST-POSITIVE-FIXNUM and friends, but still fails for
+       ;; float-related constants, where there is in fact no guarantee
+       ;; that we can represent our target value at all in the host,
+       ;; so we don't try.  We should rework all uses of floating
+       ;; point so that we never try to use a host's value, and then
+       ;; make some kind of assertion that we never attempt to take
+       ;; a host value of a constant in the CL package.
+       #+sb-xc-host (or (info :variable :xc-constant-value form)
+                        (symbol-value form))
+       #-sb-xc-host (symbol-value form))
       (list
        (if (special-operator-p (car form))
            (constant-special-form-value form environment envp)
@@ -76,14 +88,21 @@
 ;;; too.
 (defun constant-function-call-p (form environment envp)
   (let ((name (car form)))
-    (and (legal-fun-name-p name)
-         (eq :function (info :function :kind name))
-         (let ((info (info :function :info name)))
-           (and info (ir1-attributep (fun-info-attributes info)
-                                     foldable)))
-         (every (lambda (arg)
-                  (%constantp arg environment envp))
-                (cdr form)))))
+    (if (and (legal-fun-name-p name)
+             (eq :function (info :function :kind name))
+             (let ((info (info :function :info name)))
+               (and info (ir1-attributep (fun-info-attributes info)
+                                         foldable)))
+             (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
+            (values t (constant-function-call-value form environment envp))
+          (error ()
+            (values nil nil)))
+        (values nil nil))))
 
 (defun constant-function-call-value (form environment envp)
   (apply (fdefinition (car form))
@@ -138,7 +157,7 @@ constantness of the FORM in ENVIRONMENT."
                   ;; instead of general (not handling cases like &key (x y))
                   (declare (ignorable
                             ,@(remove-if (lambda (arg)
-                                           (member arg lambda-list-keywords))
+                                           (member arg sb!xc:lambda-list-keywords))
                                          lambda-list)))
                    ,body))))
       `(progn
@@ -172,14 +191,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