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
*)
57 (defvar *valid-fun-use-name
*)
59 ;;; Signal a warning if appropriate and set *FOO-DETECTED*.
60 (declaim (ftype (function (string &rest t
) (values)) note-lossage note-unwinnage
))
61 (defun note-lossage (format-string &rest format-args
)
62 (setq *lossage-detected
* t
)
64 (apply *lossage-fun
* format-string format-args
))
66 (defun note-unwinnage (format-string &rest format-args
)
67 (setq *unwinnage-detected
* t
)
69 (apply *unwinnage-fun
* format-string format-args
))
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 (awhen (lvar-fun-name (combination-fun call
) t
)
178 (let ((type (info :function
:type it
))
179 (info (info :function
:info it
)))
180 (when (and (not *lossage-detected
*)
182 (fun-info-callable-check info
))
183 (let ((*valid-fun-use-name
* it
))
184 (apply (fun-info-callable-check info
)
185 (resolve-key-args args type
))))
186 ;; One more check for structure constructors:
187 (when (typep type
'defstruct-description
)
188 (awhen (assq it
(dd-constructors type
))
189 (check-structure-constructor-call call type
(cdr it
))))))
190 (cond (*lossage-detected
* (values nil t
))
191 (*unwinnage-detected
* (values nil nil
))
194 ;;; Turn constant LVARs in keyword arg positions to constants so that
195 ;;; they can be passed to FUN-INFO-CALLABLE-CHECK.
196 (defun resolve-key-args (args type
)
197 (if (fun-type-keyp type
)
198 (let ((non-key (+ (length (fun-type-required type
))
199 (length (fun-type-optional type
))))
201 (do ((key (nthcdr non-key args
) (cddr key
)))
203 (let ((k (first key
))
205 (when (constant-lvar-p k
)
206 (let* ((name (lvar-value k
))
207 (info (find name
(fun-type-keywords type
)
208 :key
#'key-info-name
)))
210 (push name key-arguments
)
211 (push v key-arguments
))))))
213 (nconc (subseq args
0 non-key
)
214 (nreverse key-arguments
)))
217 ;;; Return MIN, MAX, whether it contaions &optional/&key/&rest
218 (defun fun-arg-limits (function)
219 (cond ((fun-type-p function
)
220 (if (fun-type-wild-args function
)
222 (let* ((min (length (fun-type-required function
)))
223 (max (and (not (or (fun-type-rest function
)
224 (fun-type-keyp function
)))
226 (length (fun-type-optional function
))))))
227 (values min max
(or (fun-type-rest function
)
228 (fun-type-keyp function
)
229 (fun-type-optional function
))))))
231 (let ((args (length (lambda-vars function
))))
233 ((not (optional-dispatch-p function
))
234 (values nil nil nil
))
235 ((optional-dispatch-more-entry function
)
236 (values (optional-dispatch-min-args function
)
240 (values (optional-dispatch-min-args function
)
241 (optional-dispatch-max-args function
)
244 (defun valid-callable-argument (lvar arg-count
)
246 ;; Handle #'function, 'function and (lambda (x y))
247 (let* ((use (principal-lvar-use lvar
))
248 (leaf (if (ref-p use
)
250 (return-from valid-callable-argument nil
)))
251 (defined-type (and (global-var-p leaf
)
252 (global-var-defined-type leaf
)))
253 (lvar-type (or defined-type
255 (fun-name (cond ((or (fun-type-p lvar-type
)
257 (if (constant-lvar-p lvar
)
258 #+sb-xc-host
(bug "Can't call %FUN-NAME")
259 #-sb-xc-host
(%fun-name
(lvar-value lvar
))
260 (lvar-fun-debug-name lvar
)))
261 ((constant-lvar-p lvar
)
264 (return-from valid-callable-argument nil
))))
265 (type (cond ((fun-type-p lvar-type
)
268 (proclaimed-ftype fun-name
))
271 (*lossage-fun
* (if (and (not (eq (leaf-where-from leaf
)
273 (not (lambda-p leaf
))
275 (not (info :function
:info fun-name
))))
276 #'compiler-style-warn
278 (multiple-value-bind (min max optional
)
279 (fun-arg-limits type
)
281 ((and (not min
) (not max
)))
283 (when (/= arg-count min
)
285 "The function ~S is called by ~S with ~R argument~:P, but wants exactly ~R."
291 "The function ~S is called by ~S with ~R argument~:P, but wants at least ~R."
298 "The function ~S called by ~S with ~R argument~:P, but wants at most ~R."
303 (defun check-structure-constructor-call (call dd ctor-ll-parts
)
304 (destructuring-bind (&optional req opt rest keys aux
)
305 (and (listp ctor-ll-parts
) (cdr ctor-ll-parts
))
306 (declare (ignore rest
))
307 (let* ((call-args (combination-args call
))
309 (keyword-lvars (nthcdr (+ n-req
(length opt
)) call-args
))
310 (const-keysp (check-key-args-constant keyword-lvars
))
311 (n-call-args (length call-args
)))
312 (dolist (slot (dd-slots dd
))
313 (let ((name (dsd-name slot
))
315 (lambda-list-element nil
))
316 ;; Ignore &AUX vars - it's not the caller's fault if wrong.
317 (unless (find name aux
:key
(lambda (x) (if (listp x
) (car x
) x
))
318 ;; is this right, or should it be EQ
319 ;; like in DETERMINE-UNSAFE-SLOTS ?
321 (multiple-value-bind (arg position
)
322 (%find-position name opt nil
0 nil
#'parse-optional-arg-spec
325 (setq suppliedp
(< (+ n-req position
) n-call-args
)
326 lambda-list-element arg
)))
327 (when (and (eq suppliedp
:maybe
) const-keysp
)
328 ;; Deduce the keyword (if any) that initializes this slot.
329 (multiple-value-bind (keyword arg
)
330 (if (listp ctor-ll-parts
)
332 (multiple-value-bind (key var
) (parse-key-arg-spec arg
)
333 (when (string= name var
) (return (values key arg
)))))
334 (values (keywordicate name
) t
))
336 (setq suppliedp
(find-keyword-lvar keyword-lvars keyword
)
337 lambda-list-element arg
))))
338 (when (eq suppliedp nil
)
339 (let ((initform (if (typep lambda-list-element
'(cons t cons
))
340 (second lambda-list-element
)
341 (dsd-default slot
))))
342 ;; Return T if value-form definitely does not satisfy
343 ;; the type-check for DSD. Return NIL if we can't decide.
344 (when (if (sb!xc
:constantp initform
)
345 (not (sb!xc
:typep
(constant-form-value initform
)
347 ;; Find uses of nil-returning functions as defaults,
348 ;; like ERROR and MISSING-ARG.
349 (and (sb!kernel
::dd-null-lexenv-p dd
)
351 (let ((f (car initform
)))
352 ;; Don't examine :function :type of macros!
353 (and (eq (info :function
:kind f
) :function
)
354 (let ((info (info :function
:type f
)))
355 (and (fun-type-p info
)
356 (type= (fun-type-returns info
)
358 (note-lossage "The slot ~S does not have a suitable default, ~
359 and no value was provided for it." name
))))))))))
361 ;;; Check that the derived type of the LVAR is compatible with TYPE. N
362 ;;; is the arg number, for error message purposes. We return true if
363 ;;; arg is definitely o.k. If the type is a magic CONSTANT-TYPE, then
364 ;;; we check for the argument being a constant value of the specified
365 ;;; type. If there is a manifest type error (DERIVED-TYPE = NIL), then
366 ;;; we flame about the asserted type even when our type is satisfied
368 (defun check-arg-type (lvar type n
)
369 (declare (type lvar lvar
) (type ctype type
) (type index n
))
371 ((not (constant-type-p type
))
372 (let ((ctype (lvar-type lvar
)))
373 (multiple-value-bind (int win
) (funcall *ctype-test-fun
* ctype type
)
375 (note-unwinnage "can't tell whether the ~:R argument is a ~S"
376 n
(type-specifier type
))
379 (note-lossage "The ~:R argument is a ~S, not a ~S."
380 n
(type-specifier ctype
) (type-specifier type
))
382 ((eq ctype
*empty-type
*)
383 (note-unwinnage "The ~:R argument never returns a value." n
)
386 ((not (constant-lvar-p lvar
))
387 (note-unwinnage "The ~:R argument is not a constant." n
)
390 (let ((val (lvar-value lvar
))
391 (type (constant-type-type type
)))
392 (multiple-value-bind (res win
) (ctypep val type
)
394 (note-unwinnage "can't tell whether the ~:R argument is a ~
396 n
(type-specifier type
) val
)
399 (note-lossage "The ~:R argument is not a constant ~S:~% ~S"
400 n
(type-specifier type
) val
)
404 ;;; Check that each of the type of each supplied argument intersects
405 ;;; with the type specified for that argument. If we can't tell, then
406 ;;; we can complain about the absence of manifest winnage.
407 (declaim (ftype (function (list list
(or ctype null
)) (values)) check-fixed-and-rest
))
408 (defun check-fixed-and-rest (args types rest
)
409 (do ((arg args
(cdr arg
))
410 (type types
(cdr type
))
412 ((or (null type
) (null arg
))
415 (check-arg-type arg rest n
)
418 (check-arg-type (car arg
) (car type
) n
))
421 ;;; Check that the &KEY args are of the correct type. Each key should
422 ;;; be known and the corresponding argument should be of the correct
423 ;;; type. If the key isn't a constant, then we can't tell, so we can
424 ;;; complain about absence of manifest winnage.
425 (declaim (ftype (function (list fixnum fun-type
) (values)) check-key-args
))
426 (defun check-key-args (args pre-key type
)
427 (let (lossages allow-other-keys
)
428 (do ((key (nthcdr pre-key args
) (cddr key
))
429 (n (1+ pre-key
) (+ n
2)))
432 (let ((k (first key
))
435 ((not (check-arg-type k
(specifier-type 'symbol
) n
)))
436 ((not (constant-lvar-p k
))
437 (note-unwinnage "~@<The ~:R argument (in keyword position) is not ~
438 a constant, weakening keyword argument ~
440 ;; An unknown key may turn out to be :ALLOW-OTHER-KEYS at runtime,
441 ;; so we cannot signal full warnings for keys that look bad.
442 (unless allow-other-keys
443 (setf allow-other-keys
:maybe
)))
445 (let* ((name (lvar-value k
))
446 (info (find name
(fun-type-keywords type
)
447 :key
#'key-info-name
)))
448 (cond ((eq name
:allow-other-keys
)
449 (unless allow-other-keys
450 (if (constant-lvar-p v
)
451 (setf allow-other-keys
(if (lvar-value v
)
454 (setf allow-other-keys
:maybe
))))
456 (unless (fun-type-allowp type
)
457 (pushnew name lossages
:test
#'eq
)))
459 (check-arg-type (second key
) (key-info-type info
)
461 (when (and lossages
(member allow-other-keys
'(nil :no
)))
462 (setf lossages
(nreverse lossages
))
464 (note-lossage "~@<~{~S~^, ~} and ~S are not a known argument keywords.~:@>"
466 (car (last lossages
)))
467 (note-lossage "~S is not a known argument keyword."
471 ;;; Construct a function type from a definition.
473 ;;; Due to the lack of a (LIST X) type specifier, we can't reconstruct
475 (declaim (ftype (sfunction (functional) fun-type
) definition-type
))
476 (defun definition-type (functional)
477 (if (lambda-p functional
)
479 :required
(mapcar #'leaf-type
(lambda-vars functional
))
480 :returns
(tail-set-type (lambda-tail-set functional
)))
485 (dolist (arg (optional-dispatch-arglist functional
))
486 (let ((info (lambda-var-arg-info arg
))
487 (type (leaf-type arg
)))
489 (ecase (arg-info-kind info
)
490 (:required
(req type
))
491 (:optional
(opt type
))
493 (keys (make-key-info :name
(arg-info-key info
)
495 ((:rest
:more-context
)
496 (setq rest
*universal-type
*))
505 :keyp
(optional-dispatch-keyp functional
)
506 :allowp
(optional-dispatch-allowp functional
)
507 :returns
(tail-set-type
509 (optional-dispatch-main-entry functional
))))))))
511 ;;;; approximate function types
513 ;;;; FIXME: This is stuff to look at when I get around to fixing function
514 ;;;; type inference and declarations.
516 ;;;; Approximate function types provide a condensed representation of all the
517 ;;;; different ways that a function has been used. If we have no declared or
518 ;;;; defined type for a function, then we build an approximate function type by
519 ;;;; examining each use of the function. When we encounter a definition or
520 ;;;; proclamation, we can check the actual type for compatibity with the
523 (defstruct (approximate-fun-type (:copier nil
))
524 ;; the smallest and largest numbers of arguments that this function
525 ;; has been called with.
526 (min-args sb
!xc
:call-arguments-limit
527 :type
(integer 0 #.sb
!xc
:call-arguments-limit
))
529 :type
(integer 0 #.sb
!xc
:call-arguments-limit
))
530 ;; a list of lists of the all the types that have been used in each
532 (types () :type list
)
533 ;; A list of APPROXIMATE-KEY-INFO structures describing all the
534 ;; things that looked like &KEY arguments. There are distinct
535 ;; structures describing each argument position in which the keyword
537 (keys () :type list
))
539 (defstruct (approximate-key-info (:copier nil
))
540 ;; The keyword name of this argument. Although keyword names don't
541 ;; have to be keywords, we only match on keywords when figuring an
543 (name (missing-arg) :type keyword
)
544 ;; The position at which this keyword appeared. 0 if it appeared as the
545 ;; first argument, etc.
546 (position (missing-arg)
547 :type
(integer 0 #.sb
!xc
:call-arguments-limit
))
548 ;; a list of all the argument types that have been used with this keyword
549 (types nil
:type list
)
550 ;; true if this keyword has appeared only in calls with an obvious
552 (allowp nil
:type
(member t nil
)))
554 ;;; Return an APPROXIMATE-FUN-TYPE representing the context of
555 ;;; CALL. If TYPE is supplied and not null, then we merge the
556 ;;; information into the information already accumulated in TYPE.
557 (declaim (ftype (function (combination
558 &optional
(or approximate-fun-type null
))
559 approximate-fun-type
)
561 (defun note-fun-use (call &optional type
)
562 (let* ((type (or type
(make-approximate-fun-type)))
563 (types (approximate-fun-type-types type
))
564 (args (combination-args call
))
565 (nargs (length args
))
566 (allowp (some (lambda (x)
567 (and (constant-lvar-p x
)
568 (eq (lvar-value x
) :allow-other-keys
)))
571 (setf (approximate-fun-type-min-args type
)
572 (min (approximate-fun-type-min-args type
) nargs
))
573 (setf (approximate-fun-type-max-args type
)
574 (max (approximate-fun-type-max-args type
) nargs
))
576 (do ((old types
(cdr old
))
577 (arg args
(cdr arg
)))
579 (setf (approximate-fun-type-types type
)
582 (list (lvar-type x
)))
584 (when (null arg
) (return))
585 (pushnew (lvar-type (car arg
))
589 (collect ((keys (approximate-fun-type-keys type
) cons
))
590 (do ((arg args
(cdr arg
))
592 ((or (null arg
) (null (cdr arg
)))
593 (setf (approximate-fun-type-keys type
) (keys)))
594 (let ((key (first arg
))
596 (when (constant-lvar-p key
)
597 (let ((name (lvar-value key
)))
598 (when (keywordp name
)
601 (and (eq (approximate-key-info-name x
) name
)
602 (= (approximate-key-info-position x
)
605 (val-type (lvar-type val
)))
608 (approximate-key-info-types old
)
611 (setf (approximate-key-info-allowp old
) nil
)))
613 (keys (make-approximate-key-info
617 :types
(list val-type
))))))))))))
620 ;;; This is similar to VALID-FUN-USE, but checks an
621 ;;; APPROXIMATE-FUN-TYPE against a real function type.
622 (declaim (ftype (function (approximate-fun-type fun-type
623 &optional function function function
)
624 (values boolean boolean
))
625 valid-approximate-type
))
626 (defun valid-approximate-type (call-type type
&optional
628 #'types-equal-or-intersect
)
630 #'compiler-style-warn
)
631 (*unwinnage-fun
* #'compiler-notify
))
632 (let* ((*lossage-detected
* nil
)
633 (*unwinnage-detected
* nil
)
634 (required (fun-type-required type
))
635 (min-args (length required
))
636 (optional (fun-type-optional type
))
637 (max-args (+ min-args
(length optional
)))
638 (rest (fun-type-rest type
))
639 (keyp (fun-type-keyp type
)))
641 (when (fun-type-wild-args type
)
642 (return-from valid-approximate-type
(values t t
)))
644 (let ((call-min (approximate-fun-type-min-args call-type
)))
645 (when (< call-min min-args
)
647 "~:@<The function was previously called with ~R argument~:P, ~
648 but wants at least ~R.~:>"
651 (let ((call-max (approximate-fun-type-max-args call-type
)))
652 (cond ((<= call-max max-args
))
653 ((not (or keyp rest
))
655 "~:@<The function was previously called with ~R argument~:P, ~
656 but wants at most ~R.~:>"
658 ((and keyp
(oddp (- call-max max-args
)))
660 "~:@<The function was previously called with an odd number of ~
661 arguments in the keyword portion.~:>")))
663 (when (and keyp
(> call-max max-args
))
664 (check-approximate-keywords call-type max-args type
)))
666 (check-approximate-fixed-and-rest call-type
(append required optional
)
669 (cond (*lossage-detected
* (values nil t
))
670 (*unwinnage-detected
* (values nil nil
))
673 ;;; Check that each of the types used at each arg position is
674 ;;; compatible with the actual type.
675 (declaim (ftype (function (approximate-fun-type list
(or ctype null
))
677 check-approximate-fixed-and-rest
))
678 (defun check-approximate-fixed-and-rest (call-type fixed rest
)
679 (do ((types (approximate-fun-type-types call-type
) (cdr types
))
681 (arg fixed
(cdr arg
)))
683 (let ((decl-type (or (car arg
) rest
)))
684 (unless decl-type
(return))
685 (check-approximate-arg-type (car types
) decl-type
"~:R" n
)))
688 ;;; Check that each of the call-types is compatible with DECL-TYPE,
689 ;;; complaining if not or if we can't tell.
690 (declaim (ftype (function (list ctype string
&rest t
) (values))
691 check-approximate-arg-type
))
692 (defun check-approximate-arg-type (call-types decl-type context
&rest args
)
693 (let ((losers *empty-type
*))
694 (dolist (ctype call-types
)
695 (multiple-value-bind (int win
) (funcall *ctype-test-fun
* ctype decl-type
)
698 (note-unwinnage "can't tell whether previous ~? ~
699 argument type ~S is a ~S"
702 (type-specifier ctype
)
703 (type-specifier decl-type
)))
705 (setq losers
(type-union ctype losers
))))))
707 (unless (eq losers
*empty-type
*)
708 (note-lossage "~:(~?~) argument should be a ~S but was a ~S in a previous call."
709 context args
(type-specifier decl-type
) (type-specifier losers
))))
712 ;;; Check the types of each manifest keyword that appears in a keyword
713 ;;; argument position. Check the validity of all keys that appeared in
714 ;;; valid keyword positions.
716 ;;; ### We could check the APPROXIMATE-FUN-TYPE-TYPES to make
717 ;;; sure that all arguments in keyword positions were manifest
719 (defun check-approximate-keywords (call-type max-args type
)
720 (let ((call-keys (approximate-fun-type-keys call-type
))
721 (keys (fun-type-keywords type
)))
723 (let ((name (key-info-name key
)))
724 (collect ((types nil append
))
725 (dolist (call-key call-keys
)
726 (let ((pos (approximate-key-info-position call-key
)))
727 (when (and (eq (approximate-key-info-name call-key
) name
)
728 (> pos max-args
) (evenp (- pos max-args
)))
729 (types (approximate-key-info-types call-key
)))))
730 (check-approximate-arg-type (types) (key-info-type key
) "~S" name
))))
732 (unless (fun-type-allowp type
)
733 (collect ((names () adjoin
))
734 (dolist (call-key call-keys
)
735 (let ((pos (approximate-key-info-position call-key
)))
736 (when (and (> pos max-args
) (evenp (- pos max-args
))
737 (not (approximate-key-info-allowp call-key
)))
738 (names (approximate-key-info-name call-key
)))))
740 (dolist (name (names))
741 (unless (find name keys
:key
#'key-info-name
)
742 (note-lossage "Function previously called with unknown argument keyword ~S."
745 ;;;; ASSERT-DEFINITION-TYPE
747 ;;; Intersect LAMBDA's var types with TYPES, giving a warning if there
748 ;;; is a mismatch. If all intersections are non-null, we return lists
749 ;;; of the variables and intersections, otherwise we return NIL, NIL.
750 (defun try-type-intersections (vars types where
)
751 (declare (list vars types
) (string where
))
753 (mapc (lambda (var type
)
754 (let* ((vtype (leaf-type var
))
755 (int (type-approx-intersection2 vtype type
)))
757 ((eq int
*empty-type
*)
759 "Definition's declared type for variable ~A:~% ~S~@
760 conflicts with this type from ~A:~% ~S"
761 (leaf-debug-name var
) (type-specifier vtype
)
762 where
(type-specifier type
))
763 (return-from try-type-intersections
(values nil nil
)))
767 (values vars
(res))))
769 ;;; Check that the optional-dispatch OD conforms to TYPE. We return
770 ;;; the values of TRY-TYPE-INTERSECTIONS if there are no syntax
771 ;;; problems, otherwise NIL, NIL.
773 ;;; Note that the variables in the returned list are the actual
774 ;;; original variables (extracted from the optional dispatch arglist),
775 ;;; rather than the variables that are arguments to the main entry.
776 ;;; This difference is significant only for &KEY args with hairy
777 ;;; defaults. Returning the actual vars allows us to use the right
778 ;;; variable name in warnings.
780 ;;; A slightly subtle point: with keywords and optionals, the type in
781 ;;; the function type is only an assertion on calls --- it doesn't
782 ;;; constrain the type of default values. So we have to union in the
783 ;;; type of the default. With optionals, we can't do any assertion
784 ;;; unless the default is constant.
786 ;;; With keywords, we exploit our knowledge about how hairy keyword
787 ;;; defaulting is done when computing the type assertion to put on the
788 ;;; main-entry argument. In the case of hairy keywords, the default
789 ;;; has been clobbered with NIL, which is the value of the main-entry
790 ;;; arg in the unsupplied case, whatever the actual default value is.
791 ;;; So we can just assume the default is constant, effectively
792 ;;; unioning in NULL, and not totally blow off doing any type
794 (defun find-optional-dispatch-types (od type where
)
795 (declare (type optional-dispatch od
)
798 (let ((od-min (optional-dispatch-min-args od
))
799 (od-max (optional-dispatch-max-args od
))
800 (od-more (optional-dispatch-more-entry od
))
801 (od-keyp (optional-dispatch-keyp od
))
802 (od-allowp (optional-dispatch-allowp od
))
803 (type-required (fun-type-required type
))
804 (type-optional (fun-type-optional type
))
805 (type-rest (fun-type-rest type
))
806 (type-keyp (fun-type-keyp type
))
807 (type-allowp (fun-type-allowp type
)))
808 (flet ((check-num (num-definition num-type arg-kind
)
809 (unless (= num-definition num-type
)
811 "The definition has ~R ~A arg~P, but ~A has ~R."
812 num-definition arg-kind num-definition where num-type
)))
813 (check-section (in-od-p in-type-p section
)
814 (unless (eq in-od-p in-type-p
)
816 "The definition ~:[doesn't have~;has~] ~A, but ~
817 ~A ~:[doesn't~;does~]."
818 in-od-p section where in-type-p
))))
819 (check-num od-min
(length type-required
) 'required
)
820 ;; When TYPE does not have &OPTIONAL parameters and the type of
821 ;; the &REST parameter is T, it may have been simplified from
823 ;; (function (... &optional t &rest t ...) ...)
825 ;; We cannot check the exact number of optional parameters then.
826 (unless (and (not type-optional
)
827 type-rest
(type= type-rest
*universal-type
*))
828 (check-num (- od-max od-min
) (length type-optional
) '&optional
))
829 (check-section od-keyp type-keyp
"&KEY arguments")
831 (check-section (not (null od-more
)) (not (null type-rest
))
833 (check-section od-allowp type-allowp
'&allow-other-keys
))
835 (when *lossage-detected
*
836 (return-from find-optional-dispatch-types
(values nil nil
)))
840 (let ((keys (fun-type-keywords type
))
841 (arglist (optional-dispatch-arglist od
)))
842 (dolist (arg arglist
)
844 ((lambda-var-arg-info arg
)
845 (let* ((info (lambda-var-arg-info arg
))
846 (default (arg-info-default info
))
847 (def-type (when (sb!xc
:constantp default
)
848 (ctype-of (constant-form-value default
)))))
849 (ecase (arg-info-kind info
)
851 (let* ((key (arg-info-key info
))
852 (kinfo (find key keys
:key
#'key-info-name
)))
855 (res (type-union (key-info-type kinfo
)
856 (or def-type
(specifier-type 'null
)))))
859 "Defining a ~S keyword not present in ~A."
861 (res *universal-type
*)))))
862 (:required
(res (pop type-required
)))
864 ;; We can exhaust TYPE-OPTIONAL when the type was
865 ;; simplified as described above.
866 (res (type-union (or (pop type-optional
)
868 (or def-type
*universal-type
*))))
870 (when (fun-type-rest type
)
871 (res (specifier-type 'list
))))
873 (when (fun-type-rest type
)
874 (res *universal-type
*)))
876 (when (fun-type-rest type
)
877 (res (specifier-type 'fixnum
)))))
879 (when (arg-info-supplied-p info
)
880 (res *universal-type
*)
881 (vars (arg-info-supplied-p info
)))))
883 (res (pop type-required
))
887 (unless (find (key-info-name key
) arglist
889 (let ((info (lambda-var-arg-info x
)))
891 (arg-info-key info
)))))
893 "The definition lacks the ~S key present in ~A."
894 (key-info-name key
) where
))))
896 (try-type-intersections (vars) (res) where
))))
898 ;;; Check that TYPE doesn't specify any funny args, and do the
900 (defun find-lambda-types (lambda type where
)
901 (declare (type clambda lambda
) (type fun-type type
) (string where
))
902 (flet ((frob (x what
)
905 "The definition has no ~A, but the ~A did."
907 (frob (fun-type-optional type
) "&OPTIONAL arguments")
908 (frob (fun-type-keyp type
) "&KEY arguments")
909 (frob (fun-type-rest type
) "&REST argument"))
910 (let* ((vars (lambda-vars lambda
))
911 (nvars (length vars
))
912 (req (fun-type-required type
))
914 (unless (= nvars nreq
)
915 (note-lossage "The definition has ~R arg~:P, but the ~A has ~R."
917 (if *lossage-detected
*
919 (try-type-intersections vars req where
))))
921 ;;; Check for syntactic and type conformance between the definition
922 ;;; FUNCTIONAL and the specified FUN-TYPE. If they are compatible
923 ;;; and REALLY-ASSERT is T, then add type assertions to the definition
924 ;;; from the FUN-TYPE.
926 ;;; If there is a syntactic or type problem, then we call
927 ;;; LOSSAGE-FUN with an error message using WHERE as context
928 ;;; describing where FUN-TYPE came from.
930 ;;; If there is no problem, we return T (even if REALLY-ASSERT was
931 ;;; false). If there was a problem, we return NIL.
932 (defun assert-definition-type
933 (functional type
&key
(really-assert t
)
934 ((:lossage-fun
*lossage-fun
*)
935 #'compiler-style-warn
)
937 (where "previous declaration"))
938 (declare (type functional functional
)
939 (type function
*lossage-fun
*)
941 (unless (fun-type-p type
)
942 (return-from assert-definition-type t
))
943 (let ((*lossage-detected
* nil
))
944 (multiple-value-bind (vars types
)
945 (if (fun-type-wild-args type
)
947 (etypecase functional
949 (find-optional-dispatch-types functional type where
))
951 (find-lambda-types functional type where
))))
952 (let* ((type-returns (fun-type-returns type
))
953 (return (lambda-return (main-entry functional
)))
955 (lvar-derived-type (return-result return
)))))
957 ((and dtype
(not (values-types-equal-or-intersect dtype
960 "The result type from ~A:~% ~S~@
961 conflicts with the definition's result type:~% ~S"
962 where
(type-specifier type-returns
) (type-specifier dtype
))
964 (*lossage-detected
* nil
)
965 ((not really-assert
) t
)
967 (let ((policy (lexenv-policy (functional-lexenv functional
))))
968 (when (policy policy
(> type-check
0))
969 (assert-lvar-type (return-result return
) type-returns
971 (loop for var in vars and type in types do
972 (cond ((basic-var-sets var
)
973 (when (and unwinnage-fun
974 (not (csubtypep (leaf-type var
) type
)))
975 (funcall unwinnage-fun
976 "Assignment to argument: ~S~% ~
977 prevents use of assertion from function ~
979 (leaf-debug-name var
)
981 (type-specifier type
))))
983 (setf (leaf-type var
) type
)
984 (let ((s-type (make-single-value-type type
)))
985 (dolist (ref (leaf-refs var
))
986 (derive-node-type ref s-type
))))))
989 ;;; FIXME: This is quite similar to ASSERT-NEW-DEFINITION.
990 (defun assert-global-function-definition-type (name fun
)
991 (declare (type functional fun
))
992 (let ((where (info :function
:where-from name
))
993 (explicit-check (getf (functional-plist fun
) 'explicit-check
)))
994 (if (eq where
:declared
)
996 (massage-global-definition-type (proclaimed-ftype name
) fun
)))
997 (setf (leaf-type fun
) type
)
998 (assert-definition-type
1000 :unwinnage-fun
#'compiler-notify
1001 :where
"proclamation"
1002 :really-assert
(not explicit-check
)))
1003 ;; Can't actually test this. DEFSTRUCTs declare this, but non-toplevel
1004 ;; ones won't have an FTYPE at compile-time.
1006 (when explicit-check
1007 (warn "Explicit-check without known FTYPE is meaningless")))))
1009 ;;; If the function has both &REST and &KEY, FIND-OPTIONAL-DISPATCH-TYPES
1010 ;;; doesn't complain about the type missing &REST -- which is good, because in
1011 ;;; that case &REST is really an implementation detail and not part of the
1012 ;;; interface. However since we set the leaf type missing &REST from there
1013 ;;; would be a bad thing -- to make up a new type if necessary.
1014 (defun massage-global-definition-type (type fun
)
1015 (if (and (fun-type-p type
)
1016 (optional-dispatch-p fun
)
1017 (optional-dispatch-keyp fun
)
1018 (optional-dispatch-more-entry fun
)
1019 (not (or (fun-type-rest type
)
1020 (fun-type-wild-args type
))))
1021 (make-fun-type :required
(fun-type-required type
)
1022 :optional
(fun-type-optional type
)
1023 :rest
*universal-type
*
1024 :keyp
(fun-type-keyp type
)
1025 :keywords
(fun-type-keywords type
)
1026 :allowp
(fun-type-allowp type
)
1027 :returns
(fun-type-returns type
))
1030 ;;; Call FUN with (arg-lvar arg-type)
1031 (defun map-combination-args-and-types (fun call
)
1032 (declare (type function fun
) (type combination call
))
1033 (binding* ((type (lvar-type (combination-fun call
)))
1034 (nil (fun-type-p type
) :exit-if-null
)
1035 (args (combination-args call
)))
1036 (dolist (req (fun-type-required type
))
1037 (when (null args
) (return-from map-combination-args-and-types
))
1038 (let ((arg (pop args
)))
1039 (funcall fun arg req
)))
1040 (dolist (opt (fun-type-optional type
))
1041 (when (null args
) (return-from map-combination-args-and-types
))
1042 (let ((arg (pop args
)))
1043 (funcall fun arg opt
)))
1045 (let ((rest (fun-type-rest type
)))
1048 (funcall fun arg rest
))))
1050 (dolist (key (fun-type-keywords type
))
1051 (let ((name (key-info-name key
)))
1052 (do ((arg args
(cddr arg
)))
1054 (let ((keyname (first arg
)))
1055 (when (and (constant-lvar-p keyname
)
1056 (eq (lvar-value keyname
) name
))
1057 (funcall fun
(second arg
) (key-info-type key
)))))))))
1059 ;;; Assert that CALL is to a function of the specified TYPE. It is
1060 ;;; assumed that the call is legal and has only constants in the
1061 ;;; keyword positions.
1062 (defun assert-call-type (call type
&optional
(trusted t
))
1063 (declare (type combination call
) (type fun-type type
))
1064 (let ((policy (lexenv-policy (node-lexenv call
)))
1065 (returns (fun-type-returns type
)))
1067 (derive-node-type call returns
)
1068 (let ((lvar (node-lvar call
)))
1069 ;; If the value is used in a non-tail position, and the lvar
1070 ;; is a single-use, assert the type. Multiple use sites need
1071 ;; to be elided because the assertion has to apply to all
1072 ;; uses. Tail positions are elided because the assertion
1073 ;; would cause us not the be in a tail-position anymore. MV
1074 ;; calls are elided because not only are the assertions of
1075 ;; less use there, but they can cause the MV call conversion
1078 (not (return-p (lvar-dest lvar
)))
1079 (not (mv-combination-p (lvar-dest lvar
)))
1080 (lvar-has-single-use-p lvar
))
1081 (when (assert-lvar-type lvar returns policy
)
1082 (reoptimize-lvar lvar
)))))
1083 (map-combination-args-and-types
1085 (when (assert-lvar-type arg type policy
)
1086 (unless trusted
(reoptimize-lvar arg
))))
1090 ;;;; FIXME: Move to some other file.
1091 (defun check-catch-tag-type (tag)
1092 (declare (type lvar tag
))
1093 (let ((ctype (lvar-type tag
)))
1094 (when (csubtypep ctype
(specifier-type '(or number character
)))
1095 (let ((sources (lvar-all-sources tag
)))
1096 (if (singleton-p sources
)
1097 (compiler-style-warn
1098 "~@<using ~S of type ~S as a catch tag (which ~
1099 tends to be unportable because THROW and CATCH ~
1100 use EQ comparison)~@:>"
1102 (type-specifier (lvar-type tag
)))
1103 (compiler-style-warn
1104 "~@<using ~{~S~^~#[~; or ~:;, ~]~} in ~S of type ~S ~
1105 as a catch tag (which tends to be unportable ~
1106 because THROW and CATCH use EQ comparison)~@:>"
1107 (rest sources
) (first sources
)
1108 (type-specifier (lvar-type tag
))))))))
1110 (defun %compile-time-type-error
(values atype dtype detail context
)
1111 (declare (ignore dtype
))
1112 (if (and (consp atype
) (eq (car atype
) 'values
))
1113 (if (singleton-p detail
)
1114 (error 'simple-type-error
1116 :expected-type atype
1118 "~@<Value set ~2I~_[~{~S~^ ~}] ~I~_from ~S in~_~A ~I~_is ~
1119 not of type ~2I~_~S.~:>"
1120 :format-arguments
(list values
1121 (first detail
) context
1123 (error 'simple-type-error
1125 :expected-type atype
1127 "~@<Value set ~2I~_[~{~S~^ ~}] ~
1128 ~I~_from ~2I~_~{~S~^~#[~; or ~:;, ~]~} ~
1129 ~I~_of ~2I~_~S ~I~_in~_~A ~I~_is not of type ~2I~_~S.~:>"
1130 :format-arguments
(list values
1131 (rest detail
) (first detail
)
1134 (if (singleton-p detail
)
1135 (error 'simple-type-error
1137 :expected-type atype
1138 :format-control
"~@<Value of ~S in ~_~A ~I~_is ~2I~_~S, ~
1139 ~I~_not a ~2I~_~S.~:@>"
1140 :format-arguments
(list (car detail
) context
1143 (error 'simple-type-error
1145 :expected-type atype
1146 :format-control
"~@<Value from ~2I~_~{~S~^~#[~; or ~:;, ~]~} ~
1147 ~I~_of ~2I~_~S ~I~_in~_~A ~I~_is ~2I~_~S, ~
1148 ~I~_not a ~2I~_~S.~:@>"
1149 :format-arguments
(list (rest detail
) (first detail
) context
1153 (defoptimizer (%compile-time-type-error ir2-convert
)
1154 ((objects atype dtype detail context
) node block
)
1155 (declare (ignore objects context
))
1156 (let ((*compiler-error-context
* node
))
1157 (setf (node-source-path node
)
1158 (cdr (node-source-path node
)))
1159 (let ((atype (lvar-value atype
))
1160 (dtype (lvar-value dtype
))
1161 (detail (lvar-value detail
)))
1162 (unless (eq atype nil
)
1163 (if (singleton-p detail
)
1164 (let ((detail (first detail
)))
1165 (if (constantp detail
)
1168 "~@<Constant ~2I~_~S ~Iconflicts with its ~
1169 asserted type ~2I~_~S.~@:>"
1170 :format-arguments
(list (eval detail
) atype
))
1173 "~@<Derived type of ~S is ~2I~_~S, ~
1174 ~I~_conflicting with ~
1175 its asserted type ~2I~_~S.~@:>"
1176 :format-arguments
(list detail dtype atype
))))
1179 "~@<Derived type of ~2I~_~{~S~^~#[~; and ~:;, ~]~} ~
1180 ~I~_in ~2I~_~S ~I~_is ~2I~_~S, ~I~_conflicting with ~
1181 their asserted type ~2I~_~S.~@:>"
1182 :format-arguments
(list (rest detail
) (first detail
) dtype atype
)))))
1183 (ir2-convert-full-call node block
)))