(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
(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)
;;; 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))
;; 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
: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
(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)