1 ;;;; This file contains code which knows about both the type
2 ;;;; representation and the compiler IR1 representation. This stuff is
3 ;;;; used for doing type checking.
5 ;;;; This software is part of the SBCL system. See the README file for
8 ;;;; This software is derived from the CMU CL system, which was
9 ;;;; written at Carnegie Mellon University and released into the
10 ;;;; public domain. The software is in the public domain and is
11 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
12 ;;;; files for more information.
16 ;;; These are the functions that are to be called when a problem is
17 ;;; detected. They are passed format arguments. If null, we don't do
18 ;;; anything. The error function is called when something is
19 ;;; definitely incorrect. The warning function is called when it is
20 ;;; somehow impossible to tell whether the call is correct.
21 (defvar *error-function*)
22 (defvar *warning-function*)
24 ;;; The function that we use for type checking. The derived type is
25 ;;; the first argument and the type we are testing against is the
26 ;;; second argument. The function should return values like CSUBTYPEP.
27 (defvar *test-function*)
28 ;;; FIXME: Why is this a variable? Explain.
30 (declaim (type (or function null) *error-function* *warning-function
33 ;;; *LOSSAGE-DETECTED* is set when a definite incompatibility is
34 ;;; detected. *SLIME-DETECTED* is set when we can't tell whether the
35 ;;; call is compatible or not.
36 (defvar *lossage-detected*)
37 (defvar *slime-detected*)
38 ;;; FIXME: SLIME is vivid and concise, but "DEFINITE-CALL-LOSSAGE" and
39 ;;; "POSSIBLE-CALL-LOSSAGE" would be more mnemonic.
41 ;;; Signal a warning if appropriate and set *LOSSAGE-DETECTED*.
42 (declaim (ftype (function (string &rest t) (values)) note-lossage note-slime))
43 (defun note-lossage (format-string &rest format-args)
44 (setq *lossage-detected* t)
45 (when *error-function*
46 (apply *error-function* format-string format-args))
48 (defun note-slime (format-string &rest format-args)
49 (setq *slime-detected* t)
50 (when *warning-function*
51 (apply *warning-function* format-string format-args))
54 (declaim (special *compiler-error-context*))
56 ;;;; stuff for checking a call against a function type
58 ;;;; FIXME: This is stuff to look at when I get around to fixing
59 ;;;; function type inference and declarations.
61 ;;; A dummy version of SUBTYPEP useful when we want a functional like
62 ;;; subtypep that always returns true.
63 (defun always-subtypep (type1 type2)
64 (declare (ignore type1 type2))
67 ;;; Determine whether a use of a function is consistent with its type.
68 ;;; These values are returned:
69 ;;; T, T: the call is definitely valid.
70 ;;; NIL, T: the call is definitely invalid.
71 ;;; NIL, NIL: unable to determine whether the call is valid.
73 ;;; The Argument-Test function is used to determine whether an
74 ;;; argument type matches the type we are checking against. Similarly,
75 ;;; the Result-Test is used to determine whether the result type
76 ;;; matches the specified result.
78 ;;; Unlike the argument test, the result test may be called on values
79 ;;; or function types. If Strict-Result is true and safety is
80 ;;; non-zero, then the Node-Derived-Type is always used. Otherwise, if
81 ;;; Cont's Type-Check is true, then the Node-Derived-Type is
82 ;;; intersected with the Cont's Asserted-Type.
84 ;;; The error and warning functions are functions that are called to
85 ;;; explain the result. We bind *compiler-error-context* to the
86 ;;; combination node so that Compiler-Warning and related functions
87 ;;; will do the right thing if they are supplied.
88 (defun valid-function-use (call type &key
89 ((:argument-test *test-function*) #'csubtypep)
90 (result-test #'values-subtypep)
92 ((:error-function *error-function*))
93 ((:warning-function *warning-function*)))
94 (declare (type function result-test) (type combination call)
95 (type function-type type))
96 (let* ((*lossage-detected* nil)
97 (*slime-detected* nil)
98 (*compiler-error-context* call)
99 (args (combination-args call))
100 (nargs (length args))
101 (required (function-type-required type))
102 (min-args (length required))
103 (optional (function-type-optional type))
104 (max-args (+ min-args (length optional)))
105 (rest (function-type-rest type))
106 (keyp (function-type-keyp type)))
109 ((function-type-wild-args type)
111 (arg args (cdr arg)))
113 (check-arg-type (car arg) *wild-type* i)))
114 ((not (or optional keyp rest))
115 (if (/= nargs min-args)
117 "The function was called with ~R argument~:P, but wants exactly ~R."
119 (check-fixed-and-rest args required nil)))
122 "The function was called with ~R argument~:P, but wants at least ~R."
125 (check-fixed-and-rest args (append required optional) rest))
126 ((not (or keyp rest))
128 "The function was called with ~R argument~:P, but wants at most ~R."
130 ((and keyp (oddp (- nargs max-args)))
132 "The function has an odd number of arguments in the keyword portion."))
134 (check-fixed-and-rest args (append required optional) rest)
136 (check-keywords args max-args type))))
138 (let* ((dtype (node-derived-type call))
139 (return-type (function-type-returns type))
140 (cont (node-cont call))
142 (if (or (not (continuation-type-check cont))
143 (and strict-result (policy call (/= safety 0))))
145 (values-type-intersection (continuation-asserted-type cont)
147 (multiple-value-bind (int win) (funcall result-test out-type return-type)
149 (note-slime "can't tell whether the result is a ~S"
150 (type-specifier return-type)))
152 (note-lossage "The result is a ~S, not a ~S."
153 (type-specifier out-type)
154 (type-specifier return-type))))))
156 (cond (*lossage-detected* (values nil t))
157 (*slime-detected* (values nil nil))
160 ;;; Check that the derived type of the continuation Cont is compatible
161 ;;; with Type. N is the arg number, for error message purposes. We
162 ;;; return true if arg is definitely o.k. If the type is a magic
163 ;;; CONSTANT-TYPE, then we check for the argument being a constant
164 ;;; value of the specified type. If there is a manifest type error
165 ;;; (DERIVED-TYPE = NIL), then we flame about the asserted type even
166 ;;; when our type is satisfied under the test.
167 (defun check-arg-type (cont type n)
168 (declare (type continuation cont) (type ctype type) (type index n))
170 ((not (constant-type-p type))
171 (let ((ctype (continuation-type cont)))
172 (multiple-value-bind (int win) (funcall *test-function* ctype type)
174 (note-slime "can't tell whether the ~:R argument is a ~S" n
175 (type-specifier type))
178 (note-lossage "The ~:R argument is a ~S, not a ~S." n
179 (type-specifier ctype)
180 (type-specifier type))
182 ((eq ctype *empty-type*)
183 (note-slime "The ~:R argument never returns a value." n)
186 ((not (constant-continuation-p cont))
187 (note-slime "The ~:R argument is not a constant." n)
190 (let ((val (continuation-value cont))
191 (type (constant-type-type type)))
192 (multiple-value-bind (res win) (ctypep val type)
194 (note-slime "can't tell whether the ~:R argument is a ~
196 n (type-specifier type) val)
199 (note-lossage "The ~:R argument is not a constant ~S:~% ~S"
200 n (type-specifier type) val)
204 ;;; Check that each of the type of each supplied argument intersects
205 ;;; with the type specified for that argument. If we can't tell, then
206 ;;; we complain about the slime.
207 (declaim (ftype (function (list list (or ctype null)) (values)) check-fixed-and-rest))
208 (defun check-fixed-and-rest (args types rest)
209 (do ((arg args (cdr arg))
210 (type types (cdr type))
212 ((or (null type) (null arg))
215 (check-arg-type arg rest n)
218 (check-arg-type (car arg) (car type) n))
221 ;;; Check that the keyword args are of the correct type. Each keyword
222 ;;; should be known and the corresponding argument should be of the
223 ;;; correct type. If the keyword isn't a constant, then we can't tell,
224 ;;; so we note slime.
225 (declaim (ftype (function (list fixnum function-type) (values)) check-keywords))
226 (defun check-keywords (args pre-key type)
227 (do ((key (nthcdr pre-key args) (cddr key))
228 (n (1+ pre-key) (+ n 2)))
233 ((not (check-arg-type k (specifier-type 'symbol) n)))
234 ((not (constant-continuation-p k))
235 (note-slime "The ~:R argument (in keyword position) is not a constant."
238 (let* ((name (continuation-value k))
239 (info (find name (function-type-keywords type)
240 :key #'key-info-name)))
242 (unless (function-type-allowp type)
243 (note-lossage "~S is not a known argument keyword."
246 (check-arg-type (second key) (key-info-type info)
250 ;;; Construct a function type from a definition.
252 ;;; Due to the lack of a (LIST X) type specifier, we can't reconstruct
254 (declaim (ftype (function (functional) function-type) definition-type))
255 (defun definition-type (functional)
256 (if (lambda-p functional)
258 :required (mapcar #'leaf-type (lambda-vars functional))
259 :returns (tail-set-type (lambda-tail-set functional)))
264 (dolist (arg (optional-dispatch-arglist functional))
265 (let ((info (lambda-var-arg-info arg))
266 (type (leaf-type arg)))
268 (ecase (arg-info-kind info)
269 (:required (req type))
270 (:optional (opt type))
272 (keys (make-key-info :name (arg-info-keyword info)
274 ((:rest :more-context)
275 (setq rest *universal-type*))
284 :keyp (optional-dispatch-keyp functional)
285 :allowp (optional-dispatch-allowp functional)
286 :returns (tail-set-type
288 (optional-dispatch-main-entry functional))))))))
290 ;;;; approximate function types
292 ;;;; FIXME: This is stuff to look at when I get around to fixing function
293 ;;;; type inference and declarations.
295 ;;;; Approximate function types provide a condensed representation of all the
296 ;;;; different ways that a function has been used. If we have no declared or
297 ;;;; defined type for a function, then we build an approximate function type by
298 ;;;; examining each use of the function. When we encounter a definition or
299 ;;;; proclamation, we can check the actual type for compatibity with the
302 (defstruct (approximate-function-type)
303 ;; The smallest and largest numbers of arguments that this function has been
305 (min-args call-arguments-limit :type fixnum)
306 (max-args 0 :type fixnum)
307 ;; A list of lists of the all the types that have been used in each argument
309 (types () :type list)
310 ;; A list of the Approximate-Key-Info structures describing all the things
311 ;; that looked like keyword arguments. There are distinct structures
312 ;; describing each argument position in which the keyword appeared.
313 (keys () :type list))
315 (defstruct (approximate-key-info)
316 ;; The keyword name of this argument. Although keyword names don't have to
317 ;; be keywords, we only match on keywords when figuring an approximate type.
318 (name (required-argument) :type keyword)
319 ;; The position at which this keyword appeared. 0 if it appeared as the
320 ;; first argument, etc.
321 (position (required-argument) :type fixnum)
322 ;; A list of all the argument types that have been used with this keyword.
323 (types nil :type list)
324 ;; True if this keyword has appeared only in calls with an obvious
325 ;; :allow-other-keys.
326 (allowp nil :type (member t nil)))
328 ;;; Return an Approximate-Function-Type representing the context of
329 ;;; Call. If Type is supplied and not null, then we merge the
330 ;;; information into the information already accumulated in Type.
331 (declaim (ftype (function (combination
332 &optional (or approximate-function-type null))
333 approximate-function-type)
335 (defun note-function-use (call &optional type)
336 (let* ((type (or type (make-approximate-function-type)))
337 (types (approximate-function-type-types type))
338 (args (combination-args call))
339 (nargs (length args))
340 (allowp (some #'(lambda (x)
341 (and (constant-continuation-p x)
342 (eq (continuation-value x) :allow-other-keys)))
345 (setf (approximate-function-type-min-args type)
346 (min (approximate-function-type-min-args type) nargs))
347 (setf (approximate-function-type-max-args type)
348 (max (approximate-function-type-max-args type) nargs))
350 (do ((old types (cdr old))
351 (arg args (cdr arg)))
353 (setf (approximate-function-type-types type)
355 (mapcar #'(lambda (x)
356 (list (continuation-type x)))
358 (when (null arg) (return))
359 (pushnew (continuation-type (car arg))
363 (collect ((keys (approximate-function-type-keys type) cons))
364 (do ((arg args (cdr arg))
366 ((or (null arg) (null (cdr arg)))
367 (setf (approximate-function-type-keys type) (keys)))
368 (let ((key (first arg))
370 (when (constant-continuation-p key)
371 (let ((name (continuation-value key)))
372 (when (keywordp name)
375 (and (eq (approximate-key-info-name x) name)
376 (= (approximate-key-info-position x)
379 (val-type (continuation-type val)))
382 (approximate-key-info-types old)
385 (setf (approximate-key-info-allowp old) nil)))
387 (keys (make-approximate-key-info
391 :types (list val-type))))))))))))
394 ;;; Similar to Valid-Function-Use, but checks an
395 ;;; Approximate-Function-Type against a real function type.
396 (declaim (ftype (function (approximate-function-type function-type
397 &optional function function function)
398 (values boolean boolean))
399 valid-approximate-type))
400 (defun valid-approximate-type (call-type type &optional
401 (*test-function* #'types-intersect)
402 (*error-function* #'compiler-warning)
403 (*warning-function* #'compiler-note))
404 (let* ((*lossage-detected* nil)
405 (*slime-detected* nil)
406 (required (function-type-required type))
407 (min-args (length required))
408 (optional (function-type-optional type))
409 (max-args (+ min-args (length optional)))
410 (rest (function-type-rest type))
411 (keyp (function-type-keyp type)))
413 (when (function-type-wild-args type)
414 (return-from valid-approximate-type (values t t)))
416 (let ((call-min (approximate-function-type-min-args call-type)))
417 (when (< call-min min-args)
419 "Function previously called with ~R argument~:P, but wants at least ~R."
422 (let ((call-max (approximate-function-type-max-args call-type)))
423 (cond ((<= call-max max-args))
424 ((not (or keyp rest))
426 "Function previously called with ~R argument~:P, but wants at most ~R."
428 ((and keyp (oddp (- call-max max-args)))
430 "Function previously called with an odd number of arguments in ~
431 the keyword portion.")))
433 (when (and keyp (> call-max max-args))
434 (check-approximate-keywords call-type max-args type)))
436 (check-approximate-fixed-and-rest call-type (append required optional)
439 (cond (*lossage-detected* (values nil t))
440 (*slime-detected* (values nil nil))
443 ;;; Check that each of the types used at each arg position is
444 ;;; compatible with the actual type.
445 (declaim (ftype (function (approximate-function-type list (or ctype null))
447 check-approximate-fixed-and-rest))
448 (defun check-approximate-fixed-and-rest (call-type fixed rest)
449 (do ((types (approximate-function-type-types call-type) (cdr types))
451 (arg fixed (cdr arg)))
453 (let ((decl-type (or (car arg) rest)))
454 (unless decl-type (return))
455 (check-approximate-arg-type (car types) decl-type "~:R" n)))
458 ;;; Check that each of the call-types is compatible with Decl-Type,
459 ;;; complaining if not or if we can't tell.
460 (declaim (ftype (function (list ctype string &rest t) (values))
461 check-approximate-arg-type))
462 (defun check-approximate-arg-type (call-types decl-type context &rest args)
463 (let ((losers *empty-type*))
464 (dolist (ctype call-types)
465 (multiple-value-bind (int win) (funcall *test-function* ctype decl-type)
468 (note-slime "can't tell whether previous ~? argument type ~S is a ~S"
469 context args (type-specifier ctype) (type-specifier decl-type)))
471 (setq losers (type-union ctype losers))))))
473 (unless (eq losers *empty-type*)
474 (note-lossage "~:(~?~) argument should be a ~S but was a ~S in a previous call."
475 context args (type-specifier decl-type) (type-specifier losers))))
478 ;;; Check the types of each manifest keyword that appears in a keyword
479 ;;; argument position. Check the validity of all keys that appeared in
480 ;;; valid keyword positions.
482 ;;; ### We could check the Approximate-Function-Type-Types to make
483 ;;; sure that all arguments in keyword positions were manifest
485 (defun check-approximate-keywords (call-type max-args type)
486 (let ((call-keys (approximate-function-type-keys call-type))
487 (keys (function-type-keywords type)))
489 (let ((name (key-info-name key)))
490 (collect ((types nil append))
491 (dolist (call-key call-keys)
492 (let ((pos (approximate-key-info-position call-key)))
493 (when (and (eq (approximate-key-info-name call-key) name)
494 (> pos max-args) (evenp (- pos max-args)))
495 (types (approximate-key-info-types call-key)))))
496 (check-approximate-arg-type (types) (key-info-type key) "~S" name))))
498 (unless (function-type-allowp type)
499 (collect ((names () adjoin))
500 (dolist (call-key call-keys)
501 (let ((pos (approximate-key-info-position call-key)))
502 (when (and (> pos max-args) (evenp (- pos max-args))
503 (not (approximate-key-info-allowp call-key)))
504 (names (approximate-key-info-name call-key)))))
506 (dolist (name (names))
507 (unless (find name keys :key #'key-info-name)
508 (note-lossage "Function previously called with unknown argument keyword ~S."
511 ;;;; ASSERT-DEFINITION-TYPE
513 ;;; Intersect Lambda's var types with Types, giving a warning if there
514 ;;; is a mismatch. If all intersections are non-null, we return lists
515 ;;; of the variables and intersections, otherwise we return NIL, NIL.
516 (defun try-type-intersections (vars types where)
517 (declare (list vars types) (string where))
519 (mapc #'(lambda (var type)
520 (let* ((vtype (leaf-type var))
521 (int (type-intersection vtype type)))
523 ((eq int *empty-type*)
525 "Definition's declared type for variable ~A:~% ~S~@
526 conflicts with this type from ~A:~% ~S"
527 (leaf-name var) (type-specifier vtype)
528 where (type-specifier type))
529 (return-from try-type-intersections (values nil nil)))
533 (values vars (res))))
535 ;;; Check that the optional-dispatch OD conforms to Type. We return
536 ;;; the values of TRY-TYPE-INTERSECTIONS if there are no syntax
537 ;;; problems, otherwise NIL, NIL.
539 ;;; Note that the variables in the returned list are the actual
540 ;;; original variables (extracted from the optional dispatch arglist),
541 ;;; rather than the variables that are arguments to the main entry.
542 ;;; This difference is significant only for keyword args with hairy
543 ;;; defaults. Returning the actual vars allows us to use the right
544 ;;; variable name in warnings.
546 ;;; A slightly subtle point: with keywords and optionals, the type in
547 ;;; the function type is only an assertion on calls --- it doesn't
548 ;;; constrain the type of default values. So we have to union in the
549 ;;; type of the default. With optionals, we can't do any assertion
550 ;;; unless the default is constant.
552 ;;; With keywords, we exploit our knowledge about how hairy keyword
553 ;;; defaulting is done when computing the type assertion to put on the
554 ;;; main-entry argument. In the case of hairy keywords, the default
555 ;;; has been clobbered with NIL, which is the value of the main-entry
556 ;;; arg in the unsupplied case, whatever the actual default value is.
557 ;;; So we can just assume the default is constant, effectively
558 ;;; unioning in NULL, and not totally blow off doing any type
560 (defun find-optional-dispatch-types (od type where)
561 (declare (type optional-dispatch od) (type function-type type)
563 (let* ((min (optional-dispatch-min-args od))
564 (req (function-type-required type))
565 (opt (function-type-optional type)))
566 (flet ((frob (x y what)
569 "Definition has ~R ~A arg~P, but ~A has ~R."
571 (frob min (length req) "fixed")
572 (frob (- (optional-dispatch-max-args od) min) (length opt) "optional"))
573 (flet ((frob (x y what)
576 "Definition ~:[doesn't have~;has~] ~A, but ~
577 ~A ~:[doesn't~;does~]."
579 (frob (optional-dispatch-keyp od) (function-type-keyp type)
581 (unless (optional-dispatch-keyp od)
582 (frob (not (null (optional-dispatch-more-entry od)))
583 (not (null (function-type-rest type)))
585 (frob (optional-dispatch-allowp od) (function-type-allowp type)
586 "&allow-other-keys"))
588 (when *lossage-detected*
589 (return-from find-optional-dispatch-types (values nil nil)))
593 (let ((keys (function-type-keywords type))
594 (arglist (optional-dispatch-arglist od)))
595 (dolist (arg arglist)
597 ((lambda-var-arg-info arg)
598 (let* ((info (lambda-var-arg-info arg))
599 (default (arg-info-default info))
600 (def-type (when (constantp default)
601 (ctype-of (eval default)))))
602 (ecase (arg-info-kind info)
604 (let* ((key (arg-info-keyword info))
605 (kinfo (find key keys :key #'key-info-name)))
608 (res (type-union (key-info-type kinfo)
609 (or def-type (specifier-type 'null)))))
612 "Defining a ~S keyword not present in ~A."
614 (res *universal-type*)))))
615 (:required (res (pop req)))
617 (res (type-union (pop opt) (or def-type *universal-type*))))
619 (when (function-type-rest type)
620 (res (specifier-type 'list))))
622 (when (function-type-rest type)
623 (res *universal-type*)))
625 (when (function-type-rest type)
626 (res (specifier-type 'fixnum)))))
628 (when (arg-info-supplied-p info)
629 (res *universal-type*)
630 (vars (arg-info-supplied-p info)))))
636 (unless (find (key-info-name key) arglist
638 (let ((info (lambda-var-arg-info x)))
640 (arg-info-keyword info)))))
642 "Definition lacks the ~S keyword present in ~A."
643 (key-info-name key) where))))
645 (try-type-intersections (vars) (res) where))))
647 ;;; Check that Type doesn't specify any funny args, and do the
649 (defun find-lambda-types (lambda type where)
650 (declare (type clambda lambda) (type function-type type) (string where))
651 (flet ((frob (x what)
654 "Definition has no ~A, but the ~A did."
656 (frob (function-type-optional type) "optional args")
657 (frob (function-type-keyp type) "keyword args")
658 (frob (function-type-rest type) "rest arg"))
659 (let* ((vars (lambda-vars lambda))
660 (nvars (length vars))
661 (req (function-type-required type))
663 (unless (= nvars nreq)
664 (note-lossage "Definition has ~R arg~:P, but the ~A has ~R."
666 (if *lossage-detected*
668 (try-type-intersections vars req where))))
670 ;;; Check for syntactic and type conformance between the definition
671 ;;; Functional and the specified Function-Type. If they are compatible
672 ;;; and Really-Assert is T, then add type assertions to the definition
673 ;;; from the Function-Type.
675 ;;; If there is a syntactic or type problem, then we call
676 ;;; Error-Function with an error message using Where as context
677 ;;; describing where Function-Type came from.
679 ;;; If there is no problem, we return T (even if Really-Assert was
680 ;;; false). If there was a problem, we return NIL.
681 (defun assert-definition-type
682 (functional type &key (really-assert t)
683 ((:error-function *error-function*) #'compiler-warning)
685 (where "previous declaration"))
686 (declare (type functional functional)
687 (type function *error-function*)
689 (unless (function-type-p type) (return-from assert-definition-type t))
690 (let ((*lossage-detected* nil))
691 (multiple-value-bind (vars types)
692 (if (function-type-wild-args type)
694 (etypecase functional
696 (find-optional-dispatch-types functional type where))
698 (find-lambda-types functional type where))))
699 (let* ((type-returns (function-type-returns type))
700 (return (lambda-return (main-entry functional)))
702 (continuation-asserted-type (return-result return)))))
704 ((and atype (not (values-types-intersect atype type-returns)))
706 "The result type from ~A:~% ~S~@
707 conflicts with the definition's result type assertion:~% ~S"
708 where (type-specifier type-returns) (type-specifier atype))
710 (*lossage-detected* nil)
711 ((not really-assert) t)
714 (assert-continuation-type (return-result return) atype))
715 (loop for var in vars and type in types do
716 (cond ((basic-var-sets var)
717 (when (and warning-function
718 (not (csubtypep (leaf-type var) type)))
719 (funcall warning-function
720 "Assignment to argument: ~S~% ~
721 prevents use of assertion from function ~
723 (leaf-name var) where (type-specifier type))))
725 (setf (leaf-type var) type)
726 (dolist (ref (leaf-refs var))
727 (derive-node-type ref type)))))