1 ;;;; implementation of CONSTANTP, needs both INFO and IR1-ATTRIBUTES
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
14 (!begin-collecting-cold-init-forms)
16 (defvar *special-form-constantp-funs*)
17 (declaim (type hash-table *special-form-constantp-funs*))
19 (setf *special-form-constantp-funs* (make-hash-table)))
21 (defvar *special-form-constant-form-value-funs*)
22 (declaim (type hash-table *special-form-constant-form-value-funs*))
24 (setf *special-form-constant-form-value-funs* (make-hash-table)))
26 (defvar *special-constant-variables*)
28 (setf *special-constant-variables* nil))
30 (defun %constantp (form environment envp)
32 (sb!xc:macroexpand form environment)
35 ;; This INFO test catches KEYWORDs as well as explicitly
36 ;; DEFCONSTANT symbols.
38 (or (eq (info :variable :kind form) :constant)
39 (constant-special-variable-p form)))
41 (or (constant-special-form-p form environment envp)
43 (constant-function-call-p form environment envp)))
46 (defun %constant-form-value (form environment envp)
48 (sb!xc:macroexpand form environment)
54 (if (special-operator-p (car form))
55 (constant-special-form-value form environment envp)
57 (constant-function-call-value form environment envp)))
61 (defun constant-special-form-p (form environment envp)
62 (let ((fun (gethash (car form) *special-form-constantp-funs*)))
64 (funcall fun form environment envp))))
66 (defun constant-special-form-value (form environment envp)
67 (let ((fun (gethash (car form) *special-form-constant-form-value-funs*)))
69 (funcall fun form environment envp)
70 (error "Not a constant-foldable special form: ~S" form))))
72 (defun constant-special-variable-p (name)
73 (and (member name *special-constant-variables*) t))
75 ;;; FIXME: It would be nice to deal with inline functions
77 (defun constant-function-call-p (form environment envp)
78 (let ((name (car form)))
79 (and (legal-fun-name-p name)
80 (eq :function (info :function :kind name))
81 (let ((info (info :function :info name)))
82 (and info (ir1-attributep (fun-info-attributes info)
84 (and (every (lambda (arg)
85 (%constantp arg environment envp))
87 ;; Even though the function may be marked as foldable
88 ;; the call may still signal an error -- eg: (CAR 1).
91 (constant-function-call-value form environment envp)
95 (defun constant-function-call-value (form environment envp)
96 (apply (fdefinition (car form))
98 (%constant-form-value arg environment envp))
101 #!-sb-fluid (declaim (inline sb!xc:constantp))
102 (defun sb!xc:constantp (form &optional (environment nil envp))
104 "True of any FORM that has a constant value: self-evaluating objects,
105 keywords, defined constants, quote forms. Additionally the
106 constant-foldability of some function calls special forms is recognized. If
107 ENVIRONMENT is provided the FORM is first macroexpanded in it."
108 (%constantp form environment envp))
110 #!-sb-fluid (declaim (inline constant-form-value))
111 (defun constant-form-value (form &optional (environment nil envp))
113 "Returns the value of the constant FORM in ENVIRONMENT. Behaviour
114 is undefined unless CONSTANTP has been first used to determine the
115 constantness of the FORM in ENVIRONMENT."
116 (%constant-form-value form environment envp))
118 (declaim (inline constant-typep))
119 (defun constant-typep (form type &optional (environment nil envp))
120 (and (%constantp form environment envp)
121 ;; FIXME: We probably should be passing the environment to
122 ;; TYPEP too, but (1) our XC version of typep AVERs that the
123 ;; environment is null (2) our real version ignores it anyhow.
124 (sb!xc:typep (%constant-form-value form environment envp) type)))
128 ;;;; If you add new special forms, check that they do not
129 ;;;; alter the logic of existing ones: eg, currently
130 ;;;; CONSTANT-FORM-VALUE directly evaluates the last expression
131 ;;;; of a PROGN, as no assignment is allowed. If you extend
132 ;;;; analysis to assignments then other forms must take this
135 (defmacro defconstantp (operator lambda-list &key test eval)
136 (with-unique-names (form environment envp)
138 `(flet ((constantp* (x)
139 (%constantp x ,environment ,envp))
140 (constant-form-value* (x)
141 (%constant-form-value x ,environment ,envp)))
142 (declare (ignorable #'constantp* #'constant-form-value*))
143 (destructuring-bind ,lambda-list (cdr ,form)
144 ;; KLUDGE: is all we need, so we keep it simple
145 ;; instead of general (not handling cases like &key (x y))
147 ,@(remove-if (lambda (arg)
148 (member arg lambda-list-keywords))
152 (setf (gethash ',operator *special-form-constantp-funs*)
153 (lambda (,form ,environment ,envp)
155 (setf (gethash ',operator *special-form-constant-form-value-funs*)
156 (lambda (,form ,environment ,envp)
160 (defconstantp quote (value)
164 (defconstantp if (test then &optional else)
166 (and (constantp* test)
167 (constantp* (if (constant-form-value* test)
170 :eval (if (constant-form-value* test)
171 (constant-form-value* then)
172 (constant-form-value* else)))
174 (defconstantp progn (&body forms)
175 :test (every #'constantp* forms)
176 :eval (constant-form-value* (car (last forms))))
178 (defconstantp unwind-protect (protected-form &body cleanup-forms)
179 :test (every #'constantp* (cons protected-form cleanup-forms))
180 :eval (constant-form-value* protected-form))
182 (defconstantp the (type form)
183 :test (and (constantp* form)
185 ;; in case the type-spec is malformed!
186 (typep (constant-form-value* form) type)
188 :eval (constant-form-value* form))
190 (defconstantp block (name &body forms)
191 ;; We currently fail to detect cases like
194 ;; ...CONSTANT-FORMS...
195 ;; (RETURN-FROM FOO CONSTANT-VALUE)
198 ;; Right now RETURN-FROM kills the constantness unequivocally.
199 :test (every #'constantp* forms)
200 :eval (constant-form-value* (car (last forms))))
202 (defconstantp multiple-value-prog1 (first-form &body forms)
203 :test (every #'constantp* (cons first-form forms))
204 :eval (constant-form-value* first-form))
206 (defconstantp progv (symbols values &body forms)
207 :test (and (constantp* symbols)
209 (let* ((symbol-values (constant-form-value* symbols))
210 (*special-constant-variables*
211 (append symbol-values *special-constant-variables*)))
214 (constant-form-value* values)
215 (every #'constantp* forms))))
217 (constant-form-value* symbols)
218 (constant-form-value* values)
219 (constant-form-value* (car (last forms))))))
221 (!defun-from-collected-cold-init-forms !constantp-cold-init)