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.
14 ;;;; FIXME: This is a poor name for this file, since CTYPE is the name
15 ;;;; of the type used internally to represent Lisp types. It'd
16 ;;;; probably be good to rename this file to "call-type.lisp" or
17 ;;;; "ir1-type.lisp" or something.
21 (declaim (type (or function null) *lossage-fun* *unwinnage-fun* *ctype-test-fun*))
23 ;;; These are the functions that are to be called when a problem is
24 ;;; detected. They are passed format arguments. If null, we don't do
25 ;;; anything. The LOSSAGE function is called when something is
26 ;;; definitely incorrect. The UNWINNAGE function is called when it is
27 ;;; somehow impossible to tell whether the call is correct. (Thus,
28 ;;; they should correspond fairly closely to the FAILURE-P and WARNINGS-P
29 ;;; return values of CL:COMPILE and CL:COMPILE-FILE. However, see the
30 ;;; KLUDGE note below for *LOSSAGE-DETECTED*.)
31 (defvar *lossage-fun*)
32 (defvar *unwinnage-fun*)
34 ;;; the function that we use for type checking. The derived type is
35 ;;; its first argument and the type we are testing against is its
36 ;;; second argument. The function should return values like CSUBTYPEP.
37 (defvar *ctype-test-fun*)
38 ;;; FIXME: Why is this a variable? Explain.
40 ;;; *LOSSAGE-DETECTED* is set when a "definite incompatibility" is
41 ;;; detected. *UNWINNAGE-DETECTED* is set when we can't tell whether the
42 ;;; call is compatible or not. Thus, they should correspond very closely
43 ;;; to the FAILURE-P and WARNINGS-P return values of CL:COMPILE and
44 ;;; CL:COMPILE-FILE.) However...
46 ;;; KLUDGE: Common Lisp is a dynamic language, even if CMU CL was not.
47 ;;; As far as I can see, none of the "definite incompatibilities"
48 ;;; detected in this file are actually definite under the ANSI spec.
49 ;;; They would be incompatibilites if the use were within the same
50 ;;; compilation unit as the contradictory definition (as per the spec
51 ;;; section "3.2.2.3 Semantic Constraints") but the old Python code
52 ;;; doesn't keep track of whether that's the case. So until/unless we
53 ;;; upgrade the code to keep track of that, we have to handle all
54 ;;; these as STYLE-WARNINGs. -- WHN 2001-02-10
55 (defvar *lossage-detected*)
56 (defvar *unwinnage-detected*)
58 ;;; Signal a warning if appropriate and set *FOO-DETECTED*.
59 (declaim (ftype (function (string &rest t) (values)) note-lossage note-unwinnage))
60 (defun note-lossage (format-string &rest format-args)
61 (setq *lossage-detected* t)
63 (apply *lossage-fun* format-string format-args))
65 (defun note-unwinnage (format-string &rest format-args)
66 (setq *unwinnage-detected* t)
68 (apply *unwinnage-fun* format-string format-args))
71 (declaim (special *compiler-error-context*))
73 ;;;; stuff for checking a call against a function type
75 ;;;; FIXME: This is stuff to look at when I get around to fixing
76 ;;;; function type inference and declarations.
78 ;;; A dummy version of SUBTYPEP useful when we want a functional like
79 ;;; SUBTYPEP that always returns true.
80 (defun always-subtypep (type1 type2)
81 (declare (ignore type1 type2))
84 ;;; Determine whether a use of a function is consistent with its type.
85 ;;; These values are returned:
86 ;;; T, T: the call is definitely valid.
87 ;;; NIL, T: the call is definitely invalid.
88 ;;; NIL, NIL: unable to determine whether the call is valid.
90 ;;; The ARGUMENT-TEST function is used to determine whether an
91 ;;; argument type matches the type we are checking against. Similarly,
92 ;;; the RESULT-TEST is used to determine whether the result type
93 ;;; matches the specified result.
95 ;;; Unlike the argument test, the result test may be called on values
96 ;;; or function types. NODE-DERIVED-TYPE is intersected with the
97 ;;; trusted asserted type.
99 ;;; The error and warning functions are functions that are called to
100 ;;; explain the result. We bind *COMPILER-ERROR-CONTEXT* to the
101 ;;; combination node so that COMPILER-WARNING and related functions
102 ;;; will do the right thing if they are supplied.
103 (defun valid-fun-use (call type &key
104 ((:argument-test *ctype-test-fun*) #'csubtypep)
105 (result-test #'values-subtypep)
106 ((:lossage-fun *lossage-fun*))
107 ((:unwinnage-fun *unwinnage-fun*)))
108 (declare (type (or function null) result-test) (type combination call)
109 ;; FIXME: Could TYPE here actually be something like
110 ;; (AND GENERIC-FUNCTION (FUNCTION (T) T))? How
111 ;; horrible... -- CSR, 2003-05-03
113 (let* ((*lossage-detected* nil)
114 (*unwinnage-detected* nil)
115 (*compiler-error-context* call)
116 (args (combination-args call)))
117 (if (fun-type-p type)
118 (let* ((nargs (length args))
119 (required (fun-type-required type))
120 (min-args (length required))
121 (optional (fun-type-optional type))
122 (max-args (+ min-args (length optional)))
123 (rest (fun-type-rest type))
124 (keyp (fun-type-keyp type)))
126 ((fun-type-wild-args type)
127 (loop for arg in args
129 do (check-arg-type arg *universal-type* i)))
130 ((not (or optional keyp rest))
131 (if (/= nargs min-args)
133 "The function was called with ~R argument~:P, but wants exactly ~R."
135 (check-fixed-and-rest args required nil)))
138 "The function was called with ~R argument~:P, but wants at least ~R."
141 (check-fixed-and-rest args (append required optional) rest))
142 ((not (or keyp rest))
144 "The function was called with ~R argument~:P, but wants at most ~R."
146 ((and keyp (oddp (- nargs max-args)))
148 "The function has an odd number of arguments in the keyword portion."))
150 (check-fixed-and-rest args (append required optional) rest)
152 (check-key-args args max-args type))))
155 (let* ((dtype (node-derived-type call))
157 (binding* ((lvar (node-lvar call) :exit-if-null)
158 (dest (lvar-dest lvar)))
159 (when (and (cast-p dest)
160 (eq (cast-type-to-check dest) *wild-type*)
161 (immediately-used-p lvar call))
162 (values-type-intersection
163 dtype (cast-asserted-type dest))))
165 (return-type (fun-type-returns type)))
166 (multiple-value-bind (int win) (funcall result-test out-type return-type)
168 (note-unwinnage "can't tell whether the result is a ~S"
169 (type-specifier return-type)))
171 (note-lossage "The result is a ~S, not a ~S."
172 (type-specifier out-type)
173 (type-specifier return-type))))))))
174 (loop for arg in args
176 do (check-arg-type arg *wild-type* i)))
177 (cond (*lossage-detected* (values nil t))
178 (*unwinnage-detected* (values nil nil))
181 ;;; Check that the derived type of the LVAR is compatible with TYPE. N
182 ;;; is the arg number, for error message purposes. We return true if
183 ;;; arg is definitely o.k. If the type is a magic CONSTANT-TYPE, then
184 ;;; we check for the argument being a constant value of the specified
185 ;;; type. If there is a manifest type error (DERIVED-TYPE = NIL), then
186 ;;; we flame about the asserted type even when our type is satisfied
188 (defun check-arg-type (lvar type n)
189 (declare (type lvar lvar) (type ctype type) (type index n))
191 ((not (constant-type-p type))
192 (let ((ctype (lvar-type lvar)))
193 (multiple-value-bind (int win) (funcall *ctype-test-fun* ctype type)
195 (note-unwinnage "can't tell whether the ~:R argument is a ~S"
196 n (type-specifier type))
199 (note-lossage "The ~:R argument is a ~S, not a ~S."
200 n (type-specifier ctype) (type-specifier type))
202 ((eq ctype *empty-type*)
203 (note-unwinnage "The ~:R argument never returns a value." n)
206 ((not (constant-lvar-p lvar))
207 (note-unwinnage "The ~:R argument is not a constant." n)
210 (let ((val (lvar-value lvar))
211 (type (constant-type-type type)))
212 (multiple-value-bind (res win) (ctypep val type)
214 (note-unwinnage "can't tell whether the ~:R argument is a ~
216 n (type-specifier type) val)
219 (note-lossage "The ~:R argument is not a constant ~S:~% ~S"
220 n (type-specifier type) val)
224 ;;; Check that each of the type of each supplied argument intersects
225 ;;; with the type specified for that argument. If we can't tell, then
226 ;;; we can complain about the absence of manifest winnage.
227 (declaim (ftype (function (list list (or ctype null)) (values)) check-fixed-and-rest))
228 (defun check-fixed-and-rest (args types rest)
229 (do ((arg args (cdr arg))
230 (type types (cdr type))
232 ((or (null type) (null arg))
235 (check-arg-type arg rest n)
238 (check-arg-type (car arg) (car type) n))
241 ;;; Check that the &KEY args are of the correct type. Each key should
242 ;;; be known and the corresponding argument should be of the correct
243 ;;; type. If the key isn't a constant, then we can't tell, so we can
244 ;;; complain about absence of manifest winnage.
245 (declaim (ftype (function (list fixnum fun-type) (values)) check-key-args))
246 (defun check-key-args (args pre-key type)
247 (do ((key (nthcdr pre-key args) (cddr key))
248 (n (1+ pre-key) (+ n 2)))
253 ((not (check-arg-type k (specifier-type 'symbol) n)))
254 ((not (constant-lvar-p k))
255 (note-unwinnage "The ~:R argument (in keyword position) is not a ~
259 (let* ((name (lvar-value k))
260 (info (find name (fun-type-keywords type)
261 :key #'key-info-name)))
263 (unless (fun-type-allowp type)
264 (note-lossage "~S is not a known argument keyword."
267 (check-arg-type (second key) (key-info-type info)
271 ;;; Construct a function type from a definition.
273 ;;; Due to the lack of a (LIST X) type specifier, we can't reconstruct
275 (declaim (ftype (sfunction (functional) fun-type) definition-type))
276 (defun definition-type (functional)
277 (if (lambda-p functional)
279 :required (mapcar #'leaf-type (lambda-vars functional))
280 :returns (tail-set-type (lambda-tail-set functional)))
285 (dolist (arg (optional-dispatch-arglist functional))
286 (let ((info (lambda-var-arg-info arg))
287 (type (leaf-type arg)))
289 (ecase (arg-info-kind info)
290 (:required (req type))
291 (:optional (opt type))
293 (keys (make-key-info :name (arg-info-key info)
295 ((:rest :more-context)
296 (setq rest *universal-type*))
305 :keyp (optional-dispatch-keyp functional)
306 :allowp (optional-dispatch-allowp functional)
307 :returns (tail-set-type
309 (optional-dispatch-main-entry functional))))))))
311 ;;;; approximate function types
313 ;;;; FIXME: This is stuff to look at when I get around to fixing function
314 ;;;; type inference and declarations.
316 ;;;; Approximate function types provide a condensed representation of all the
317 ;;;; different ways that a function has been used. If we have no declared or
318 ;;;; defined type for a function, then we build an approximate function type by
319 ;;;; examining each use of the function. When we encounter a definition or
320 ;;;; proclamation, we can check the actual type for compatibity with the
323 (defstruct (approximate-fun-type (:copier nil))
324 ;; the smallest and largest numbers of arguments that this function
325 ;; has been called with.
326 (min-args sb!xc:call-arguments-limit :type fixnum)
327 (max-args 0 :type fixnum)
328 ;; a list of lists of the all the types that have been used in each
330 (types () :type list)
331 ;; A list of APPROXIMATE-KEY-INFO structures describing all the
332 ;; things that looked like &KEY arguments. There are distinct
333 ;; structures describing each argument position in which the keyword
335 (keys () :type list))
337 (defstruct (approximate-key-info (:copier nil))
338 ;; The keyword name of this argument. Although keyword names don't
339 ;; have to be keywords, we only match on keywords when figuring an
341 (name (missing-arg) :type keyword)
342 ;; The position at which this keyword appeared. 0 if it appeared as the
343 ;; first argument, etc.
344 (position (missing-arg) :type fixnum)
345 ;; a list of all the argument types that have been used with this keyword
346 (types nil :type list)
347 ;; true if this keyword has appeared only in calls with an obvious
349 (allowp nil :type (member t nil)))
351 ;;; Return an APPROXIMATE-FUN-TYPE representing the context of
352 ;;; CALL. If TYPE is supplied and not null, then we merge the
353 ;;; information into the information already accumulated in TYPE.
354 (declaim (ftype (function (combination
355 &optional (or approximate-fun-type null))
356 approximate-fun-type)
358 (defun note-fun-use (call &optional type)
359 (let* ((type (or type (make-approximate-fun-type)))
360 (types (approximate-fun-type-types type))
361 (args (combination-args call))
362 (nargs (length args))
363 (allowp (some (lambda (x)
364 (and (constant-lvar-p x)
365 (eq (lvar-value x) :allow-other-keys)))
368 (setf (approximate-fun-type-min-args type)
369 (min (approximate-fun-type-min-args type) nargs))
370 (setf (approximate-fun-type-max-args type)
371 (max (approximate-fun-type-max-args type) nargs))
373 (do ((old types (cdr old))
374 (arg args (cdr arg)))
376 (setf (approximate-fun-type-types type)
379 (list (lvar-type x)))
381 (when (null arg) (return))
382 (pushnew (lvar-type (car arg))
386 (collect ((keys (approximate-fun-type-keys type) cons))
387 (do ((arg args (cdr arg))
389 ((or (null arg) (null (cdr arg)))
390 (setf (approximate-fun-type-keys type) (keys)))
391 (let ((key (first arg))
393 (when (constant-lvar-p key)
394 (let ((name (lvar-value key)))
395 (when (keywordp name)
398 (and (eq (approximate-key-info-name x) name)
399 (= (approximate-key-info-position x)
402 (val-type (lvar-type val)))
405 (approximate-key-info-types old)
408 (setf (approximate-key-info-allowp old) nil)))
410 (keys (make-approximate-key-info
414 :types (list val-type))))))))))))
417 ;;; This is similar to VALID-FUN-USE, but checks an
418 ;;; APPROXIMATE-FUN-TYPE against a real function type.
419 (declaim (ftype (function (approximate-fun-type fun-type
420 &optional function function function)
421 (values boolean boolean))
422 valid-approximate-type))
423 (defun valid-approximate-type (call-type type &optional
425 #'types-equal-or-intersect)
427 #'compiler-style-warn)
428 (*unwinnage-fun* #'compiler-notify))
429 (let* ((*lossage-detected* nil)
430 (*unwinnage-detected* nil)
431 (required (fun-type-required type))
432 (min-args (length required))
433 (optional (fun-type-optional type))
434 (max-args (+ min-args (length optional)))
435 (rest (fun-type-rest type))
436 (keyp (fun-type-keyp type)))
438 (when (fun-type-wild-args type)
439 (return-from valid-approximate-type (values t t)))
441 (let ((call-min (approximate-fun-type-min-args call-type)))
442 (when (< call-min min-args)
444 "~:@<The function was previously called with ~R argument~:P, ~
445 but wants at least ~R.~:>"
448 (let ((call-max (approximate-fun-type-max-args call-type)))
449 (cond ((<= call-max max-args))
450 ((not (or keyp rest))
452 "~:@<The function was previously called with ~R argument~:P, ~
453 but wants at most ~R.~:>"
455 ((and keyp (oddp (- call-max max-args)))
457 "~:@<The function was previously called with an odd number of ~
458 arguments in the keyword portion.~:>")))
460 (when (and keyp (> call-max max-args))
461 (check-approximate-keywords call-type max-args type)))
463 (check-approximate-fixed-and-rest call-type (append required optional)
466 (cond (*lossage-detected* (values nil t))
467 (*unwinnage-detected* (values nil nil))
470 ;;; Check that each of the types used at each arg position is
471 ;;; compatible with the actual type.
472 (declaim (ftype (function (approximate-fun-type list (or ctype null))
474 check-approximate-fixed-and-rest))
475 (defun check-approximate-fixed-and-rest (call-type fixed rest)
476 (do ((types (approximate-fun-type-types call-type) (cdr types))
478 (arg fixed (cdr arg)))
480 (let ((decl-type (or (car arg) rest)))
481 (unless decl-type (return))
482 (check-approximate-arg-type (car types) decl-type "~:R" n)))
485 ;;; Check that each of the call-types is compatible with DECL-TYPE,
486 ;;; complaining if not or if we can't tell.
487 (declaim (ftype (function (list ctype string &rest t) (values))
488 check-approximate-arg-type))
489 (defun check-approximate-arg-type (call-types decl-type context &rest args)
490 (let ((losers *empty-type*))
491 (dolist (ctype call-types)
492 (multiple-value-bind (int win) (funcall *ctype-test-fun* ctype decl-type)
495 (note-unwinnage "can't tell whether previous ~? ~
496 argument type ~S is a ~S"
499 (type-specifier ctype)
500 (type-specifier decl-type)))
502 (setq losers (type-union ctype losers))))))
504 (unless (eq losers *empty-type*)
505 (note-lossage "~:(~?~) argument should be a ~S but was a ~S in a previous call."
506 context args (type-specifier decl-type) (type-specifier losers))))
509 ;;; Check the types of each manifest keyword that appears in a keyword
510 ;;; argument position. Check the validity of all keys that appeared in
511 ;;; valid keyword positions.
513 ;;; ### We could check the APPROXIMATE-FUN-TYPE-TYPES to make
514 ;;; sure that all arguments in keyword positions were manifest
516 (defun check-approximate-keywords (call-type max-args type)
517 (let ((call-keys (approximate-fun-type-keys call-type))
518 (keys (fun-type-keywords type)))
520 (let ((name (key-info-name key)))
521 (collect ((types nil append))
522 (dolist (call-key call-keys)
523 (let ((pos (approximate-key-info-position call-key)))
524 (when (and (eq (approximate-key-info-name call-key) name)
525 (> pos max-args) (evenp (- pos max-args)))
526 (types (approximate-key-info-types call-key)))))
527 (check-approximate-arg-type (types) (key-info-type key) "~S" name))))
529 (unless (fun-type-allowp type)
530 (collect ((names () adjoin))
531 (dolist (call-key call-keys)
532 (let ((pos (approximate-key-info-position call-key)))
533 (when (and (> pos max-args) (evenp (- pos max-args))
534 (not (approximate-key-info-allowp call-key)))
535 (names (approximate-key-info-name call-key)))))
537 (dolist (name (names))
538 (unless (find name keys :key #'key-info-name)
539 (note-lossage "Function previously called with unknown argument keyword ~S."
542 ;;;; ASSERT-DEFINITION-TYPE
544 ;;; Intersect LAMBDA's var types with TYPES, giving a warning if there
545 ;;; is a mismatch. If all intersections are non-null, we return lists
546 ;;; of the variables and intersections, otherwise we return NIL, NIL.
547 (defun try-type-intersections (vars types where)
548 (declare (list vars types) (string where))
550 (mapc (lambda (var type)
551 (let* ((vtype (leaf-type var))
552 (int (type-approx-intersection2 vtype type)))
554 ((eq int *empty-type*)
556 "Definition's declared type for variable ~A:~% ~S~@
557 conflicts with this type from ~A:~% ~S"
558 (leaf-debug-name var) (type-specifier vtype)
559 where (type-specifier type))
560 (return-from try-type-intersections (values nil nil)))
564 (values vars (res))))
566 ;;; Check that the optional-dispatch OD conforms to TYPE. We return
567 ;;; the values of TRY-TYPE-INTERSECTIONS if there are no syntax
568 ;;; problems, otherwise NIL, NIL.
570 ;;; Note that the variables in the returned list are the actual
571 ;;; original variables (extracted from the optional dispatch arglist),
572 ;;; rather than the variables that are arguments to the main entry.
573 ;;; This difference is significant only for &KEY args with hairy
574 ;;; defaults. Returning the actual vars allows us to use the right
575 ;;; variable name in warnings.
577 ;;; A slightly subtle point: with keywords and optionals, the type in
578 ;;; the function type is only an assertion on calls --- it doesn't
579 ;;; constrain the type of default values. So we have to union in the
580 ;;; type of the default. With optionals, we can't do any assertion
581 ;;; unless the default is constant.
583 ;;; With keywords, we exploit our knowledge about how hairy keyword
584 ;;; defaulting is done when computing the type assertion to put on the
585 ;;; main-entry argument. In the case of hairy keywords, the default
586 ;;; has been clobbered with NIL, which is the value of the main-entry
587 ;;; arg in the unsupplied case, whatever the actual default value is.
588 ;;; So we can just assume the default is constant, effectively
589 ;;; unioning in NULL, and not totally blow off doing any type
591 (defun find-optional-dispatch-types (od type where)
592 (declare (type optional-dispatch od)
595 (let* ((min (optional-dispatch-min-args od))
596 (req (fun-type-required type))
597 (opt (fun-type-optional type)))
598 (flet ((frob (x y what)
601 "The definition has ~R ~A arg~P, but ~A has ~R."
603 (frob min (length req) "fixed")
604 (frob (- (optional-dispatch-max-args od) min) (length opt) "optional"))
605 (flet ((frob (x y what)
608 "The definition ~:[doesn't have~;has~] ~A, but ~
609 ~A ~:[doesn't~;does~]."
611 (frob (optional-dispatch-keyp od) (fun-type-keyp type)
613 (unless (optional-dispatch-keyp od)
614 (frob (not (null (optional-dispatch-more-entry od)))
615 (not (null (fun-type-rest type)))
617 (frob (optional-dispatch-allowp od) (fun-type-allowp type)
618 "&ALLOW-OTHER-KEYS"))
620 (when *lossage-detected*
621 (return-from find-optional-dispatch-types (values nil nil)))
625 (let ((keys (fun-type-keywords type))
626 (arglist (optional-dispatch-arglist od)))
627 (dolist (arg arglist)
629 ((lambda-var-arg-info arg)
630 (let* ((info (lambda-var-arg-info arg))
631 (default (arg-info-default info))
632 (def-type (when (constantp default)
633 (ctype-of (eval default)))))
634 (ecase (arg-info-kind info)
636 (let* ((key (arg-info-key info))
637 (kinfo (find key keys :key #'key-info-name)))
640 (res (type-union (key-info-type kinfo)
641 (or def-type (specifier-type 'null)))))
644 "Defining a ~S keyword not present in ~A."
646 (res *universal-type*)))))
647 (:required (res (pop req)))
649 (res (type-union (pop opt) (or def-type *universal-type*))))
651 (when (fun-type-rest type)
652 (res (specifier-type 'list))))
654 (when (fun-type-rest type)
655 (res *universal-type*)))
657 (when (fun-type-rest type)
658 (res (specifier-type 'fixnum)))))
660 (when (arg-info-supplied-p info)
661 (res *universal-type*)
662 (vars (arg-info-supplied-p info)))))
668 (unless (find (key-info-name key) arglist
670 (let ((info (lambda-var-arg-info x)))
672 (arg-info-key info)))))
674 "The definition lacks the ~S key present in ~A."
675 (key-info-name key) where))))
677 (try-type-intersections (vars) (res) where))))
679 ;;; Check that TYPE doesn't specify any funny args, and do the
681 (defun find-lambda-types (lambda type where)
682 (declare (type clambda lambda) (type fun-type type) (string where))
683 (flet ((frob (x what)
686 "The definition has no ~A, but the ~A did."
688 (frob (fun-type-optional type) "&OPTIONAL arguments")
689 (frob (fun-type-keyp type) "&KEY arguments")
690 (frob (fun-type-rest type) "&REST argument"))
691 (let* ((vars (lambda-vars lambda))
692 (nvars (length vars))
693 (req (fun-type-required type))
695 (unless (= nvars nreq)
696 (note-lossage "The definition has ~R arg~:P, but the ~A has ~R."
698 (if *lossage-detected*
700 (try-type-intersections vars req where))))
702 ;;; Check for syntactic and type conformance between the definition
703 ;;; FUNCTIONAL and the specified FUN-TYPE. If they are compatible
704 ;;; and REALLY-ASSERT is T, then add type assertions to the definition
705 ;;; from the FUN-TYPE.
707 ;;; If there is a syntactic or type problem, then we call
708 ;;; LOSSAGE-FUN with an error message using WHERE as context
709 ;;; describing where FUN-TYPE came from.
711 ;;; If there is no problem, we return T (even if REALLY-ASSERT was
712 ;;; false). If there was a problem, we return NIL.
713 (defun assert-definition-type
714 (functional type &key (really-assert t)
715 ((:lossage-fun *lossage-fun*)
716 #'compiler-style-warn)
718 (where "previous declaration"))
719 (declare (type functional functional)
720 (type function *lossage-fun*)
722 (unless (fun-type-p type)
723 (return-from assert-definition-type t))
724 (let ((*lossage-detected* nil))
725 (multiple-value-bind (vars types)
726 (if (fun-type-wild-args type)
728 (etypecase functional
730 (find-optional-dispatch-types functional type where))
732 (find-lambda-types functional type where))))
733 (let* ((type-returns (fun-type-returns type))
734 (return (lambda-return (main-entry functional)))
736 (lvar-derived-type (return-result return)))))
738 ((and dtype (not (values-types-equal-or-intersect dtype
741 "The result type from ~A:~% ~S~@
742 conflicts with the definition's result type:~% ~S"
743 where (type-specifier type-returns) (type-specifier dtype))
745 (*lossage-detected* nil)
746 ((not really-assert) t)
748 (let ((policy (lexenv-policy (functional-lexenv functional))))
749 (when (policy policy (> type-check 0))
750 (assert-lvar-type (return-result return) type-returns
752 (loop for var in vars and type in types do
753 (cond ((basic-var-sets var)
754 (when (and unwinnage-fun
755 (not (csubtypep (leaf-type var) type)))
756 (funcall unwinnage-fun
757 "Assignment to argument: ~S~% ~
758 prevents use of assertion from function ~
760 (leaf-debug-name var)
762 (type-specifier type))))
764 (setf (leaf-type var) type)
765 (dolist (ref (leaf-refs var))
766 (derive-node-type ref (make-single-value-type type))))))
769 ;;; FIXME: This is quite similar to ASSERT-NEW-DEFINITION.
770 (defun assert-global-function-definition-type (name fun)
771 (declare (type functional fun))
772 (let ((type (info :function :type name))
773 (where (info :function :where-from name)))
774 (when (eq where :declared)
775 (setf (leaf-type fun) type)
776 (assert-definition-type
778 :unwinnage-fun #'compiler-notify
779 :where "proclamation"
780 :really-assert (not (awhen (info :function :info name)
781 (ir1-attributep (fun-info-attributes it)
782 explicit-check)))))))
784 ;;; Call FUN with (arg-lvar arg-type)
785 (defun map-combination-args-and-types (fun call)
786 (declare (type function fun) (type combination call))
787 (binding* ((type (lvar-type (combination-fun call)))
788 (nil (fun-type-p type) :exit-if-null)
789 (args (combination-args call)))
790 (dolist (req (fun-type-required type))
791 (when (null args) (return-from map-combination-args-and-types))
792 (let ((arg (pop args)))
793 (funcall fun arg req)))
794 (dolist (opt (fun-type-optional type))
795 (when (null args) (return-from map-combination-args-and-types))
796 (let ((arg (pop args)))
797 (funcall fun arg opt)))
799 (let ((rest (fun-type-rest type)))
802 (funcall fun arg rest))))
804 (dolist (key (fun-type-keywords type))
805 (let ((name (key-info-name key)))
806 (do ((arg args (cddr arg)))
808 (when (eq (lvar-value (first arg)) name)
809 (funcall fun (second arg) (key-info-type key))))))))
811 ;;; Assert that CALL is to a function of the specified TYPE. It is
812 ;;; assumed that the call is legal and has only constants in the
813 ;;; keyword positions.
814 (defun assert-call-type (call type)
815 (declare (type combination call) (type fun-type type))
816 (derive-node-type call (fun-type-returns type))
817 (let ((policy (lexenv-policy (node-lexenv call))))
818 (map-combination-args-and-types
820 (assert-lvar-type arg type policy))
824 ;;;; FIXME: Move to some other file.
825 (defun check-catch-tag-type (tag)
826 (declare (type lvar tag))
827 (let ((ctype (lvar-type tag)))
828 (when (csubtypep ctype (specifier-type '(or number character)))
829 (compiler-style-warn "~@<using ~S of type ~S as a catch tag (which ~
830 tends to be unportable because THROW and CATCH ~
831 use EQ comparison)~@:>"
833 (type-specifier (lvar-type tag))))))
835 (defun %compile-time-type-error (values atype dtype)
836 (declare (ignore dtype))
837 (if (and (consp atype)
838 (eq (car atype) 'values))
839 (error 'values-type-error :datum values :expected-type atype)
840 (error 'type-error :datum (car values) :expected-type atype)))
842 (defoptimizer (%compile-time-type-error ir2-convert)
843 ((objects atype dtype) node block)
844 (let ((*compiler-error-context* node))
845 (setf (node-source-path node)
846 (cdr (node-source-path node)))
847 (destructuring-bind (values atype dtype)
848 (basic-combination-args node)
849 (declare (ignore values))
850 (let ((atype (lvar-value atype))
851 (dtype (lvar-value dtype)))
852 (unless (eq atype nil)
854 "~@<Asserted type ~S conflicts with derived type ~S.~@:>"
856 (ir2-convert-full-call node block)))