+;;;; implementation of CONSTANTP, needs both INFO and IR1-ATTRIBUTES
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(!begin-collecting-cold-init-forms)
+
+(defvar *special-form-constantp-funs*)
+(declaim (type hash-table *special-form-constantp-funs*))
+(!cold-init-forms
+ (setf *special-form-constantp-funs* (make-hash-table)))
+
+(defvar *special-form-constant-form-value-funs*)
+(declaim (type hash-table *special-form-constant-form-value-funs*))
+(!cold-init-forms
+ (setf *special-form-constant-form-value-funs* (make-hash-table)))
+
+(defvar *special-constant-variables*)
+(!cold-init-forms
+ (setf *special-constant-variables* nil))
+
+(defun %constantp (form environment envp)
+ (let ((form (if envp
+ (sb!xc:macroexpand form environment)
+ form)))
+ (typecase form
+ ;; This INFO test catches KEYWORDs as well as explicitly
+ ;; DEFCONSTANT symbols.
+ (symbol
+ (or (eq (info :variable :kind form) :constant)
+ (constant-special-variable-p form)))
+ (list
+ (or (constant-special-form-p form environment envp)
+ #-sb-xc-host
+ (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)
+ form)))
+ (typecase form
+ (symbol
+ (symbol-value form))
+ (list
+ (if (special-operator-p (car form))
+ (constant-special-form-value form environment envp)
+ #-sb-xc-host
+ (constant-function-call-value form environment envp)))
+ (t
+ form))))
+
+(defun constant-special-form-p (form environment envp)
+ (let ((fun (gethash (car form) *special-form-constantp-funs*)))
+ (when fun
+ (funcall fun form environment envp))))
+
+(defun constant-special-form-value (form environment envp)
+ (let ((fun (gethash (car form) *special-form-constant-form-value-funs*)))
+ (if fun
+ (funcall fun form environment envp)
+ (error "Not a constant-foldable special form: ~S" form))))
+
+(defun constant-special-variable-p (name)
+ (and (member name *special-constant-variables*) t))
+
+;;; FIXME: It would be nice to deal with inline functions
+;;; 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)))))
+
+(defun constant-function-call-value (form environment envp)
+ (apply (fdefinition (car form))
+ (mapcar (lambda (arg)
+ (%constant-form-value arg environment envp))
+ (cdr form))))
+
+#!-sb-fluid (declaim (inline sb!xc:constantp))
+(defun sb!xc:constantp (form &optional (environment nil envp))
+ #!+sb-doc
+ "True of any FORM that has a constant value: self-evaluating objects,
+keywords, defined constants, quote forms. Additionally the
+constant-foldability of some function calls special forms is recognized. If
+ENVIRONMENT is provided the FORM is first macroexpanded in it."
+ (%constantp form environment envp))
+
+#!-sb-fluid (declaim (inline constant-form-value))
+(defun constant-form-value (form &optional (environment nil envp))
+ #!+sb-doc
+ "Returns the value of the constant FORM in ENVIRONMENT. Behaviour
+is undefined unless CONSTANTP has been first used to determine the
+constantness of the FORM in ENVIRONMENT."
+ (%constant-form-value form environment envp))
+
+(declaim (inline constant-typep))
+(defun constant-typep (form type &optional (environment nil envp))
+ (and (%constantp form environment envp)
+ ;; FIXME: We probably should be passing the environment to
+ ;; TYPEP too, but (1) our XC version of typep AVERs that the
+ ;; environment is null (2) our real version ignores it anyhow.
+ (sb!xc:typep (%constant-form-value form environment envp) type)))
+
+;;;; NOTE!!!
+;;;;
+;;;; If you add new special forms, check that they do not
+;;;; alter the logic of existing ones: eg, currently
+;;;; CONSTANT-FORM-VALUE directly evaluates the last expression
+;;;; of a PROGN, as no assignment is allowed. If you extend
+;;;; analysis to assignments then other forms must take this
+;;;; into account.
+
+(defmacro defconstantp (operator lambda-list &key test eval)
+ (with-unique-names (form environment envp)
+ (flet ((frob (body)
+ `(flet ((constantp* (x)
+ (%constantp x ,environment ,envp))
+ (constant-form-value* (x)
+ (%constant-form-value x ,environment ,envp)))
+ (declare (ignorable #'constantp* #'constant-form-value*))
+ (destructuring-bind ,lambda-list (cdr ,form)
+ ;; KLUDGE: is all we need, so we keep it simple
+ ;; instead of general (not handling cases like &key (x y))
+ (declare (ignorable
+ ,@(remove-if (lambda (arg)
+ (member arg lambda-list-keywords))
+ lambda-list)))
+ ,body))))
+ `(progn
+ (setf (gethash ',operator *special-form-constantp-funs*)
+ (lambda (,form ,environment ,envp)
+ ,(frob test)))
+ (setf (gethash ',operator *special-form-constant-form-value-funs*)
+ (lambda (,form ,environment ,envp)
+ ,(frob eval)))))))
+
+(!cold-init-forms
+ (defconstantp quote (value)
+ :test t
+ :eval value)
+
+ (defconstantp if (test then &optional else)
+ :test
+ (and (constantp* test)
+ (constantp* (if (constant-form-value* test)
+ then
+ else)))
+ :eval (if (constant-form-value* test)
+ (constant-form-value* then)
+ (constant-form-value* else)))
+
+ (defconstantp progn (&body forms)
+ :test (every #'constantp* forms)
+ :eval (constant-form-value* (car (last forms))))
+
+ (defconstantp unwind-protect (protected-form &body cleanup-forms)
+ :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 block (name &body forms)
+ ;; We currently fail to detect cases like
+ ;;
+ ;; (BLOCK FOO
+ ;; ...CONSTANT-FORMS...
+ ;; (RETURN-FROM FOO CONSTANT-VALUE)
+ ;; ...ANYTHING...)
+ ;;
+ ;; Right now RETURN-FROM kills the constantness unequivocally.
+ :test (every #'constantp* forms)
+ :eval (constant-form-value* (car (last forms))))
+
+ (defconstantp multiple-value-prog1 (first-form &body forms)
+ :test (every #'constantp* (cons first-form forms))
+ :test (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)))
+ :eval (progv
+ (constant-form-value* symbols)
+ (constant-form-value* values)
+ (constant-form-value* (car (last forms))))))
+
+(!defun-from-collected-cold-init-forms !constantp-cold-init)
+