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
327 :type
(integer 0 #.sb
!xc
:call-arguments-limit
))
329 :type
(integer 0 #.sb
!xc
:call-arguments-limit
))
330 ;; a list of lists of the all the types that have been used in each
332 (types () :type list
)
333 ;; A list of APPROXIMATE-KEY-INFO structures describing all the
334 ;; things that looked like &KEY arguments. There are distinct
335 ;; structures describing each argument position in which the keyword
337 (keys () :type list
))
339 (defstruct (approximate-key-info (:copier nil
))
340 ;; The keyword name of this argument. Although keyword names don't
341 ;; have to be keywords, we only match on keywords when figuring an
343 (name (missing-arg) :type keyword
)
344 ;; The position at which this keyword appeared. 0 if it appeared as the
345 ;; first argument, etc.
346 (position (missing-arg)
347 :type
(integer 0 #.sb
!xc
:call-arguments-limit
))
348 ;; a list of all the argument types that have been used with this keyword
349 (types nil
:type list
)
350 ;; true if this keyword has appeared only in calls with an obvious
352 (allowp nil
:type
(member t nil
)))
354 ;;; Return an APPROXIMATE-FUN-TYPE representing the context of
355 ;;; CALL. If TYPE is supplied and not null, then we merge the
356 ;;; information into the information already accumulated in TYPE.
357 (declaim (ftype (function (combination
358 &optional
(or approximate-fun-type null
))
359 approximate-fun-type
)
361 (defun note-fun-use (call &optional type
)
362 (let* ((type (or type
(make-approximate-fun-type)))
363 (types (approximate-fun-type-types type
))
364 (args (combination-args call
))
365 (nargs (length args
))
366 (allowp (some (lambda (x)
367 (and (constant-lvar-p x
)
368 (eq (lvar-value x
) :allow-other-keys
)))
371 (setf (approximate-fun-type-min-args type
)
372 (min (approximate-fun-type-min-args type
) nargs
))
373 (setf (approximate-fun-type-max-args type
)
374 (max (approximate-fun-type-max-args type
) nargs
))
376 (do ((old types
(cdr old
))
377 (arg args
(cdr arg
)))
379 (setf (approximate-fun-type-types type
)
382 (list (lvar-type x
)))
384 (when (null arg
) (return))
385 (pushnew (lvar-type (car arg
))
389 (collect ((keys (approximate-fun-type-keys type
) cons
))
390 (do ((arg args
(cdr arg
))
392 ((or (null arg
) (null (cdr arg
)))
393 (setf (approximate-fun-type-keys type
) (keys)))
394 (let ((key (first arg
))
396 (when (constant-lvar-p key
)
397 (let ((name (lvar-value key
)))
398 (when (keywordp name
)
401 (and (eq (approximate-key-info-name x
) name
)
402 (= (approximate-key-info-position x
)
405 (val-type (lvar-type val
)))
408 (approximate-key-info-types old
)
411 (setf (approximate-key-info-allowp old
) nil
)))
413 (keys (make-approximate-key-info
417 :types
(list val-type
))))))))))))
420 ;;; This is similar to VALID-FUN-USE, but checks an
421 ;;; APPROXIMATE-FUN-TYPE against a real function type.
422 (declaim (ftype (function (approximate-fun-type fun-type
423 &optional function function function
)
424 (values boolean boolean
))
425 valid-approximate-type
))
426 (defun valid-approximate-type (call-type type
&optional
428 #'types-equal-or-intersect
)
430 #'compiler-style-warn
)
431 (*unwinnage-fun
* #'compiler-notify
))
432 (let* ((*lossage-detected
* nil
)
433 (*unwinnage-detected
* nil
)
434 (required (fun-type-required type
))
435 (min-args (length required
))
436 (optional (fun-type-optional type
))
437 (max-args (+ min-args
(length optional
)))
438 (rest (fun-type-rest type
))
439 (keyp (fun-type-keyp type
)))
441 (when (fun-type-wild-args type
)
442 (return-from valid-approximate-type
(values t t
)))
444 (let ((call-min (approximate-fun-type-min-args call-type
)))
445 (when (< call-min min-args
)
447 "~:@<The function was previously called with ~R argument~:P, ~
448 but wants at least ~R.~:>"
451 (let ((call-max (approximate-fun-type-max-args call-type
)))
452 (cond ((<= call-max max-args
))
453 ((not (or keyp rest
))
455 "~:@<The function was previously called with ~R argument~:P, ~
456 but wants at most ~R.~:>"
458 ((and keyp
(oddp (- call-max max-args
)))
460 "~:@<The function was previously called with an odd number of ~
461 arguments in the keyword portion.~:>")))
463 (when (and keyp
(> call-max max-args
))
464 (check-approximate-keywords call-type max-args type
)))
466 (check-approximate-fixed-and-rest call-type
(append required optional
)
469 (cond (*lossage-detected
* (values nil t
))
470 (*unwinnage-detected
* (values nil nil
))
473 ;;; Check that each of the types used at each arg position is
474 ;;; compatible with the actual type.
475 (declaim (ftype (function (approximate-fun-type list
(or ctype null
))
477 check-approximate-fixed-and-rest
))
478 (defun check-approximate-fixed-and-rest (call-type fixed rest
)
479 (do ((types (approximate-fun-type-types call-type
) (cdr types
))
481 (arg fixed
(cdr arg
)))
483 (let ((decl-type (or (car arg
) rest
)))
484 (unless decl-type
(return))
485 (check-approximate-arg-type (car types
) decl-type
"~:R" n
)))
488 ;;; Check that each of the call-types is compatible with DECL-TYPE,
489 ;;; complaining if not or if we can't tell.
490 (declaim (ftype (function (list ctype string
&rest t
) (values))
491 check-approximate-arg-type
))
492 (defun check-approximate-arg-type (call-types decl-type context
&rest args
)
493 (let ((losers *empty-type
*))
494 (dolist (ctype call-types
)
495 (multiple-value-bind (int win
) (funcall *ctype-test-fun
* ctype decl-type
)
498 (note-unwinnage "can't tell whether previous ~? ~
499 argument type ~S is a ~S"
502 (type-specifier ctype
)
503 (type-specifier decl-type
)))
505 (setq losers
(type-union ctype losers
))))))
507 (unless (eq losers
*empty-type
*)
508 (note-lossage "~:(~?~) argument should be a ~S but was a ~S in a previous call."
509 context args
(type-specifier decl-type
) (type-specifier losers
))))
512 ;;; Check the types of each manifest keyword that appears in a keyword
513 ;;; argument position. Check the validity of all keys that appeared in
514 ;;; valid keyword positions.
516 ;;; ### We could check the APPROXIMATE-FUN-TYPE-TYPES to make
517 ;;; sure that all arguments in keyword positions were manifest
519 (defun check-approximate-keywords (call-type max-args type
)
520 (let ((call-keys (approximate-fun-type-keys call-type
))
521 (keys (fun-type-keywords type
)))
523 (let ((name (key-info-name key
)))
524 (collect ((types nil append
))
525 (dolist (call-key call-keys
)
526 (let ((pos (approximate-key-info-position call-key
)))
527 (when (and (eq (approximate-key-info-name call-key
) name
)
528 (> pos max-args
) (evenp (- pos max-args
)))
529 (types (approximate-key-info-types call-key
)))))
530 (check-approximate-arg-type (types) (key-info-type key
) "~S" name
))))
532 (unless (fun-type-allowp type
)
533 (collect ((names () adjoin
))
534 (dolist (call-key call-keys
)
535 (let ((pos (approximate-key-info-position call-key
)))
536 (when (and (> pos max-args
) (evenp (- pos max-args
))
537 (not (approximate-key-info-allowp call-key
)))
538 (names (approximate-key-info-name call-key
)))))
540 (dolist (name (names))
541 (unless (find name keys
:key
#'key-info-name
)
542 (note-lossage "Function previously called with unknown argument keyword ~S."
545 ;;;; ASSERT-DEFINITION-TYPE
547 ;;; Intersect LAMBDA's var types with TYPES, giving a warning if there
548 ;;; is a mismatch. If all intersections are non-null, we return lists
549 ;;; of the variables and intersections, otherwise we return NIL, NIL.
550 (defun try-type-intersections (vars types where
)
551 (declare (list vars types
) (string where
))
553 (mapc (lambda (var type
)
554 (let* ((vtype (leaf-type var
))
555 (int (type-approx-intersection2 vtype type
)))
557 ((eq int
*empty-type
*)
559 "Definition's declared type for variable ~A:~% ~S~@
560 conflicts with this type from ~A:~% ~S"
561 (leaf-debug-name var
) (type-specifier vtype
)
562 where
(type-specifier type
))
563 (return-from try-type-intersections
(values nil nil
)))
567 (values vars
(res))))
569 ;;; Check that the optional-dispatch OD conforms to TYPE. We return
570 ;;; the values of TRY-TYPE-INTERSECTIONS if there are no syntax
571 ;;; problems, otherwise NIL, NIL.
573 ;;; Note that the variables in the returned list are the actual
574 ;;; original variables (extracted from the optional dispatch arglist),
575 ;;; rather than the variables that are arguments to the main entry.
576 ;;; This difference is significant only for &KEY args with hairy
577 ;;; defaults. Returning the actual vars allows us to use the right
578 ;;; variable name in warnings.
580 ;;; A slightly subtle point: with keywords and optionals, the type in
581 ;;; the function type is only an assertion on calls --- it doesn't
582 ;;; constrain the type of default values. So we have to union in the
583 ;;; type of the default. With optionals, we can't do any assertion
584 ;;; unless the default is constant.
586 ;;; With keywords, we exploit our knowledge about how hairy keyword
587 ;;; defaulting is done when computing the type assertion to put on the
588 ;;; main-entry argument. In the case of hairy keywords, the default
589 ;;; has been clobbered with NIL, which is the value of the main-entry
590 ;;; arg in the unsupplied case, whatever the actual default value is.
591 ;;; So we can just assume the default is constant, effectively
592 ;;; unioning in NULL, and not totally blow off doing any type
594 (defun find-optional-dispatch-types (od type where
)
595 (declare (type optional-dispatch od
)
598 (let* ((min (optional-dispatch-min-args od
))
599 (req (fun-type-required type
))
600 (opt (fun-type-optional type
)))
601 (flet ((frob (x y what
)
604 "The definition has ~R ~A arg~P, but ~A has ~R."
606 (frob min
(length req
) "fixed")
607 (frob (- (optional-dispatch-max-args od
) min
) (length opt
) "optional"))
608 (flet ((frob (x y what
)
611 "The definition ~:[doesn't have~;has~] ~A, but ~
612 ~A ~:[doesn't~;does~]."
614 (frob (optional-dispatch-keyp od
) (fun-type-keyp type
)
616 (unless (optional-dispatch-keyp od
)
617 (frob (not (null (optional-dispatch-more-entry od
)))
618 (not (null (fun-type-rest type
)))
620 (frob (optional-dispatch-allowp od
) (fun-type-allowp type
)
621 "&ALLOW-OTHER-KEYS"))
623 (when *lossage-detected
*
624 (return-from find-optional-dispatch-types
(values nil nil
)))
628 (let ((keys (fun-type-keywords type
))
629 (arglist (optional-dispatch-arglist od
)))
630 (dolist (arg arglist
)
632 ((lambda-var-arg-info arg
)
633 (let* ((info (lambda-var-arg-info arg
))
634 (default (arg-info-default info
))
635 (def-type (when (sb!xc
:constantp default
)
636 (ctype-of (constant-form-value default
)))))
637 (ecase (arg-info-kind info
)
639 (let* ((key (arg-info-key info
))
640 (kinfo (find key keys
:key
#'key-info-name
)))
643 (res (type-union (key-info-type kinfo
)
644 (or def-type
(specifier-type 'null
)))))
647 "Defining a ~S keyword not present in ~A."
649 (res *universal-type
*)))))
650 (:required
(res (pop req
)))
652 (res (type-union (pop opt
) (or def-type
*universal-type
*))))
654 (when (fun-type-rest type
)
655 (res (specifier-type 'list
))))
657 (when (fun-type-rest type
)
658 (res *universal-type
*)))
660 (when (fun-type-rest type
)
661 (res (specifier-type 'fixnum
)))))
663 (when (arg-info-supplied-p info
)
664 (res *universal-type
*)
665 (vars (arg-info-supplied-p info
)))))
671 (unless (find (key-info-name key
) arglist
673 (let ((info (lambda-var-arg-info x
)))
675 (arg-info-key info
)))))
677 "The definition lacks the ~S key present in ~A."
678 (key-info-name key
) where
))))
680 (try-type-intersections (vars) (res) where
))))
682 ;;; Check that TYPE doesn't specify any funny args, and do the
684 (defun find-lambda-types (lambda type where
)
685 (declare (type clambda lambda
) (type fun-type type
) (string where
))
686 (flet ((frob (x what
)
689 "The definition has no ~A, but the ~A did."
691 (frob (fun-type-optional type
) "&OPTIONAL arguments")
692 (frob (fun-type-keyp type
) "&KEY arguments")
693 (frob (fun-type-rest type
) "&REST argument"))
694 (let* ((vars (lambda-vars lambda
))
695 (nvars (length vars
))
696 (req (fun-type-required type
))
698 (unless (= nvars nreq
)
699 (note-lossage "The definition has ~R arg~:P, but the ~A has ~R."
701 (if *lossage-detected
*
703 (try-type-intersections vars req where
))))
705 ;;; Check for syntactic and type conformance between the definition
706 ;;; FUNCTIONAL and the specified FUN-TYPE. If they are compatible
707 ;;; and REALLY-ASSERT is T, then add type assertions to the definition
708 ;;; from the FUN-TYPE.
710 ;;; If there is a syntactic or type problem, then we call
711 ;;; LOSSAGE-FUN with an error message using WHERE as context
712 ;;; describing where FUN-TYPE came from.
714 ;;; If there is no problem, we return T (even if REALLY-ASSERT was
715 ;;; false). If there was a problem, we return NIL.
716 (defun assert-definition-type
717 (functional type
&key
(really-assert t
)
718 ((:lossage-fun
*lossage-fun
*)
719 #'compiler-style-warn
)
721 (where "previous declaration"))
722 (declare (type functional functional
)
723 (type function
*lossage-fun
*)
725 (unless (fun-type-p type
)
726 (return-from assert-definition-type t
))
727 (let ((*lossage-detected
* nil
))
728 (multiple-value-bind (vars types
)
729 (if (fun-type-wild-args type
)
731 (etypecase functional
733 (find-optional-dispatch-types functional type where
))
735 (find-lambda-types functional type where
))))
736 (let* ((type-returns (fun-type-returns type
))
737 (return (lambda-return (main-entry functional
)))
739 (lvar-derived-type (return-result return
)))))
741 ((and dtype
(not (values-types-equal-or-intersect dtype
744 "The result type from ~A:~% ~S~@
745 conflicts with the definition's result type:~% ~S"
746 where
(type-specifier type-returns
) (type-specifier dtype
))
748 (*lossage-detected
* nil
)
749 ((not really-assert
) t
)
751 (let ((policy (lexenv-policy (functional-lexenv functional
))))
752 (when (policy policy
(> type-check
0))
753 (assert-lvar-type (return-result return
) type-returns
755 (loop for var in vars and type in types do
756 (cond ((basic-var-sets var
)
757 (when (and unwinnage-fun
758 (not (csubtypep (leaf-type var
) type
)))
759 (funcall unwinnage-fun
760 "Assignment to argument: ~S~% ~
761 prevents use of assertion from function ~
763 (leaf-debug-name var
)
765 (type-specifier type
))))
767 (setf (leaf-type var
) type
)
768 (let ((s-type (make-single-value-type type
)))
769 (dolist (ref (leaf-refs var
))
770 (derive-node-type ref s-type
))))))
773 ;;; FIXME: This is quite similar to ASSERT-NEW-DEFINITION.
774 (defun assert-global-function-definition-type (name fun
)
775 (declare (type functional fun
))
776 (let ((type (info :function
:type name
))
777 (where (info :function
:where-from name
)))
778 (when (eq where
:declared
)
779 (setf (leaf-type fun
) type
)
780 (assert-definition-type
782 :unwinnage-fun
#'compiler-notify
783 :where
"proclamation"
784 :really-assert
(not (awhen (info :function
:info name
)
785 (ir1-attributep (fun-info-attributes it
)
786 explicit-check
)))))))
788 ;;; Call FUN with (arg-lvar arg-type)
789 (defun map-combination-args-and-types (fun call
)
790 (declare (type function fun
) (type combination call
))
791 (binding* ((type (lvar-type (combination-fun call
)))
792 (nil (fun-type-p type
) :exit-if-null
)
793 (args (combination-args call
)))
794 (dolist (req (fun-type-required type
))
795 (when (null args
) (return-from map-combination-args-and-types
))
796 (let ((arg (pop args
)))
797 (funcall fun arg req
)))
798 (dolist (opt (fun-type-optional type
))
799 (when (null args
) (return-from map-combination-args-and-types
))
800 (let ((arg (pop args
)))
801 (funcall fun arg opt
)))
803 (let ((rest (fun-type-rest type
)))
806 (funcall fun arg rest
))))
808 (dolist (key (fun-type-keywords type
))
809 (let ((name (key-info-name key
)))
810 (do ((arg args
(cddr arg
)))
812 (when (eq (lvar-value (first arg
)) name
)
813 (funcall fun
(second arg
) (key-info-type key
))))))))
815 ;;; Assert that CALL is to a function of the specified TYPE. It is
816 ;;; assumed that the call is legal and has only constants in the
817 ;;; keyword positions.
818 (defun assert-call-type (call type
)
819 (declare (type combination call
) (type fun-type type
))
820 (derive-node-type call
(fun-type-returns type
))
821 (let ((policy (lexenv-policy (node-lexenv call
))))
822 (map-combination-args-and-types
824 (assert-lvar-type arg type policy
))
828 ;;;; FIXME: Move to some other file.
829 (defun check-catch-tag-type (tag)
830 (declare (type lvar tag
))
831 (let ((ctype (lvar-type tag
)))
832 (when (csubtypep ctype
(specifier-type '(or number character
)))
833 (compiler-style-warn "~@<using ~S of type ~S as a catch tag (which ~
834 tends to be unportable because THROW and CATCH ~
835 use EQ comparison)~@:>"
837 (type-specifier (lvar-type tag
))))))
839 (defun %compile-time-type-error
(values atype dtype
)
840 (declare (ignore dtype
))
841 (if (and (consp atype
)
842 (eq (car atype
) 'values
))
843 (error 'values-type-error
:datum values
:expected-type atype
)
844 (error 'type-error
:datum
(car values
) :expected-type atype
)))
846 (defoptimizer (%compile-time-type-error ir2-convert
)
847 ((objects atype dtype
) node block
)
848 (let ((*compiler-error-context
* node
))
849 (setf (node-source-path node
)
850 (cdr (node-source-path node
)))
851 (destructuring-bind (values atype dtype
)
852 (basic-combination-args node
)
853 (declare (ignore values
))
854 (let ((atype (lvar-value atype
))
855 (dtype (lvar-value dtype
)))
856 (unless (eq atype nil
)
859 "~@<Asserted type ~S conflicts with derived type ~S.~@:>"
860 :format-arguments
(list atype dtype
)))))
861 (ir2-convert-full-call node block
)))