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. If STRICT-RESULT is true and SAFETY is
97 ;;; non-zero, then the NODE-DERIVED-TYPE is always used. Otherwise, if
98 ;;; CONT's TYPE-CHECK is true, then the NODE-DERIVED-TYPE is
99 ;;; intersected with the CONT's ASSERTED-TYPE.
101 ;;; The error and warning functions are functions that are called to
102 ;;; explain the result. We bind *COMPILER-ERROR-CONTEXT* to the
103 ;;; combination node so that COMPILER-WARNING and related functions
104 ;;; will do the right thing if they are supplied.
105 (defun valid-fun-use (call type &key
106 ((:argument-test *ctype-test-fun*) #'csubtypep)
107 (result-test #'values-subtypep)
108 ((:lossage-fun *lossage-fun*))
109 ((:unwinnage-fun *unwinnage-fun*)))
110 (declare (type function result-test) (type combination call)
111 ;; FIXME: Could TYPE here actually be something like
112 ;; (AND GENERIC-FUNCTION (FUNCTION (T) T))? How
113 ;; horrible... -- CSR, 2003-05-03
115 (let* ((*lossage-detected* nil)
116 (*unwinnage-detected* nil)
117 (*compiler-error-context* call)
118 (args (combination-args call)))
119 (if (fun-type-p type)
120 (let* ((nargs (length args))
121 (required (fun-type-required type))
122 (min-args (length required))
123 (optional (fun-type-optional type))
124 (max-args (+ min-args (length optional)))
125 (rest (fun-type-rest type))
126 (keyp (fun-type-keyp type)))
128 ((fun-type-wild-args type)
129 (loop for arg in args
131 do (check-arg-type arg *universal-type* i)))
132 ((not (or optional keyp rest))
133 (if (/= nargs min-args)
135 "The function was called with ~R argument~:P, but wants exactly ~R."
137 (check-fixed-and-rest args required nil)))
140 "The function was called with ~R argument~:P, but wants at least ~R."
143 (check-fixed-and-rest args (append required optional) rest))
144 ((not (or keyp rest))
146 "The function was called with ~R argument~:P, but wants at most ~R."
148 ((and keyp (oddp (- nargs max-args)))
150 "The function has an odd number of arguments in the keyword portion."))
152 (check-fixed-and-rest args (append required optional) rest)
154 (check-key-args args max-args type))))
156 (let* ((dtype (node-derived-type call))
157 (return-type (fun-type-returns type))
159 (multiple-value-bind (int win) (funcall result-test out-type return-type)
161 (note-unwinnage "can't tell whether the result is a ~S"
162 (type-specifier return-type)))
164 (note-lossage "The result is a ~S, not a ~S."
165 (type-specifier out-type)
166 (type-specifier return-type)))))))
167 (loop for arg in args
169 do (check-arg-type arg *wild-type* i)))
170 (cond (*lossage-detected* (values nil t))
171 (*unwinnage-detected* (values nil nil))
174 ;;; Check that the derived type of the continuation CONT is compatible
175 ;;; with TYPE. N is the arg number, for error message purposes. We
176 ;;; return true if arg is definitely o.k. If the type is a magic
177 ;;; CONSTANT-TYPE, then we check for the argument being a constant
178 ;;; value of the specified type. If there is a manifest type error
179 ;;; (DERIVED-TYPE = NIL), then we flame about the asserted type even
180 ;;; when our type is satisfied under the test.
181 (defun check-arg-type (cont type n)
182 (declare (type continuation cont) (type ctype type) (type index n))
184 ((not (constant-type-p type))
185 (let ((ctype (continuation-type cont)))
186 (multiple-value-bind (int win) (funcall *ctype-test-fun* ctype type)
188 (note-unwinnage "can't tell whether the ~:R argument is a ~S"
189 n (type-specifier type))
192 (note-lossage "The ~:R argument is a ~S, not a ~S."
193 n (type-specifier ctype) (type-specifier type))
195 ((eq ctype *empty-type*)
196 (note-unwinnage "The ~:R argument never returns a value." n)
199 ((not (constant-continuation-p cont))
200 (note-unwinnage "The ~:R argument is not a constant." n)
203 (let ((val (continuation-value cont))
204 (type (constant-type-type type)))
205 (multiple-value-bind (res win) (ctypep val type)
207 (note-unwinnage "can't tell whether the ~:R argument is a ~
209 n (type-specifier type) val)
212 (note-lossage "The ~:R argument is not a constant ~S:~% ~S"
213 n (type-specifier type) val)
217 ;;; Check that each of the type of each supplied argument intersects
218 ;;; with the type specified for that argument. If we can't tell, then
219 ;;; we can complain about the absence of manifest winnage.
220 (declaim (ftype (function (list list (or ctype null)) (values)) check-fixed-and-rest))
221 (defun check-fixed-and-rest (args types rest)
222 (do ((arg args (cdr arg))
223 (type types (cdr type))
225 ((or (null type) (null arg))
228 (check-arg-type arg rest n)
231 (check-arg-type (car arg) (car type) n))
234 ;;; Check that the &KEY args are of the correct type. Each key should
235 ;;; be known and the corresponding argument should be of the correct
236 ;;; type. If the key isn't a constant, then we can't tell, so we can
237 ;;; complain about absence of manifest winnage.
238 (declaim (ftype (function (list fixnum fun-type) (values)) check-key-args))
239 (defun check-key-args (args pre-key type)
240 (do ((key (nthcdr pre-key args) (cddr key))
241 (n (1+ pre-key) (+ n 2)))
246 ((not (check-arg-type k (specifier-type 'symbol) n)))
247 ((not (constant-continuation-p k))
248 (note-unwinnage "The ~:R argument (in keyword position) is not a ~
252 (let* ((name (continuation-value k))
253 (info (find name (fun-type-keywords type)
254 :key #'key-info-name)))
256 (unless (fun-type-allowp type)
257 (note-lossage "~S is not a known argument keyword."
260 (check-arg-type (second key) (key-info-type info)
264 ;;; Construct a function type from a definition.
266 ;;; Due to the lack of a (LIST X) type specifier, we can't reconstruct
268 (declaim (ftype (sfunction (functional) fun-type) definition-type))
269 (defun definition-type (functional)
270 (if (lambda-p functional)
272 :required (mapcar #'leaf-type (lambda-vars functional))
273 :returns (tail-set-type (lambda-tail-set functional)))
278 (dolist (arg (optional-dispatch-arglist functional))
279 (let ((info (lambda-var-arg-info arg))
280 (type (leaf-type arg)))
282 (ecase (arg-info-kind info)
283 (:required (req type))
284 (:optional (opt type))
286 (keys (make-key-info :name (arg-info-key info)
288 ((:rest :more-context)
289 (setq rest *universal-type*))
298 :keyp (optional-dispatch-keyp functional)
299 :allowp (optional-dispatch-allowp functional)
300 :returns (tail-set-type
302 (optional-dispatch-main-entry functional))))))))
304 ;;;; approximate function types
306 ;;;; FIXME: This is stuff to look at when I get around to fixing function
307 ;;;; type inference and declarations.
309 ;;;; Approximate function types provide a condensed representation of all the
310 ;;;; different ways that a function has been used. If we have no declared or
311 ;;;; defined type for a function, then we build an approximate function type by
312 ;;;; examining each use of the function. When we encounter a definition or
313 ;;;; proclamation, we can check the actual type for compatibity with the
316 (defstruct (approximate-fun-type (:copier nil))
317 ;; the smallest and largest numbers of arguments that this function
318 ;; has been called with.
319 (min-args sb!xc:call-arguments-limit :type fixnum)
320 (max-args 0 :type fixnum)
321 ;; a list of lists of the all the types that have been used in each
323 (types () :type list)
324 ;; A list of APPROXIMATE-KEY-INFO structures describing all the
325 ;; things that looked like &KEY arguments. There are distinct
326 ;; structures describing each argument position in which the keyword
328 (keys () :type list))
330 (defstruct (approximate-key-info (:copier nil))
331 ;; The keyword name of this argument. Although keyword names don't
332 ;; have to be keywords, we only match on keywords when figuring an
334 (name (missing-arg) :type keyword)
335 ;; The position at which this keyword appeared. 0 if it appeared as the
336 ;; first argument, etc.
337 (position (missing-arg) :type fixnum)
338 ;; a list of all the argument types that have been used with this keyword
339 (types nil :type list)
340 ;; true if this keyword has appeared only in calls with an obvious
342 (allowp nil :type (member t nil)))
344 ;;; Return an APPROXIMATE-FUN-TYPE representing the context of
345 ;;; CALL. If TYPE is supplied and not null, then we merge the
346 ;;; information into the information already accumulated in TYPE.
347 (declaim (ftype (function (combination
348 &optional (or approximate-fun-type null))
349 approximate-fun-type)
351 (defun note-fun-use (call &optional type)
352 (let* ((type (or type (make-approximate-fun-type)))
353 (types (approximate-fun-type-types type))
354 (args (combination-args call))
355 (nargs (length args))
356 (allowp (some (lambda (x)
357 (and (constant-continuation-p x)
358 (eq (continuation-value x) :allow-other-keys)))
361 (setf (approximate-fun-type-min-args type)
362 (min (approximate-fun-type-min-args type) nargs))
363 (setf (approximate-fun-type-max-args type)
364 (max (approximate-fun-type-max-args type) nargs))
366 (do ((old types (cdr old))
367 (arg args (cdr arg)))
369 (setf (approximate-fun-type-types type)
372 (list (continuation-type x)))
374 (when (null arg) (return))
375 (pushnew (continuation-type (car arg))
379 (collect ((keys (approximate-fun-type-keys type) cons))
380 (do ((arg args (cdr arg))
382 ((or (null arg) (null (cdr arg)))
383 (setf (approximate-fun-type-keys type) (keys)))
384 (let ((key (first arg))
386 (when (constant-continuation-p key)
387 (let ((name (continuation-value key)))
388 (when (keywordp name)
391 (and (eq (approximate-key-info-name x) name)
392 (= (approximate-key-info-position x)
395 (val-type (continuation-type val)))
398 (approximate-key-info-types old)
401 (setf (approximate-key-info-allowp old) nil)))
403 (keys (make-approximate-key-info
407 :types (list val-type))))))))))))
410 ;;; This is similar to VALID-FUN-USE, but checks an
411 ;;; APPROXIMATE-FUN-TYPE against a real function type.
412 (declaim (ftype (function (approximate-fun-type fun-type
413 &optional function function function)
414 (values boolean boolean))
415 valid-approximate-type))
416 (defun valid-approximate-type (call-type type &optional
418 #'types-equal-or-intersect)
420 #'compiler-style-warn)
421 (*unwinnage-fun* #'compiler-note))
422 (let* ((*lossage-detected* nil)
423 (*unwinnage-detected* nil)
424 (required (fun-type-required type))
425 (min-args (length required))
426 (optional (fun-type-optional type))
427 (max-args (+ min-args (length optional)))
428 (rest (fun-type-rest type))
429 (keyp (fun-type-keyp type)))
431 (when (fun-type-wild-args type)
432 (return-from valid-approximate-type (values t t)))
434 (let ((call-min (approximate-fun-type-min-args call-type)))
435 (when (< call-min min-args)
437 "~:@<The function was previously called with ~R argument~:P, ~
438 but wants at least ~R.~:>"
441 (let ((call-max (approximate-fun-type-max-args call-type)))
442 (cond ((<= call-max max-args))
443 ((not (or keyp rest))
445 "~:@<The function was previously called with ~R argument~:P, ~
446 but wants at most ~R.~:>"
448 ((and keyp (oddp (- call-max max-args)))
450 "~:@<The function was previously called with an odd number of ~
451 arguments in the keyword portion.~:>")))
453 (when (and keyp (> call-max max-args))
454 (check-approximate-keywords call-type max-args type)))
456 (check-approximate-fixed-and-rest call-type (append required optional)
459 (cond (*lossage-detected* (values nil t))
460 (*unwinnage-detected* (values nil nil))
463 ;;; Check that each of the types used at each arg position is
464 ;;; compatible with the actual type.
465 (declaim (ftype (function (approximate-fun-type list (or ctype null))
467 check-approximate-fixed-and-rest))
468 (defun check-approximate-fixed-and-rest (call-type fixed rest)
469 (do ((types (approximate-fun-type-types call-type) (cdr types))
471 (arg fixed (cdr arg)))
473 (let ((decl-type (or (car arg) rest)))
474 (unless decl-type (return))
475 (check-approximate-arg-type (car types) decl-type "~:R" n)))
478 ;;; Check that each of the call-types is compatible with DECL-TYPE,
479 ;;; complaining if not or if we can't tell.
480 (declaim (ftype (function (list ctype string &rest t) (values))
481 check-approximate-arg-type))
482 (defun check-approximate-arg-type (call-types decl-type context &rest args)
483 (let ((losers *empty-type*))
484 (dolist (ctype call-types)
485 (multiple-value-bind (int win) (funcall *ctype-test-fun* ctype decl-type)
488 (note-unwinnage "can't tell whether previous ~? ~
489 argument type ~S is a ~S"
492 (type-specifier ctype)
493 (type-specifier decl-type)))
495 (setq losers (type-union ctype losers))))))
497 (unless (eq losers *empty-type*)
498 (note-lossage "~:(~?~) argument should be a ~S but was a ~S in a previous call."
499 context args (type-specifier decl-type) (type-specifier losers))))
502 ;;; Check the types of each manifest keyword that appears in a keyword
503 ;;; argument position. Check the validity of all keys that appeared in
504 ;;; valid keyword positions.
506 ;;; ### We could check the APPROXIMATE-FUN-TYPE-TYPES to make
507 ;;; sure that all arguments in keyword positions were manifest
509 (defun check-approximate-keywords (call-type max-args type)
510 (let ((call-keys (approximate-fun-type-keys call-type))
511 (keys (fun-type-keywords type)))
513 (let ((name (key-info-name key)))
514 (collect ((types nil append))
515 (dolist (call-key call-keys)
516 (let ((pos (approximate-key-info-position call-key)))
517 (when (and (eq (approximate-key-info-name call-key) name)
518 (> pos max-args) (evenp (- pos max-args)))
519 (types (approximate-key-info-types call-key)))))
520 (check-approximate-arg-type (types) (key-info-type key) "~S" name))))
522 (unless (fun-type-allowp type)
523 (collect ((names () adjoin))
524 (dolist (call-key call-keys)
525 (let ((pos (approximate-key-info-position call-key)))
526 (when (and (> pos max-args) (evenp (- pos max-args))
527 (not (approximate-key-info-allowp call-key)))
528 (names (approximate-key-info-name call-key)))))
530 (dolist (name (names))
531 (unless (find name keys :key #'key-info-name)
532 (note-lossage "Function previously called with unknown argument keyword ~S."
535 ;;;; ASSERT-DEFINITION-TYPE
537 ;;; Intersect LAMBDA's var types with TYPES, giving a warning if there
538 ;;; is a mismatch. If all intersections are non-null, we return lists
539 ;;; of the variables and intersections, otherwise we return NIL, NIL.
540 (defun try-type-intersections (vars types where)
541 (declare (list vars types) (string where))
543 (mapc (lambda (var type)
544 (let* ((vtype (leaf-type var))
545 (int (type-approx-intersection2 vtype type)))
547 ((eq int *empty-type*)
549 "Definition's declared type for variable ~A:~% ~S~@
550 conflicts with this type from ~A:~% ~S"
551 (leaf-debug-name var) (type-specifier vtype)
552 where (type-specifier type))
553 (return-from try-type-intersections (values nil nil)))
557 (values vars (res))))
559 ;;; Check that the optional-dispatch OD conforms to TYPE. We return
560 ;;; the values of TRY-TYPE-INTERSECTIONS if there are no syntax
561 ;;; problems, otherwise NIL, NIL.
563 ;;; Note that the variables in the returned list are the actual
564 ;;; original variables (extracted from the optional dispatch arglist),
565 ;;; rather than the variables that are arguments to the main entry.
566 ;;; This difference is significant only for &KEY args with hairy
567 ;;; defaults. Returning the actual vars allows us to use the right
568 ;;; variable name in warnings.
570 ;;; A slightly subtle point: with keywords and optionals, the type in
571 ;;; the function type is only an assertion on calls --- it doesn't
572 ;;; constrain the type of default values. So we have to union in the
573 ;;; type of the default. With optionals, we can't do any assertion
574 ;;; unless the default is constant.
576 ;;; With keywords, we exploit our knowledge about how hairy keyword
577 ;;; defaulting is done when computing the type assertion to put on the
578 ;;; main-entry argument. In the case of hairy keywords, the default
579 ;;; has been clobbered with NIL, which is the value of the main-entry
580 ;;; arg in the unsupplied case, whatever the actual default value is.
581 ;;; So we can just assume the default is constant, effectively
582 ;;; unioning in NULL, and not totally blow off doing any type
584 (defun find-optional-dispatch-types (od type where)
585 (declare (type optional-dispatch od)
588 (let* ((min (optional-dispatch-min-args od))
589 (req (fun-type-required type))
590 (opt (fun-type-optional type)))
591 (flet ((frob (x y what)
594 "The definition has ~R ~A arg~P, but ~A has ~R."
596 (frob min (length req) "fixed")
597 (frob (- (optional-dispatch-max-args od) min) (length opt) "optional"))
598 (flet ((frob (x y what)
601 "The definition ~:[doesn't have~;has~] ~A, but ~
602 ~A ~:[doesn't~;does~]."
604 (frob (optional-dispatch-keyp od) (fun-type-keyp type)
606 (unless (optional-dispatch-keyp od)
607 (frob (not (null (optional-dispatch-more-entry od)))
608 (not (null (fun-type-rest type)))
610 (frob (optional-dispatch-allowp od) (fun-type-allowp type)
611 "&ALLOW-OTHER-KEYS"))
613 (when *lossage-detected*
614 (return-from find-optional-dispatch-types (values nil nil)))
618 (let ((keys (fun-type-keywords type))
619 (arglist (optional-dispatch-arglist od)))
620 (dolist (arg arglist)
622 ((lambda-var-arg-info arg)
623 (let* ((info (lambda-var-arg-info arg))
624 (default (arg-info-default info))
625 (def-type (when (constantp default)
626 (ctype-of (eval default)))))
627 (ecase (arg-info-kind info)
629 (let* ((key (arg-info-key info))
630 (kinfo (find key keys :key #'key-info-name)))
633 (res (type-union (key-info-type kinfo)
634 (or def-type (specifier-type 'null)))))
637 "Defining a ~S keyword not present in ~A."
639 (res *universal-type*)))))
640 (:required (res (pop req)))
642 (res (type-union (pop opt) (or def-type *universal-type*))))
644 (when (fun-type-rest type)
645 (res (specifier-type 'list))))
647 (when (fun-type-rest type)
648 (res *universal-type*)))
650 (when (fun-type-rest type)
651 (res (specifier-type 'fixnum)))))
653 (when (arg-info-supplied-p info)
654 (res *universal-type*)
655 (vars (arg-info-supplied-p info)))))
661 (unless (find (key-info-name key) arglist
663 (let ((info (lambda-var-arg-info x)))
665 (arg-info-key info)))))
667 "The definition lacks the ~S key present in ~A."
668 (key-info-name key) where))))
670 (try-type-intersections (vars) (res) where))))
672 ;;; Check that TYPE doesn't specify any funny args, and do the
674 (defun find-lambda-types (lambda type where)
675 (declare (type clambda lambda) (type fun-type type) (string where))
676 (flet ((frob (x what)
679 "The definition has no ~A, but the ~A did."
681 (frob (fun-type-optional type) "&OPTIONAL arguments")
682 (frob (fun-type-keyp type) "&KEY arguments")
683 (frob (fun-type-rest type) "&REST argument"))
684 (let* ((vars (lambda-vars lambda))
685 (nvars (length vars))
686 (req (fun-type-required type))
688 (unless (= nvars nreq)
689 (note-lossage "The definition has ~R arg~:P, but the ~A has ~R."
691 (if *lossage-detected*
693 (try-type-intersections vars req where))))
695 ;;; Check for syntactic and type conformance between the definition
696 ;;; FUNCTIONAL and the specified FUN-TYPE. If they are compatible
697 ;;; and REALLY-ASSERT is T, then add type assertions to the definition
698 ;;; from the FUN-TYPE.
700 ;;; If there is a syntactic or type problem, then we call
701 ;;; LOSSAGE-FUN with an error message using WHERE as context
702 ;;; describing where FUN-TYPE came from.
704 ;;; If there is no problem, we return T (even if REALLY-ASSERT was
705 ;;; false). If there was a problem, we return NIL.
706 (defun assert-definition-type
707 (functional type &key (really-assert t)
708 ((:lossage-fun *lossage-fun*)
709 #'compiler-style-warn)
711 (where "previous declaration"))
712 (declare (type functional functional)
713 (type function *lossage-fun*)
715 (unless (fun-type-p type)
716 (return-from assert-definition-type t))
717 (let ((*lossage-detected* nil))
718 (multiple-value-bind (vars types)
719 (if (fun-type-wild-args type)
721 (etypecase functional
723 (find-optional-dispatch-types functional type where))
725 (find-lambda-types functional type where))))
726 (let* ((type-returns (fun-type-returns type))
727 (return (lambda-return (main-entry functional)))
729 (continuation-derived-type (return-result return)))))
731 ((and dtype (not (values-types-equal-or-intersect dtype
734 "The result type from ~A:~% ~S~@
735 conflicts with the definition's result type:~% ~S"
736 where (type-specifier type-returns) (type-specifier dtype))
738 (*lossage-detected* nil)
739 ((not really-assert) t)
741 (let ((policy (lexenv-policy (functional-lexenv functional))))
742 (when (policy policy (> type-check 0))
743 (assert-continuation-type (return-result return) type-returns
745 (loop for var in vars and type in types do
746 (cond ((basic-var-sets var)
747 (when (and unwinnage-fun
748 (not (csubtypep (leaf-type var) type)))
749 (funcall unwinnage-fun
750 "Assignment to argument: ~S~% ~
751 prevents use of assertion from function ~
753 (leaf-debug-name var)
755 (type-specifier type))))
757 (setf (leaf-type var) type)
758 (dolist (ref (leaf-refs var))
759 (derive-node-type ref (make-single-value-type type))))))
762 (defun assert-global-function-definition-type (name fun)
763 (declare (type functional fun))
764 (let ((type (info :function :type name))
765 (where (info :function :where-from name)))
766 (when (eq where :declared)
767 (setf (leaf-type fun) type)
768 (assert-definition-type fun type
769 :unwinnage-fun #'compiler-note
770 :where "proclamation"))))
772 ;;;; FIXME: Move to some other file.
773 (defun check-catch-tag-type (tag)
774 (declare (type continuation tag))
775 (let ((ctype (continuation-type tag)))
776 (when (csubtypep ctype (specifier-type '(or number character)))
777 (compiler-style-warn "~@<using ~S of type ~S as a catch tag (which ~
778 tends to be unportable because THROW and CATCH ~
779 use EQ comparison)~@:>"
780 (continuation-source tag)
781 (type-specifier (continuation-type tag))))))
783 (defun %compile-time-type-error (values atype dtype)
784 (declare (ignore dtype))
785 (if (and (consp atype)
786 (eq (car atype) 'values))
787 (error 'values-type-error :datum values :expected-type atype)
788 (error 'type-error :datum (car values) :expected-type atype)))
790 (defoptimizer (%compile-time-type-error ir2-convert)
791 ((objects atype dtype) node block)
792 (let ((*compiler-error-context* node))
793 (setf (node-source-path node)
794 (cdr (node-source-path node)))
795 (destructuring-bind (values atype dtype)
796 (basic-combination-args node)
797 (declare (ignore values))
798 (let ((atype (continuation-value atype))
799 (dtype (continuation-value dtype)))
800 (unless (eq atype nil)
802 "~@<Asserted type ~S conflicts with derived type ~S.~@:>"
804 (ir2-convert-full-call node block)))