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
))
72 ;;;; stuff for checking a call against a function type
74 ;;;; FIXME: This is stuff to look at when I get around to fixing
75 ;;;; function type inference and declarations.
77 ;;; A dummy version of SUBTYPEP useful when we want a functional like
78 ;;; SUBTYPEP that always returns true.
79 (defun always-subtypep (type1 type2
)
80 (declare (ignore type1 type2
))
83 ;;; Determine whether a use of a function is consistent with its type.
84 ;;; These values are returned:
85 ;;; T, T: the call is definitely valid.
86 ;;; NIL, T: the call is definitely invalid.
87 ;;; NIL, NIL: unable to determine whether the call is valid.
89 ;;; The ARGUMENT-TEST function is used to determine whether an
90 ;;; argument type matches the type we are checking against. Similarly,
91 ;;; the RESULT-TEST is used to determine whether the result type
92 ;;; matches the specified result.
94 ;;; Unlike the argument test, the result test may be called on values
95 ;;; or function types. NODE-DERIVED-TYPE is intersected with the
96 ;;; trusted asserted type.
98 ;;; The error and warning functions are functions that are called to
99 ;;; explain the result. We bind *COMPILER-ERROR-CONTEXT* to the
100 ;;; combination node so that COMPILER-WARNING and related functions
101 ;;; will do the right thing if they are supplied.
102 (defun valid-fun-use (call type
&key
103 ((:argument-test
*ctype-test-fun
*) #'csubtypep
)
104 (result-test #'values-subtypep
)
105 ((:lossage-fun
*lossage-fun
*))
106 ((:unwinnage-fun
*unwinnage-fun
*)))
107 (declare (type (or function null
) result-test
) (type combination call
)
108 ;; FIXME: Could TYPE here actually be something like
109 ;; (AND GENERIC-FUNCTION (FUNCTION (T) T))? How
110 ;; horrible... -- CSR, 2003-05-03
112 (let* ((*lossage-detected
* nil
)
113 (*unwinnage-detected
* nil
)
114 (*compiler-error-context
* call
)
115 (args (combination-args call
)))
116 (if (fun-type-p type
)
117 (let* ((nargs (length args
))
118 (required (fun-type-required type
))
119 (min-args (length required
))
120 (optional (fun-type-optional type
))
121 (max-args (+ min-args
(length optional
)))
122 (rest (fun-type-rest type
))
123 (keyp (fun-type-keyp type
)))
125 ((fun-type-wild-args type
)
126 (loop for arg in args
128 do
(check-arg-type arg
*universal-type
* i
)))
129 ((not (or optional keyp rest
))
130 (if (/= nargs min-args
)
132 "The function was called with ~R argument~:P, but wants exactly ~R."
134 (check-fixed-and-rest args required nil
)))
137 "The function was called with ~R argument~:P, but wants at least ~R."
140 (check-fixed-and-rest args
(append required optional
) rest
))
141 ((not (or keyp rest
))
143 "The function was called with ~R argument~:P, but wants at most ~R."
145 ((and keyp
(oddp (- nargs max-args
)))
147 "The function has an odd number of arguments in the keyword portion."))
149 (check-fixed-and-rest args
(append required optional
) rest
)
151 (check-key-args args max-args type
))))
154 (let* ((dtype (node-derived-type call
))
156 (binding* ((lvar (node-lvar call
) :exit-if-null
)
157 (dest (lvar-dest lvar
)))
158 (when (and (cast-p dest
)
159 (eq (cast-type-to-check dest
) *wild-type
*)
160 (immediately-used-p lvar call
))
161 (values-type-intersection
162 dtype
(cast-asserted-type dest
))))
164 (return-type (fun-type-returns type
)))
165 (multiple-value-bind (int win
) (funcall result-test out-type return-type
)
167 (note-unwinnage "can't tell whether the result is a ~S"
168 (type-specifier return-type
)))
170 (note-lossage "The result is a ~S, not a ~S."
171 (type-specifier out-type
)
172 (type-specifier return-type
))))))))
173 (loop for arg in args
175 do
(check-arg-type arg
*wild-type
* i
)))
176 (cond (*lossage-detected
* (values nil t
))
177 (*unwinnage-detected
* (values nil nil
))
180 ;;; Check that the derived type of the LVAR is compatible with TYPE. N
181 ;;; is the arg number, for error message purposes. We return true if
182 ;;; arg is definitely o.k. If the type is a magic CONSTANT-TYPE, then
183 ;;; we check for the argument being a constant value of the specified
184 ;;; type. If there is a manifest type error (DERIVED-TYPE = NIL), then
185 ;;; we flame about the asserted type even when our type is satisfied
187 (defun check-arg-type (lvar type n
)
188 (declare (type lvar lvar
) (type ctype type
) (type index n
))
190 ((not (constant-type-p type
))
191 (let ((ctype (lvar-type lvar
)))
192 (multiple-value-bind (int win
) (funcall *ctype-test-fun
* ctype type
)
194 (note-unwinnage "can't tell whether the ~:R argument is a ~S"
195 n
(type-specifier type
))
198 (note-lossage "The ~:R argument is a ~S, not a ~S."
199 n
(type-specifier ctype
) (type-specifier type
))
201 ((eq ctype
*empty-type
*)
202 (note-unwinnage "The ~:R argument never returns a value." n
)
205 ((not (constant-lvar-p lvar
))
206 (note-unwinnage "The ~:R argument is not a constant." n
)
209 (let ((val (lvar-value lvar
))
210 (type (constant-type-type type
)))
211 (multiple-value-bind (res win
) (ctypep val type
)
213 (note-unwinnage "can't tell whether the ~:R argument is a ~
215 n
(type-specifier type
) val
)
218 (note-lossage "The ~:R argument is not a constant ~S:~% ~S"
219 n
(type-specifier type
) val
)
223 ;;; Check that each of the type of each supplied argument intersects
224 ;;; with the type specified for that argument. If we can't tell, then
225 ;;; we can complain about the absence of manifest winnage.
226 (declaim (ftype (function (list list
(or ctype null
)) (values)) check-fixed-and-rest
))
227 (defun check-fixed-and-rest (args types rest
)
228 (do ((arg args
(cdr arg
))
229 (type types
(cdr type
))
231 ((or (null type
) (null arg
))
234 (check-arg-type arg rest n
)
237 (check-arg-type (car arg
) (car type
) n
))
240 ;;; Check that the &KEY args are of the correct type. Each key should
241 ;;; be known and the corresponding argument should be of the correct
242 ;;; type. If the key isn't a constant, then we can't tell, so we can
243 ;;; complain about absence of manifest winnage.
244 (declaim (ftype (function (list fixnum fun-type
) (values)) check-key-args
))
245 (defun check-key-args (args pre-key type
)
246 (let (lossages allow-other-keys
)
247 (do ((key (nthcdr pre-key args
) (cddr key
))
248 (n (1+ pre-key
) (+ n
2)))
251 (let ((k (first key
))
254 ((not (check-arg-type k
(specifier-type 'symbol
) n
)))
255 ((not (constant-lvar-p k
))
256 (note-unwinnage "~@<The ~:R argument (in keyword position) is not ~
257 a constant, weakening keyword argument ~
259 ;; An unknown key may turn out to be :ALLOW-OTHER-KEYS at runtime,
260 ;; so we cannot signal full warnings for keys that look bad.
261 (unless allow-other-keys
262 (setf allow-other-keys
:maybe
)))
264 (let* ((name (lvar-value k
))
265 (info (find name
(fun-type-keywords type
)
266 :key
#'key-info-name
)))
267 (cond ((eq name
:allow-other-keys
)
268 (unless allow-other-keys
269 (if (constant-lvar-p v
)
270 (setf allow-other-keys
(if (lvar-value v
)
273 (setf allow-other-keys
:maybe
))))
275 (unless (fun-type-allowp type
)
276 (pushnew name lossages
:test
#'eq
)))
278 (check-arg-type (second key
) (key-info-type info
)
280 (when (and lossages
(member allow-other-keys
'(nil :no
)))
281 (setf lossages
(nreverse lossages
))
283 (note-lossage "~@<~{~S~^, ~} and ~S are not a known argument keywords.~:@>"
285 (car (last lossages
)))
286 (note-lossage "~S is not a known argument keyword."
290 ;;; Construct a function type from a definition.
292 ;;; Due to the lack of a (LIST X) type specifier, we can't reconstruct
294 (declaim (ftype (sfunction (functional) fun-type
) definition-type
))
295 (defun definition-type (functional)
296 (if (lambda-p functional
)
298 :required
(mapcar #'leaf-type
(lambda-vars functional
))
299 :returns
(tail-set-type (lambda-tail-set functional
)))
304 (dolist (arg (optional-dispatch-arglist functional
))
305 (let ((info (lambda-var-arg-info arg
))
306 (type (leaf-type arg
)))
308 (ecase (arg-info-kind info
)
309 (:required
(req type
))
310 (:optional
(opt type
))
312 (keys (make-key-info :name
(arg-info-key info
)
314 ((:rest
:more-context
)
315 (setq rest
*universal-type
*))
324 :keyp
(optional-dispatch-keyp functional
)
325 :allowp
(optional-dispatch-allowp functional
)
326 :returns
(tail-set-type
328 (optional-dispatch-main-entry functional
))))))))
330 ;;;; approximate function types
332 ;;;; FIXME: This is stuff to look at when I get around to fixing function
333 ;;;; type inference and declarations.
335 ;;;; Approximate function types provide a condensed representation of all the
336 ;;;; different ways that a function has been used. If we have no declared or
337 ;;;; defined type for a function, then we build an approximate function type by
338 ;;;; examining each use of the function. When we encounter a definition or
339 ;;;; proclamation, we can check the actual type for compatibity with the
342 (defstruct (approximate-fun-type (:copier nil
))
343 ;; the smallest and largest numbers of arguments that this function
344 ;; has been called with.
345 (min-args sb
!xc
:call-arguments-limit
346 :type
(integer 0 #.sb
!xc
:call-arguments-limit
))
348 :type
(integer 0 #.sb
!xc
:call-arguments-limit
))
349 ;; a list of lists of the all the types that have been used in each
351 (types () :type list
)
352 ;; A list of APPROXIMATE-KEY-INFO structures describing all the
353 ;; things that looked like &KEY arguments. There are distinct
354 ;; structures describing each argument position in which the keyword
356 (keys () :type list
))
358 (defstruct (approximate-key-info (:copier nil
))
359 ;; The keyword name of this argument. Although keyword names don't
360 ;; have to be keywords, we only match on keywords when figuring an
362 (name (missing-arg) :type keyword
)
363 ;; The position at which this keyword appeared. 0 if it appeared as the
364 ;; first argument, etc.
365 (position (missing-arg)
366 :type
(integer 0 #.sb
!xc
:call-arguments-limit
))
367 ;; a list of all the argument types that have been used with this keyword
368 (types nil
:type list
)
369 ;; true if this keyword has appeared only in calls with an obvious
371 (allowp nil
:type
(member t nil
)))
373 ;;; Return an APPROXIMATE-FUN-TYPE representing the context of
374 ;;; CALL. If TYPE is supplied and not null, then we merge the
375 ;;; information into the information already accumulated in TYPE.
376 (declaim (ftype (function (combination
377 &optional
(or approximate-fun-type null
))
378 approximate-fun-type
)
380 (defun note-fun-use (call &optional type
)
381 (let* ((type (or type
(make-approximate-fun-type)))
382 (types (approximate-fun-type-types type
))
383 (args (combination-args call
))
384 (nargs (length args
))
385 (allowp (some (lambda (x)
386 (and (constant-lvar-p x
)
387 (eq (lvar-value x
) :allow-other-keys
)))
390 (setf (approximate-fun-type-min-args type
)
391 (min (approximate-fun-type-min-args type
) nargs
))
392 (setf (approximate-fun-type-max-args type
)
393 (max (approximate-fun-type-max-args type
) nargs
))
395 (do ((old types
(cdr old
))
396 (arg args
(cdr arg
)))
398 (setf (approximate-fun-type-types type
)
401 (list (lvar-type x
)))
403 (when (null arg
) (return))
404 (pushnew (lvar-type (car arg
))
408 (collect ((keys (approximate-fun-type-keys type
) cons
))
409 (do ((arg args
(cdr arg
))
411 ((or (null arg
) (null (cdr arg
)))
412 (setf (approximate-fun-type-keys type
) (keys)))
413 (let ((key (first arg
))
415 (when (constant-lvar-p key
)
416 (let ((name (lvar-value key
)))
417 (when (keywordp name
)
420 (and (eq (approximate-key-info-name x
) name
)
421 (= (approximate-key-info-position x
)
424 (val-type (lvar-type val
)))
427 (approximate-key-info-types old
)
430 (setf (approximate-key-info-allowp old
) nil
)))
432 (keys (make-approximate-key-info
436 :types
(list val-type
))))))))))))
439 ;;; This is similar to VALID-FUN-USE, but checks an
440 ;;; APPROXIMATE-FUN-TYPE against a real function type.
441 (declaim (ftype (function (approximate-fun-type fun-type
442 &optional function function function
)
443 (values boolean boolean
))
444 valid-approximate-type
))
445 (defun valid-approximate-type (call-type type
&optional
447 #'types-equal-or-intersect
)
449 #'compiler-style-warn
)
450 (*unwinnage-fun
* #'compiler-notify
))
451 (let* ((*lossage-detected
* nil
)
452 (*unwinnage-detected
* nil
)
453 (required (fun-type-required type
))
454 (min-args (length required
))
455 (optional (fun-type-optional type
))
456 (max-args (+ min-args
(length optional
)))
457 (rest (fun-type-rest type
))
458 (keyp (fun-type-keyp type
)))
460 (when (fun-type-wild-args type
)
461 (return-from valid-approximate-type
(values t t
)))
463 (let ((call-min (approximate-fun-type-min-args call-type
)))
464 (when (< call-min min-args
)
466 "~:@<The function was previously called with ~R argument~:P, ~
467 but wants at least ~R.~:>"
470 (let ((call-max (approximate-fun-type-max-args call-type
)))
471 (cond ((<= call-max max-args
))
472 ((not (or keyp rest
))
474 "~:@<The function was previously called with ~R argument~:P, ~
475 but wants at most ~R.~:>"
477 ((and keyp
(oddp (- call-max max-args
)))
479 "~:@<The function was previously called with an odd number of ~
480 arguments in the keyword portion.~:>")))
482 (when (and keyp
(> call-max max-args
))
483 (check-approximate-keywords call-type max-args type
)))
485 (check-approximate-fixed-and-rest call-type
(append required optional
)
488 (cond (*lossage-detected
* (values nil t
))
489 (*unwinnage-detected
* (values nil nil
))
492 ;;; Check that each of the types used at each arg position is
493 ;;; compatible with the actual type.
494 (declaim (ftype (function (approximate-fun-type list
(or ctype null
))
496 check-approximate-fixed-and-rest
))
497 (defun check-approximate-fixed-and-rest (call-type fixed rest
)
498 (do ((types (approximate-fun-type-types call-type
) (cdr types
))
500 (arg fixed
(cdr arg
)))
502 (let ((decl-type (or (car arg
) rest
)))
503 (unless decl-type
(return))
504 (check-approximate-arg-type (car types
) decl-type
"~:R" n
)))
507 ;;; Check that each of the call-types is compatible with DECL-TYPE,
508 ;;; complaining if not or if we can't tell.
509 (declaim (ftype (function (list ctype string
&rest t
) (values))
510 check-approximate-arg-type
))
511 (defun check-approximate-arg-type (call-types decl-type context
&rest args
)
512 (let ((losers *empty-type
*))
513 (dolist (ctype call-types
)
514 (multiple-value-bind (int win
) (funcall *ctype-test-fun
* ctype decl-type
)
517 (note-unwinnage "can't tell whether previous ~? ~
518 argument type ~S is a ~S"
521 (type-specifier ctype
)
522 (type-specifier decl-type
)))
524 (setq losers
(type-union ctype losers
))))))
526 (unless (eq losers
*empty-type
*)
527 (note-lossage "~:(~?~) argument should be a ~S but was a ~S in a previous call."
528 context args
(type-specifier decl-type
) (type-specifier losers
))))
531 ;;; Check the types of each manifest keyword that appears in a keyword
532 ;;; argument position. Check the validity of all keys that appeared in
533 ;;; valid keyword positions.
535 ;;; ### We could check the APPROXIMATE-FUN-TYPE-TYPES to make
536 ;;; sure that all arguments in keyword positions were manifest
538 (defun check-approximate-keywords (call-type max-args type
)
539 (let ((call-keys (approximate-fun-type-keys call-type
))
540 (keys (fun-type-keywords type
)))
542 (let ((name (key-info-name key
)))
543 (collect ((types nil append
))
544 (dolist (call-key call-keys
)
545 (let ((pos (approximate-key-info-position call-key
)))
546 (when (and (eq (approximate-key-info-name call-key
) name
)
547 (> pos max-args
) (evenp (- pos max-args
)))
548 (types (approximate-key-info-types call-key
)))))
549 (check-approximate-arg-type (types) (key-info-type key
) "~S" name
))))
551 (unless (fun-type-allowp type
)
552 (collect ((names () adjoin
))
553 (dolist (call-key call-keys
)
554 (let ((pos (approximate-key-info-position call-key
)))
555 (when (and (> pos max-args
) (evenp (- pos max-args
))
556 (not (approximate-key-info-allowp call-key
)))
557 (names (approximate-key-info-name call-key
)))))
559 (dolist (name (names))
560 (unless (find name keys
:key
#'key-info-name
)
561 (note-lossage "Function previously called with unknown argument keyword ~S."
564 ;;;; ASSERT-DEFINITION-TYPE
566 ;;; Intersect LAMBDA's var types with TYPES, giving a warning if there
567 ;;; is a mismatch. If all intersections are non-null, we return lists
568 ;;; of the variables and intersections, otherwise we return NIL, NIL.
569 (defun try-type-intersections (vars types where
)
570 (declare (list vars types
) (string where
))
572 (mapc (lambda (var type
)
573 (let* ((vtype (leaf-type var
))
574 (int (type-approx-intersection2 vtype type
)))
576 ((eq int
*empty-type
*)
578 "Definition's declared type for variable ~A:~% ~S~@
579 conflicts with this type from ~A:~% ~S"
580 (leaf-debug-name var
) (type-specifier vtype
)
581 where
(type-specifier type
))
582 (return-from try-type-intersections
(values nil nil
)))
586 (values vars
(res))))
588 ;;; Check that the optional-dispatch OD conforms to TYPE. We return
589 ;;; the values of TRY-TYPE-INTERSECTIONS if there are no syntax
590 ;;; problems, otherwise NIL, NIL.
592 ;;; Note that the variables in the returned list are the actual
593 ;;; original variables (extracted from the optional dispatch arglist),
594 ;;; rather than the variables that are arguments to the main entry.
595 ;;; This difference is significant only for &KEY args with hairy
596 ;;; defaults. Returning the actual vars allows us to use the right
597 ;;; variable name in warnings.
599 ;;; A slightly subtle point: with keywords and optionals, the type in
600 ;;; the function type is only an assertion on calls --- it doesn't
601 ;;; constrain the type of default values. So we have to union in the
602 ;;; type of the default. With optionals, we can't do any assertion
603 ;;; unless the default is constant.
605 ;;; With keywords, we exploit our knowledge about how hairy keyword
606 ;;; defaulting is done when computing the type assertion to put on the
607 ;;; main-entry argument. In the case of hairy keywords, the default
608 ;;; has been clobbered with NIL, which is the value of the main-entry
609 ;;; arg in the unsupplied case, whatever the actual default value is.
610 ;;; So we can just assume the default is constant, effectively
611 ;;; unioning in NULL, and not totally blow off doing any type
613 (defun find-optional-dispatch-types (od type where
)
614 (declare (type optional-dispatch od
)
617 (let ((od-min (optional-dispatch-min-args od
))
618 (od-max (optional-dispatch-max-args od
))
619 (od-more (optional-dispatch-more-entry od
))
620 (od-keyp (optional-dispatch-keyp od
))
621 (od-allowp (optional-dispatch-allowp od
))
622 (type-required (fun-type-required type
))
623 (type-optional (fun-type-optional type
))
624 (type-rest (fun-type-rest type
))
625 (type-keyp (fun-type-keyp type
))
626 (type-allowp (fun-type-allowp type
)))
627 (flet ((check-num (num-definition num-type arg-kind
)
628 (unless (= num-definition num-type
)
630 "The definition has ~R ~A arg~P, but ~A has ~R."
631 num-definition arg-kind num-definition where num-type
)))
632 (check-section (in-od-p in-type-p section
)
633 (unless (eq in-od-p in-type-p
)
635 "The definition ~:[doesn't have~;has~] ~A, but ~
636 ~A ~:[doesn't~;does~]."
637 in-od-p section where in-type-p
))))
638 (check-num od-min
(length type-required
) 'required
)
639 ;; When TYPE does not have &OPTIONAL parameters and the type of
640 ;; the &REST parameter is T, it may have been simplified from
642 ;; (function (... &optional t &rest t ...) ...)
644 ;; We cannot check the exact number of optional parameters then.
645 (unless (and (not type-optional
)
646 type-rest
(type= type-rest
*universal-type
*))
647 (check-num (- od-max od-min
) (length type-optional
) '&optional
))
648 (check-section od-keyp type-keyp
"&KEY arguments")
650 (check-section (not (null od-more
)) (not (null type-rest
))
652 (check-section od-allowp type-allowp
'&allow-other-keys
))
654 (when *lossage-detected
*
655 (return-from find-optional-dispatch-types
(values nil nil
)))
659 (let ((keys (fun-type-keywords type
))
660 (arglist (optional-dispatch-arglist od
)))
661 (dolist (arg arglist
)
663 ((lambda-var-arg-info arg
)
664 (let* ((info (lambda-var-arg-info arg
))
665 (default (arg-info-default info
))
666 (def-type (when (sb!xc
:constantp default
)
667 (ctype-of (constant-form-value default
)))))
668 (ecase (arg-info-kind info
)
670 (let* ((key (arg-info-key info
))
671 (kinfo (find key keys
:key
#'key-info-name
)))
674 (res (type-union (key-info-type kinfo
)
675 (or def-type
(specifier-type 'null
)))))
678 "Defining a ~S keyword not present in ~A."
680 (res *universal-type
*)))))
681 (:required
(res (pop type-required
)))
683 ;; We can exhaust TYPE-OPTIONAL when the type was
684 ;; simplified as described above.
685 (res (type-union (or (pop type-optional
)
687 (or def-type
*universal-type
*))))
689 (when (fun-type-rest type
)
690 (res (specifier-type 'list
))))
692 (when (fun-type-rest type
)
693 (res *universal-type
*)))
695 (when (fun-type-rest type
)
696 (res (specifier-type 'fixnum
)))))
698 (when (arg-info-supplied-p info
)
699 (res *universal-type
*)
700 (vars (arg-info-supplied-p info
)))))
702 (res (pop type-required
))
706 (unless (find (key-info-name key
) arglist
708 (let ((info (lambda-var-arg-info x
)))
710 (arg-info-key info
)))))
712 "The definition lacks the ~S key present in ~A."
713 (key-info-name key
) where
))))
715 (try-type-intersections (vars) (res) where
))))
717 ;;; Check that TYPE doesn't specify any funny args, and do the
719 (defun find-lambda-types (lambda type where
)
720 (declare (type clambda lambda
) (type fun-type type
) (string where
))
721 (flet ((frob (x what
)
724 "The definition has no ~A, but the ~A did."
726 (frob (fun-type-optional type
) "&OPTIONAL arguments")
727 (frob (fun-type-keyp type
) "&KEY arguments")
728 (frob (fun-type-rest type
) "&REST argument"))
729 (let* ((vars (lambda-vars lambda
))
730 (nvars (length vars
))
731 (req (fun-type-required type
))
733 (unless (= nvars nreq
)
734 (note-lossage "The definition has ~R arg~:P, but the ~A has ~R."
736 (if *lossage-detected
*
738 (try-type-intersections vars req where
))))
740 ;;; Check for syntactic and type conformance between the definition
741 ;;; FUNCTIONAL and the specified FUN-TYPE. If they are compatible
742 ;;; and REALLY-ASSERT is T, then add type assertions to the definition
743 ;;; from the FUN-TYPE.
745 ;;; If there is a syntactic or type problem, then we call
746 ;;; LOSSAGE-FUN with an error message using WHERE as context
747 ;;; describing where FUN-TYPE came from.
749 ;;; If there is no problem, we return T (even if REALLY-ASSERT was
750 ;;; false). If there was a problem, we return NIL.
751 (defun assert-definition-type
752 (functional type
&key
(really-assert t
)
753 ((:lossage-fun
*lossage-fun
*)
754 #'compiler-style-warn
)
756 (where "previous declaration"))
757 (declare (type functional functional
)
758 (type function
*lossage-fun
*)
760 (unless (fun-type-p type
)
761 (return-from assert-definition-type t
))
762 (let ((*lossage-detected
* nil
))
763 (multiple-value-bind (vars types
)
764 (if (fun-type-wild-args type
)
766 (etypecase functional
768 (find-optional-dispatch-types functional type where
))
770 (find-lambda-types functional type where
))))
771 (let* ((type-returns (fun-type-returns type
))
772 (return (lambda-return (main-entry functional
)))
774 (lvar-derived-type (return-result return
)))))
776 ((and dtype
(not (values-types-equal-or-intersect dtype
779 "The result type from ~A:~% ~S~@
780 conflicts with the definition's result type:~% ~S"
781 where
(type-specifier type-returns
) (type-specifier dtype
))
783 (*lossage-detected
* nil
)
784 ((not really-assert
) t
)
786 (let ((policy (lexenv-policy (functional-lexenv functional
))))
787 (when (policy policy
(> type-check
0))
788 (assert-lvar-type (return-result return
) type-returns
790 (loop for var in vars and type in types do
791 (cond ((basic-var-sets var
)
792 (when (and unwinnage-fun
793 (not (csubtypep (leaf-type var
) type
)))
794 (funcall unwinnage-fun
795 "Assignment to argument: ~S~% ~
796 prevents use of assertion from function ~
798 (leaf-debug-name var
)
800 (type-specifier type
))))
802 (setf (leaf-type var
) type
)
803 (let ((s-type (make-single-value-type type
)))
804 (dolist (ref (leaf-refs var
))
805 (derive-node-type ref s-type
))))))
808 ;;; FIXME: This is quite similar to ASSERT-NEW-DEFINITION.
809 (defun assert-global-function-definition-type (name fun
)
810 (declare (type functional fun
))
811 (let ((type (info :function
:type name
))
812 (where (info :function
:where-from name
)))
813 (when (eq where
:declared
)
814 (let ((type (massage-global-definition-type type fun
)))
815 (setf (leaf-type fun
) type
)
816 (assert-definition-type
818 :unwinnage-fun
#'compiler-notify
819 :where
"proclamation"
820 :really-assert
(not (awhen (info :function
:info name
)
821 (ir1-attributep (fun-info-attributes it
)
822 explicit-check
))))))))
824 ;;; If the function has both &REST and &KEY, FIND-OPTIONAL-DISPATCH-TYPES
825 ;;; doesn't complain about the type missing &REST -- which is good, because in
826 ;;; that case &REST is really an implementation detail and not part of the
827 ;;; interface. However since we set the leaf type missing &REST from there
828 ;;; would be a bad thing -- to make up a new type if necessary.
829 (defun massage-global-definition-type (type fun
)
830 (if (and (fun-type-p type
)
831 (optional-dispatch-p fun
)
832 (optional-dispatch-keyp fun
)
833 (optional-dispatch-more-entry fun
)
834 (not (or (fun-type-rest type
)
835 (fun-type-wild-args type
))))
836 (make-fun-type :required
(fun-type-required type
)
837 :optional
(fun-type-optional type
)
838 :rest
*universal-type
*
839 :keyp
(fun-type-keyp type
)
840 :keywords
(fun-type-keywords type
)
841 :allowp
(fun-type-allowp type
)
842 :returns
(fun-type-returns type
))
845 ;;; Call FUN with (arg-lvar arg-type)
846 (defun map-combination-args-and-types (fun call
)
847 (declare (type function fun
) (type combination call
))
848 (binding* ((type (lvar-type (combination-fun call
)))
849 (nil (fun-type-p type
) :exit-if-null
)
850 (args (combination-args call
)))
851 (dolist (req (fun-type-required type
))
852 (when (null args
) (return-from map-combination-args-and-types
))
853 (let ((arg (pop args
)))
854 (funcall fun arg req
)))
855 (dolist (opt (fun-type-optional type
))
856 (when (null args
) (return-from map-combination-args-and-types
))
857 (let ((arg (pop args
)))
858 (funcall fun arg opt
)))
860 (let ((rest (fun-type-rest type
)))
863 (funcall fun arg rest
))))
865 (dolist (key (fun-type-keywords type
))
866 (let ((name (key-info-name key
)))
867 (do ((arg args
(cddr arg
)))
869 (let ((keyname (first arg
)))
870 (when (and (constant-lvar-p keyname
)
871 (eq (lvar-value keyname
) name
))
872 (funcall fun
(second arg
) (key-info-type key
)))))))))
874 ;;; Assert that CALL is to a function of the specified TYPE. It is
875 ;;; assumed that the call is legal and has only constants in the
876 ;;; keyword positions.
877 (defun assert-call-type (call type
&optional
(trusted t
))
878 (declare (type combination call
) (type fun-type type
))
879 (let ((policy (lexenv-policy (node-lexenv call
)))
880 (returns (fun-type-returns type
)))
882 (derive-node-type call returns
)
883 (let ((lvar (node-lvar call
)))
884 ;; If the value is used in a non-tail position, and the lvar
885 ;; is a single-use, assert the type. Multiple use sites need
886 ;; to be elided because the assertion has to apply to all
887 ;; uses. Tail positions are elided because the assertion
888 ;; would cause us not the be in a tail-position anymore. MV
889 ;; calls are elided because not only are the assertions of
890 ;; less use there, but they can cause the MV call conversion
893 (not (return-p (lvar-dest lvar
)))
894 (not (mv-combination-p (lvar-dest lvar
)))
895 (lvar-has-single-use-p lvar
))
896 (when (assert-lvar-type lvar returns policy
)
897 (reoptimize-lvar lvar
)))))
898 (map-combination-args-and-types
900 (when (assert-lvar-type arg type policy
)
901 (unless trusted
(reoptimize-lvar arg
))))
905 ;;;; FIXME: Move to some other file.
906 (defun check-catch-tag-type (tag)
907 (declare (type lvar tag
))
908 (let ((ctype (lvar-type tag
)))
909 (when (csubtypep ctype
(specifier-type '(or number character
)))
910 (let ((sources (lvar-all-sources tag
)))
911 (if (singleton-p sources
)
913 "~@<using ~S of type ~S as a catch tag (which ~
914 tends to be unportable because THROW and CATCH ~
915 use EQ comparison)~@:>"
917 (type-specifier (lvar-type tag
)))
919 "~@<using ~{~S~^~#[~; or ~:;, ~]~} in ~S of type ~S ~
920 as a catch tag (which tends to be unportable ~
921 because THROW and CATCH use EQ comparison)~@:>"
922 (rest sources
) (first sources
)
923 (type-specifier (lvar-type tag
))))))))
925 (defun %compile-time-type-error
(values atype dtype detail context
)
926 (declare (ignore dtype
))
927 (if (and (consp atype
) (eq (car atype
) 'values
))
928 (if (singleton-p detail
)
929 (error 'simple-type-error
933 "~@<Value set ~2I~_[~{~S~^ ~}] ~I~_from ~S in~_~A ~I~_is ~
934 not of type ~2I~_~S.~:>"
935 :format-arguments
(list values
936 (first detail
) context
938 (error 'simple-type-error
942 "~@<Value set ~2I~_[~{~S~^ ~}] ~
943 ~I~_from ~2I~_~{~S~^~#[~; or ~:;, ~]~} ~
944 ~I~_of ~2I~_~S ~I~_in~_~A ~I~_is not of type ~2I~_~S.~:>"
945 :format-arguments
(list values
946 (rest detail
) (first detail
)
949 (if (singleton-p detail
)
950 (error 'simple-type-error
953 :format-control
"~@<Value of ~S in ~_~A ~I~_is ~2I~_~S, ~
954 ~I~_not a ~2I~_~S.~:@>"
955 :format-arguments
(list (car detail
) context
958 (error 'simple-type-error
961 :format-control
"~@<Value from ~2I~_~{~S~^~#[~; or ~:;, ~]~} ~
962 ~I~_of ~2I~_~S ~I~_in~_~A ~I~_is ~2I~_~S, ~
963 ~I~_not a ~2I~_~S.~:@>"
964 :format-arguments
(list (rest detail
) (first detail
) context
968 (defoptimizer (%compile-time-type-error ir2-convert
)
969 ((objects atype dtype detail context
) node block
)
970 (declare (ignore objects context
))
971 (let ((*compiler-error-context
* node
))
972 (setf (node-source-path node
)
973 (cdr (node-source-path node
)))
974 (let ((atype (lvar-value atype
))
975 (dtype (lvar-value dtype
))
976 (detail (lvar-value detail
)))
977 (unless (eq atype nil
)
978 (if (singleton-p detail
)
979 (let ((detail (first detail
)))
980 (if (constantp detail
)
983 "~@<Constant ~2I~_~S ~Iconflicts with its ~
984 asserted type ~2I~_~S.~@:>"
985 :format-arguments
(list (eval detail
) atype
))
988 "~@<Derived type of ~S is ~2I~_~S, ~
989 ~I~_conflicting with ~
990 its asserted type ~2I~_~S.~@:>"
991 :format-arguments
(list detail dtype atype
))))
994 "~@<Derived type of ~2I~_~{~S~^~#[~; and ~:;, ~]~} ~
995 ~I~_in ~2I~_~S ~I~_is ~2I~_~S, ~I~_conflicting with ~
996 their asserted type ~2I~_~S.~@:>"
997 :format-arguments
(list (rest detail
) (first detail
) dtype atype
)))))
998 (ir2-convert-full-call node block
)))