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
*)
58 (defvar *valid-callable-argument-assert-unknown-lvars
* nil
)
60 ;;; Signal a warning if appropriate and set *FOO-DETECTED*.
61 (declaim (ftype (function (string &rest t
) (values)) note-lossage note-unwinnage
))
62 (defun note-lossage (format-string &rest format-args
)
63 (setq *lossage-detected
* t
)
65 (apply *lossage-fun
* format-string format-args
))
67 (defun note-unwinnage (format-string &rest format-args
)
68 (setq *unwinnage-detected
* t
)
70 (apply *unwinnage-fun
* format-string format-args
))
74 ;;;; stuff for checking a call against a function type
76 ;;;; FIXME: This is stuff to look at when I get around to fixing
77 ;;;; function type inference and declarations.
79 ;;; A dummy version of SUBTYPEP useful when we want a functional like
80 ;;; SUBTYPEP that always returns true.
81 (defun always-subtypep (type1 type2
)
82 (declare (ignore type1 type2
))
85 ;;; Determine whether a use of a function is consistent with its type.
86 ;;; These values are returned:
87 ;;; T, T: the call is definitely valid.
88 ;;; NIL, T: the call is definitely invalid.
89 ;;; NIL, NIL: unable to determine whether the call is valid.
91 ;;; The ARGUMENT-TEST function is used to determine whether an
92 ;;; argument type matches the type we are checking against. Similarly,
93 ;;; the RESULT-TEST is used to determine whether the result type
94 ;;; matches the specified result.
96 ;;; Unlike the argument test, the result test may be called on values
97 ;;; or function types. NODE-DERIVED-TYPE is intersected with the
98 ;;; trusted asserted type.
100 ;;; The error and warning functions are functions that are called to
101 ;;; explain the result. We bind *COMPILER-ERROR-CONTEXT* to the
102 ;;; combination node so that COMPILER-WARNING and related functions
103 ;;; will do the right thing if they are supplied.
104 (defun valid-fun-use (call type
&key
105 ((:argument-test
*ctype-test-fun
*) #'csubtypep
)
106 (result-test #'values-subtypep
)
107 ((:lossage-fun
*lossage-fun
*))
108 ((:unwinnage-fun
*unwinnage-fun
*)))
109 (declare (type (or function null
) result-test
) (type combination call
)
110 ;; FIXME: Could TYPE here actually be something like
111 ;; (AND GENERIC-FUNCTION (FUNCTION (T) T))? How
112 ;; horrible... -- CSR, 2003-05-03
114 (let* ((*lossage-detected
* nil
)
115 (*unwinnage-detected
* nil
)
116 (*compiler-error-context
* call
)
117 (args (combination-args call
)))
118 (if (fun-type-p type
)
119 (let* ((nargs (length args
))
120 (required (fun-type-required type
))
121 (min-args (length required
))
122 (optional (fun-type-optional type
))
123 (max-args (+ min-args
(length optional
)))
124 (rest (fun-type-rest type
))
125 (keyp (fun-type-keyp type
)))
127 ((fun-type-wild-args type
)
128 (loop for arg in args
130 do
(check-arg-type arg
*universal-type
* i
)))
131 ((not (or optional keyp rest
))
132 (if (/= nargs min-args
)
134 "The function was called with ~R argument~:P, but wants exactly ~R."
136 (check-fixed-and-rest args required nil
)))
139 "The function was called with ~R argument~:P, but wants at least ~R."
142 (check-fixed-and-rest args
(append required optional
) rest
))
143 ((not (or keyp rest
))
145 "The function was called with ~R argument~:P, but wants at most ~R."
147 ((and keyp
(oddp (- nargs max-args
)))
149 "The function has an odd number of arguments in the keyword portion."))
151 (check-fixed-and-rest args
(append required optional
) rest
)
153 (check-key-args args max-args type
))))
156 (let* ((dtype (node-derived-type call
))
158 (binding* ((lvar (node-lvar call
) :exit-if-null
)
159 (dest (lvar-dest lvar
)))
160 (when (and (cast-p dest
)
161 (eq (cast-type-to-check dest
) *wild-type
*)
162 (immediately-used-p lvar call
))
163 (values-type-intersection
164 dtype
(cast-asserted-type dest
))))
166 (return-type (fun-type-returns type
)))
167 (multiple-value-bind (int win
) (funcall result-test out-type return-type
)
169 (note-unwinnage "can't tell whether the result is a ~S"
170 (type-specifier return-type
)))
172 (note-lossage "The result is a ~S, not a ~S."
173 (type-specifier out-type
)
174 (type-specifier return-type
))))))))
175 (loop for arg in args
177 do
(check-arg-type arg
*wild-type
* i
)))
178 (awhen (lvar-fun-name (combination-fun call
) t
)
179 (let ((type (info :function
:type it
))
180 (info (info :function
:info it
)))
181 (when (and (not *lossage-detected
*)
183 (fun-info-callable-check info
))
184 (let ((*valid-fun-use-name
* it
))
185 (apply (fun-info-callable-check info
)
186 (resolve-key-args args type
))))
187 ;; One more check for structure constructors:
188 (when (typep type
'defstruct-description
)
189 (awhen (assq it
(dd-constructors type
))
190 (check-structure-constructor-call call type
(cdr it
))))))
191 (cond (*lossage-detected
* (values nil t
))
192 (*unwinnage-detected
* (values nil nil
))
195 ;;; Turn constant LVARs in keyword arg positions to constants so that
196 ;;; they can be passed to FUN-INFO-CALLABLE-CHECK.
197 (defun resolve-key-args (args type
)
198 (if (fun-type-keyp type
)
199 (let ((non-key (+ (length (fun-type-required type
))
200 (length (fun-type-optional type
))))
202 (do ((key (nthcdr non-key args
) (cddr key
)))
204 (let ((k (first key
))
206 (when (constant-lvar-p k
)
207 (let* ((name (lvar-value k
))
208 (info (find name
(fun-type-keywords type
)
209 :key
#'key-info-name
)))
211 (push name key-arguments
)
212 (push v key-arguments
))))))
214 (nconc (subseq args
0 non-key
)
215 (nreverse key-arguments
)))
218 ;;; Return MIN, MAX, whether it contaions &optional/&key/&rest
219 (defun fun-arg-limits (function)
220 (cond ((fun-type-p function
)
221 (if (fun-type-wild-args function
)
223 (let* ((min (length (fun-type-required function
)))
224 (max (and (not (or (fun-type-rest function
)
225 (fun-type-keyp function
)))
227 (length (fun-type-optional function
))))))
228 (values min max
(or (fun-type-rest function
)
229 (fun-type-keyp function
)
230 (fun-type-optional function
))))))
232 (if (eq (lambda-kind function
) :external
)
233 (fun-arg-limits (lambda-entry-fun function
))
234 (let ((args (length (lambda-vars function
))))
235 (values args args
))))
236 ((not (optional-dispatch-p function
))
237 (if (and (functional-p function
)
238 (entry-info-p (functional-info function
)))
239 (fun-arg-limits (specifier-type (entry-info-type (functional-info function
))))
240 (values nil nil nil
)))
241 ((optional-dispatch-more-entry function
)
242 (values (optional-dispatch-min-args function
)
246 (values (optional-dispatch-min-args function
)
247 (optional-dispatch-max-args function
)
250 (defun valid-callable-argument (lvar arg-count
)
252 ;; Handle #'function, 'function and (lambda (x y))
253 (let* ((use (principal-lvar-use lvar
))
254 (leaf (if (ref-p use
)
256 (return-from valid-callable-argument nil
)))
257 (defined-type (and (global-var-p leaf
)
258 (global-var-defined-type leaf
)))
259 (lvar-type (or defined-type
261 (fun-name (cond ((or (fun-type-p lvar-type
)
263 (cond ((constant-lvar-p lvar
)
264 #+sb-xc-host
(bug "Can't call %FUN-NAME")
265 #-sb-xc-host
(%fun-name
(lvar-value lvar
)))
266 ((and (lambda-p leaf
)
267 (eq (lambda-kind leaf
) :external
))
268 (leaf-debug-name (lambda-entry-fun leaf
)))
270 (leaf-debug-name leaf
))))
271 ((constant-lvar-p lvar
)
274 (when *valid-callable-argument-assert-unknown-lvars
*
275 (assert-function-designator-lvar-type lvar
276 (specifier-type '(or function symbol
))
280 (return-from valid-callable-argument nil
))))
281 (type (cond ((fun-type-p lvar-type
)
284 (proclaimed-ftype fun-name
))
287 (*lossage-fun
* (if (and (not (eq (leaf-where-from leaf
)
289 (not (and (functional-p leaf
)
291 (member (functional-kind leaf
)
294 (not (info :function
:info fun-name
))))
295 #'compiler-style-warn
297 (multiple-value-bind (min max optional
)
298 (fun-arg-limits type
)
300 ((and (not min
) (not max
)))
302 (when (/= arg-count min
)
304 "The function ~S is called by ~S with ~R argument~:P, but wants exactly ~R."
310 "The function ~S is called by ~S with ~R argument~:P, but wants at least ~R."
317 "The function ~S called by ~S with ~R argument~:P, but wants at most ~R."
322 (defun check-structure-constructor-call (call dd ctor-ll-parts
)
323 (destructuring-bind (&optional req opt rest keys aux
)
324 (and (listp ctor-ll-parts
) (cdr ctor-ll-parts
))
325 (declare (ignore rest
))
326 (let* ((call-args (combination-args call
))
328 (keyword-lvars (nthcdr (+ n-req
(length opt
)) call-args
))
329 (const-keysp (check-key-args-constant keyword-lvars
))
330 (n-call-args (length call-args
)))
331 (dolist (slot (dd-slots dd
))
332 (let ((name (dsd-name slot
))
334 (lambda-list-element nil
))
335 ;; Ignore &AUX vars - it's not the caller's fault if wrong.
336 (unless (find name aux
:key
(lambda (x) (if (listp x
) (car x
) x
))
337 ;; is this right, or should it be EQ
338 ;; like in DETERMINE-UNSAFE-SLOTS ?
340 (multiple-value-bind (arg position
)
341 (%find-position name opt nil
0 nil
#'parse-optional-arg-spec
344 (setq suppliedp
(< (+ n-req position
) n-call-args
)
345 lambda-list-element arg
)))
346 (when (and (eq suppliedp
:maybe
) const-keysp
)
347 ;; Deduce the keyword (if any) that initializes this slot.
348 (multiple-value-bind (keyword arg
)
349 (if (listp ctor-ll-parts
)
351 (multiple-value-bind (key var
) (parse-key-arg-spec arg
)
352 (when (string= name var
) (return (values key arg
)))))
353 (values (keywordicate name
) t
))
355 (setq suppliedp
(find-keyword-lvar keyword-lvars keyword
)
356 lambda-list-element arg
))))
357 (when (eq suppliedp nil
)
358 (let ((initform (if (typep lambda-list-element
'(cons t cons
))
359 (second lambda-list-element
)
360 (dsd-default slot
))))
361 ;; Return T if value-form definitely does not satisfy
362 ;; the type-check for DSD. Return NIL if we can't decide.
363 (when (if (sb!xc
:constantp initform
)
364 (not (sb!xc
:typep
(constant-form-value initform
)
366 ;; Find uses of nil-returning functions as defaults,
367 ;; like ERROR and MISSING-ARG.
368 (and (sb!kernel
::dd-null-lexenv-p dd
)
370 (let ((f (car initform
)))
371 ;; Don't examine :function :type of macros!
372 (and (eq (info :function
:kind f
) :function
)
373 (let ((info (info :function
:type f
)))
374 (and (fun-type-p info
)
375 (type= (fun-type-returns info
)
377 (note-lossage "The slot ~S does not have a suitable default, ~
378 and no value was provided for it." name
))))))))))
380 ;;; Check that the derived type of the LVAR is compatible with TYPE. N
381 ;;; is the arg number, for error message purposes. We return true if
382 ;;; arg is definitely o.k. If the type is a magic CONSTANT-TYPE, then
383 ;;; we check for the argument being a constant value of the specified
384 ;;; type. If there is a manifest type error (DERIVED-TYPE = NIL), then
385 ;;; we flame about the asserted type even when our type is satisfied
387 (defun check-arg-type (lvar type n
)
388 (declare (type lvar lvar
) (type ctype type
) (type index n
))
390 ((not (constant-type-p type
))
391 (let ((ctype (lvar-type lvar
)))
392 (multiple-value-bind (int win
) (funcall *ctype-test-fun
* ctype type
)
394 (note-unwinnage "can't tell whether the ~:R argument is a ~S"
395 n
(type-specifier type
))
398 (note-lossage "The ~:R argument is a ~S, not a ~S."
399 n
(type-specifier ctype
) (type-specifier type
))
401 ((eq ctype
*empty-type
*)
402 (note-unwinnage "The ~:R argument never returns a value." n
)
405 ((not (constant-lvar-p lvar
))
406 (note-unwinnage "The ~:R argument is not a constant." n
)
409 (let ((val (lvar-value lvar
))
410 (type (constant-type-type type
)))
411 (multiple-value-bind (res win
) (ctypep val type
)
413 (note-unwinnage "can't tell whether the ~:R argument is a ~
415 n
(type-specifier type
) val
)
418 (note-lossage "The ~:R argument is not a constant ~S:~% ~S"
419 n
(type-specifier type
) val
)
423 ;;; Check that each of the type of each supplied argument intersects
424 ;;; with the type specified for that argument. If we can't tell, then
425 ;;; we can complain about the absence of manifest winnage.
426 (declaim (ftype (function (list list
(or ctype null
)) (values)) check-fixed-and-rest
))
427 (defun check-fixed-and-rest (args types rest
)
428 (do ((arg args
(cdr arg
))
429 (type types
(cdr type
))
431 ((or (null type
) (null arg
))
434 (check-arg-type arg rest n
)
437 (check-arg-type (car arg
) (car type
) n
))
440 ;;; Check that the &KEY args are of the correct type. Each key should
441 ;;; be known and the corresponding argument should be of the correct
442 ;;; type. If the key isn't a constant, then we can't tell, so we can
443 ;;; complain about absence of manifest winnage.
444 (declaim (ftype (function (list fixnum fun-type
) (values)) check-key-args
))
445 (defun check-key-args (args pre-key type
)
446 (let (lossages allow-other-keys
)
447 (do ((key (nthcdr pre-key args
) (cddr key
))
448 (n (1+ pre-key
) (+ n
2)))
451 (let ((k (first key
))
454 ((not (check-arg-type k
(specifier-type 'symbol
) n
)))
455 ((not (constant-lvar-p k
))
456 (note-unwinnage "~@<The ~:R argument (in keyword position) is not ~
457 a constant, weakening keyword argument ~
459 ;; An unknown key may turn out to be :ALLOW-OTHER-KEYS at runtime,
460 ;; so we cannot signal full warnings for keys that look bad.
461 (unless allow-other-keys
462 (setf allow-other-keys
:maybe
)))
464 (let* ((name (lvar-value k
))
465 (info (find name
(fun-type-keywords type
)
466 :key
#'key-info-name
)))
467 (cond ((eq name
:allow-other-keys
)
468 (unless allow-other-keys
469 (if (constant-lvar-p v
)
470 (setf allow-other-keys
(if (lvar-value v
)
473 (setf allow-other-keys
:maybe
))))
475 (unless (fun-type-allowp type
)
476 (pushnew name lossages
:test
#'eq
)))
478 (check-arg-type (second key
) (key-info-type info
)
480 (when (and lossages
(member allow-other-keys
'(nil :no
)))
481 (setf lossages
(nreverse lossages
))
483 (note-lossage "~@<~{~S~^, ~} and ~S are not a known argument keywords.~:@>"
485 (car (last lossages
)))
486 (note-lossage "~S is not a known argument keyword."
490 ;;; Construct a function type from a definition.
492 ;;; Due to the lack of a (LIST X) type specifier, we can't reconstruct
494 (declaim (ftype (sfunction (functional) fun-type
) definition-type
))
495 (defun definition-type (functional)
496 (if (lambda-p functional
)
498 :required
(mapcar #'leaf-type
(lambda-vars functional
))
499 :returns
(tail-set-type (lambda-tail-set functional
)))
504 (dolist (arg (optional-dispatch-arglist functional
))
505 (let ((info (lambda-var-arg-info arg
))
506 (type (leaf-type arg
)))
508 (ecase (arg-info-kind info
)
509 (:required
(req type
))
510 (:optional
(opt type
))
512 (keys (make-key-info :name
(arg-info-key info
)
514 ((:rest
:more-context
)
515 (setq rest
*universal-type
*))
524 :keyp
(optional-dispatch-keyp functional
)
525 :allowp
(optional-dispatch-allowp functional
)
526 :returns
(tail-set-type
528 (optional-dispatch-main-entry functional
))))))))
530 ;;;; approximate function types
532 ;;;; FIXME: This is stuff to look at when I get around to fixing function
533 ;;;; type inference and declarations.
535 ;;;; Approximate function types provide a condensed representation of all the
536 ;;;; different ways that a function has been used. If we have no declared or
537 ;;;; defined type for a function, then we build an approximate function type by
538 ;;;; examining each use of the function. When we encounter a definition or
539 ;;;; proclamation, we can check the actual type for compatibity with the
542 (defstruct (approximate-fun-type (:copier nil
))
543 ;; the smallest and largest numbers of arguments that this function
544 ;; has been called with.
545 (min-args sb
!xc
:call-arguments-limit
546 :type
(integer 0 #.sb
!xc
:call-arguments-limit
))
548 :type
(integer 0 #.sb
!xc
:call-arguments-limit
))
549 ;; a list of lists of the all the types that have been used in each
551 (types () :type list
)
552 ;; A list of APPROXIMATE-KEY-INFO structures describing all the
553 ;; things that looked like &KEY arguments. There are distinct
554 ;; structures describing each argument position in which the keyword
556 (keys () :type list
))
558 (defstruct (approximate-key-info (:copier nil
))
559 ;; The keyword name of this argument. Although keyword names don't
560 ;; have to be keywords, we only match on keywords when figuring an
562 (name (missing-arg) :type keyword
)
563 ;; The position at which this keyword appeared. 0 if it appeared as the
564 ;; first argument, etc.
565 (position (missing-arg)
566 :type
(integer 0 #.sb
!xc
:call-arguments-limit
))
567 ;; a list of all the argument types that have been used with this keyword
568 (types nil
:type list
)
569 ;; true if this keyword has appeared only in calls with an obvious
571 (allowp nil
:type
(member t nil
)))
573 ;;; Return an APPROXIMATE-FUN-TYPE representing the context of
574 ;;; CALL. If TYPE is supplied and not null, then we merge the
575 ;;; information into the information already accumulated in TYPE.
576 (declaim (ftype (function (combination
577 &optional
(or approximate-fun-type null
))
578 approximate-fun-type
)
580 (defun note-fun-use (call &optional type
)
581 (let* ((type (or type
(make-approximate-fun-type)))
582 (types (approximate-fun-type-types type
))
583 (args (combination-args call
))
584 (nargs (length args
))
585 (allowp (some (lambda (x)
586 (and (constant-lvar-p x
)
587 (eq (lvar-value x
) :allow-other-keys
)))
590 (setf (approximate-fun-type-min-args type
)
591 (min (approximate-fun-type-min-args type
) nargs
))
592 (setf (approximate-fun-type-max-args type
)
593 (max (approximate-fun-type-max-args type
) nargs
))
595 (do ((old types
(cdr old
))
596 (arg args
(cdr arg
)))
598 (setf (approximate-fun-type-types type
)
601 (list (lvar-type x
)))
603 (when (null arg
) (return))
604 (pushnew (lvar-type (car arg
))
608 (collect ((keys (approximate-fun-type-keys type
) cons
))
609 (do ((arg args
(cdr arg
))
611 ((or (null arg
) (null (cdr arg
)))
612 (setf (approximate-fun-type-keys type
) (keys)))
613 (let ((key (first arg
))
615 (when (constant-lvar-p key
)
616 (let ((name (lvar-value key
)))
617 (when (keywordp name
)
620 (and (eq (approximate-key-info-name x
) name
)
621 (= (approximate-key-info-position x
)
624 (val-type (lvar-type val
)))
627 (approximate-key-info-types old
)
630 (setf (approximate-key-info-allowp old
) nil
)))
632 (keys (make-approximate-key-info
636 :types
(list val-type
))))))))))))
639 ;;; This is similar to VALID-FUN-USE, but checks an
640 ;;; APPROXIMATE-FUN-TYPE against a real function type.
641 (declaim (ftype (function (approximate-fun-type fun-type
642 &optional function function function
)
643 (values boolean boolean
))
644 valid-approximate-type
))
645 (defun valid-approximate-type (call-type type
&optional
647 #'types-equal-or-intersect
)
649 #'compiler-style-warn
)
650 (*unwinnage-fun
* #'compiler-notify
))
651 (let* ((*lossage-detected
* nil
)
652 (*unwinnage-detected
* nil
)
653 (required (fun-type-required type
))
654 (min-args (length required
))
655 (optional (fun-type-optional type
))
656 (max-args (+ min-args
(length optional
)))
657 (rest (fun-type-rest type
))
658 (keyp (fun-type-keyp type
)))
660 (when (fun-type-wild-args type
)
661 (return-from valid-approximate-type
(values t t
)))
663 (let ((call-min (approximate-fun-type-min-args call-type
)))
664 (when (< call-min min-args
)
666 "~:@<The function was previously called with ~R argument~:P, ~
667 but wants at least ~R.~:>"
670 (let ((call-max (approximate-fun-type-max-args call-type
)))
671 (cond ((<= call-max max-args
))
672 ((not (or keyp rest
))
674 "~:@<The function was previously called with ~R argument~:P, ~
675 but wants at most ~R.~:>"
677 ((and keyp
(oddp (- call-max max-args
)))
679 "~:@<The function was previously called with an odd number of ~
680 arguments in the keyword portion.~:>")))
682 (when (and keyp
(> call-max max-args
))
683 (check-approximate-keywords call-type max-args type
)))
685 (check-approximate-fixed-and-rest call-type
(append required optional
)
688 (cond (*lossage-detected
* (values nil t
))
689 (*unwinnage-detected
* (values nil nil
))
692 ;;; Check that each of the types used at each arg position is
693 ;;; compatible with the actual type.
694 (declaim (ftype (function (approximate-fun-type list
(or ctype null
))
696 check-approximate-fixed-and-rest
))
697 (defun check-approximate-fixed-and-rest (call-type fixed rest
)
698 (do ((types (approximate-fun-type-types call-type
) (cdr types
))
700 (arg fixed
(cdr arg
)))
702 (let ((decl-type (or (car arg
) rest
)))
703 (unless decl-type
(return))
704 (check-approximate-arg-type (car types
) decl-type
"~:R" n
)))
707 ;;; Check that each of the call-types is compatible with DECL-TYPE,
708 ;;; complaining if not or if we can't tell.
709 (declaim (ftype (function (list ctype string
&rest t
) (values))
710 check-approximate-arg-type
))
711 (defun check-approximate-arg-type (call-types decl-type context
&rest args
)
712 (let ((losers *empty-type
*))
713 (dolist (ctype call-types
)
714 (multiple-value-bind (int win
) (funcall *ctype-test-fun
* ctype decl-type
)
717 (note-unwinnage "can't tell whether previous ~? ~
718 argument type ~S is a ~S"
721 (type-specifier ctype
)
722 (type-specifier decl-type
)))
724 (setq losers
(type-union ctype losers
))))))
726 (unless (eq losers
*empty-type
*)
727 (note-lossage "~:(~?~) argument should be a ~S but was a ~S in a previous call."
728 context args
(type-specifier decl-type
) (type-specifier losers
))))
731 ;;; Check the types of each manifest keyword that appears in a keyword
732 ;;; argument position. Check the validity of all keys that appeared in
733 ;;; valid keyword positions.
735 ;;; ### We could check the APPROXIMATE-FUN-TYPE-TYPES to make
736 ;;; sure that all arguments in keyword positions were manifest
738 (defun check-approximate-keywords (call-type max-args type
)
739 (let ((call-keys (approximate-fun-type-keys call-type
))
740 (keys (fun-type-keywords type
)))
742 (let ((name (key-info-name key
)))
743 (collect ((types nil append
))
744 (dolist (call-key call-keys
)
745 (let ((pos (approximate-key-info-position call-key
)))
746 (when (and (eq (approximate-key-info-name call-key
) name
)
747 (> pos max-args
) (evenp (- pos max-args
)))
748 (types (approximate-key-info-types call-key
)))))
749 (check-approximate-arg-type (types) (key-info-type key
) "~S" name
))))
751 (unless (fun-type-allowp type
)
752 (collect ((names () adjoin
))
753 (dolist (call-key call-keys
)
754 (let ((pos (approximate-key-info-position call-key
)))
755 (when (and (> pos max-args
) (evenp (- pos max-args
))
756 (not (approximate-key-info-allowp call-key
)))
757 (names (approximate-key-info-name call-key
)))))
759 (dolist (name (names))
760 (unless (find name keys
:key
#'key-info-name
)
761 (note-lossage "Function previously called with unknown argument keyword ~S."
764 ;;;; ASSERT-DEFINITION-TYPE
766 ;;; Intersect LAMBDA's var types with TYPES, giving a warning if there
767 ;;; is a mismatch. If all intersections are non-null, we return lists
768 ;;; of the variables and intersections, otherwise we return NIL, NIL.
769 (defun try-type-intersections (vars types where
)
770 (declare (list vars types
) (string where
))
772 (mapc (lambda (var type
)
773 (let* ((vtype (leaf-type var
))
774 (int (type-approx-intersection2 vtype type
)))
776 ((eq int
*empty-type
*)
778 "Definition's declared type for variable ~A:~% ~S~@
779 conflicts with this type from ~A:~% ~S"
780 (leaf-debug-name var
) (type-specifier vtype
)
781 where
(type-specifier type
))
782 (return-from try-type-intersections
(values nil nil
)))
786 (values vars
(res))))
788 ;;; Check that the optional-dispatch OD conforms to TYPE. We return
789 ;;; the values of TRY-TYPE-INTERSECTIONS if there are no syntax
790 ;;; problems, otherwise NIL, NIL.
792 ;;; Note that the variables in the returned list are the actual
793 ;;; original variables (extracted from the optional dispatch arglist),
794 ;;; rather than the variables that are arguments to the main entry.
795 ;;; This difference is significant only for &KEY args with hairy
796 ;;; defaults. Returning the actual vars allows us to use the right
797 ;;; variable name in warnings.
799 ;;; A slightly subtle point: with keywords and optionals, the type in
800 ;;; the function type is only an assertion on calls --- it doesn't
801 ;;; constrain the type of default values. So we have to union in the
802 ;;; type of the default. With optionals, we can't do any assertion
803 ;;; unless the default is constant.
805 ;;; With keywords, we exploit our knowledge about how hairy keyword
806 ;;; defaulting is done when computing the type assertion to put on the
807 ;;; main-entry argument. In the case of hairy keywords, the default
808 ;;; has been clobbered with NIL, which is the value of the main-entry
809 ;;; arg in the unsupplied case, whatever the actual default value is.
810 ;;; So we can just assume the default is constant, effectively
811 ;;; unioning in NULL, and not totally blow off doing any type
813 (defun find-optional-dispatch-types (od type where
)
814 (declare (type optional-dispatch od
)
817 (let ((od-min (optional-dispatch-min-args od
))
818 (od-max (optional-dispatch-max-args od
))
819 (od-more (optional-dispatch-more-entry od
))
820 (od-keyp (optional-dispatch-keyp od
))
821 (od-allowp (optional-dispatch-allowp od
))
822 (type-required (fun-type-required type
))
823 (type-optional (fun-type-optional type
))
824 (type-rest (fun-type-rest type
))
825 (type-keyp (fun-type-keyp type
))
826 (type-allowp (fun-type-allowp type
)))
827 (flet ((check-num (num-definition num-type arg-kind
)
828 (unless (= num-definition num-type
)
830 "The definition has ~R ~A arg~P, but ~A has ~R."
831 num-definition arg-kind num-definition where num-type
)))
832 (check-section (in-od-p in-type-p section
)
833 (unless (eq in-od-p in-type-p
)
835 "The definition ~:[doesn't have~;has~] ~A, but ~
836 ~A ~:[doesn't~;does~]."
837 in-od-p section where in-type-p
))))
838 (check-num od-min
(length type-required
) 'required
)
839 ;; When TYPE does not have &OPTIONAL parameters and the type of
840 ;; the &REST parameter is T, it may have been simplified from
842 ;; (function (... &optional t &rest t ...) ...)
844 ;; We cannot check the exact number of optional parameters then.
845 (unless (and (not type-optional
)
846 type-rest
(type= type-rest
*universal-type
*))
847 (check-num (- od-max od-min
) (length type-optional
) '&optional
))
848 (check-section od-keyp type-keyp
"&KEY arguments")
850 (check-section (not (null od-more
)) (not (null type-rest
))
852 (check-section od-allowp type-allowp
'&allow-other-keys
))
854 (when *lossage-detected
*
855 (return-from find-optional-dispatch-types
(values nil nil
)))
859 (let ((keys (fun-type-keywords type
))
860 (arglist (optional-dispatch-arglist od
)))
861 (dolist (arg arglist
)
863 ((lambda-var-arg-info arg
)
864 (let* ((info (lambda-var-arg-info arg
))
865 (default (arg-info-default info
))
866 (def-type (when (sb!xc
:constantp default
)
867 (ctype-of (constant-form-value default
)))))
868 (ecase (arg-info-kind info
)
870 (let* ((key (arg-info-key info
))
871 (kinfo (find key keys
:key
#'key-info-name
)))
874 (res (type-union (key-info-type kinfo
)
875 (or def-type
(specifier-type 'null
)))))
878 "Defining a ~S keyword not present in ~A."
880 (res *universal-type
*)))))
881 (:required
(res (pop type-required
)))
883 ;; We can exhaust TYPE-OPTIONAL when the type was
884 ;; simplified as described above.
885 (res (type-union (or (pop type-optional
)
887 (or def-type
*universal-type
*))))
889 (when (fun-type-rest type
)
890 (res (specifier-type 'list
))))
892 (when (fun-type-rest type
)
893 (res *universal-type
*)))
895 (when (fun-type-rest type
)
896 (res (specifier-type 'fixnum
)))))
898 (when (arg-info-supplied-p info
)
899 (res *universal-type
*)
900 (vars (arg-info-supplied-p info
)))))
902 (res (pop type-required
))
906 (unless (find (key-info-name key
) arglist
908 (let ((info (lambda-var-arg-info x
)))
910 (arg-info-key info
)))))
912 "The definition lacks the ~S key present in ~A."
913 (key-info-name key
) where
))))
915 (try-type-intersections (vars) (res) where
))))
917 ;;; Check that TYPE doesn't specify any funny args, and do the
919 (defun find-lambda-types (lambda type where
)
920 (declare (type clambda lambda
) (type fun-type type
) (string where
))
921 (flet ((frob (x what
)
924 "The definition has no ~A, but the ~A did."
926 (frob (fun-type-optional type
) "&OPTIONAL arguments")
927 (frob (fun-type-keyp type
) "&KEY arguments")
928 (frob (fun-type-rest type
) "&REST argument"))
929 (let* ((vars (lambda-vars lambda
))
930 (nvars (length vars
))
931 (req (fun-type-required type
))
933 (unless (= nvars nreq
)
934 (note-lossage "The definition has ~R arg~:P, but the ~A has ~R."
936 (if *lossage-detected
*
938 (try-type-intersections vars req where
))))
940 ;;; Check for syntactic and type conformance between the definition
941 ;;; FUNCTIONAL and the specified FUN-TYPE. If they are compatible
942 ;;; and REALLY-ASSERT is T, then add type assertions to the definition
943 ;;; from the FUN-TYPE.
945 ;;; If there is a syntactic or type problem, then we call
946 ;;; LOSSAGE-FUN with an error message using WHERE as context
947 ;;; describing where FUN-TYPE came from.
949 ;;; If there is no problem, we return T (even if REALLY-ASSERT was
950 ;;; false). If there was a problem, we return NIL.
951 (defun assert-definition-type
952 (functional type
&key
(really-assert t
)
953 ((:lossage-fun
*lossage-fun
*) #'compiler-style-warn
)
955 (where "previous declaration"))
956 (declare (type functional functional
)
957 (type function
*lossage-fun
*)
959 (unless (fun-type-p type
)
960 (return-from assert-definition-type t
))
961 (let ((*lossage-detected
* nil
))
962 (multiple-value-bind (vars types
)
963 (if (fun-type-wild-args type
)
965 (etypecase functional
967 (find-optional-dispatch-types functional type where
))
969 (find-lambda-types functional type where
))))
970 (let* ((type-returns (fun-type-returns type
))
971 (return (lambda-return (main-entry functional
)))
973 (lvar-derived-type (return-result return
)))))
975 ((and dtype
(not (values-types-equal-or-intersect dtype
978 "The result type from ~A:~% ~
979 ~/sb!impl:print-type/~@
980 conflicts with the definition's result type:~% ~
981 ~/sb!impl:print-type/"
982 where type-returns dtype
)
984 (*lossage-detected
* nil
)
985 ((not really-assert
) t
)
987 ;; REALLY-ASSERT can be T or `(:NOT . ,vars) where the latter is
988 ;; a list of vars for which compiling will *not* generate
989 ;; an automatic check.
990 (let ((policy (lexenv-policy (functional-lexenv functional
))))
991 (when (and (policy policy
(> type-check
0))
992 (or (eq really-assert t
)
993 (not (member :result
(cdr really-assert
)))))
994 (assert-lvar-type (return-result return
) type-returns
996 (loop for var in vars and type in types do
997 (cond ((basic-var-sets var
)
998 (when (and unwinnage-fun
999 (not (csubtypep (leaf-type var
) type
)))
1000 (funcall unwinnage-fun
1001 #.
(#+sb-xc sb
!impl
::!xc-preprocess-format-control
1003 "Assignment to argument: ~S~% ~
1004 prevents use of assertion from function ~
1005 type ~A:~% ~/sb!impl:print-type/~%")
1006 (leaf-debug-name var
) where type
)))
1007 ((and (listp really-assert
) ; (:NOT . ,vars)
1008 (member (lambda-var-%source-name var
)
1009 (cdr really-assert
)))) ; do nothing
1011 (setf (leaf-type var
) type
)
1012 (let ((s-type (make-single-value-type type
)))
1013 (dolist (ref (leaf-refs var
))
1014 (derive-node-type ref s-type
))))))
1017 ;;; Manipulate the poorly-named :REALLY-ASSERT value.
1018 ;;; It would make sense to pass the opposite sense of the arg
1019 ;;; (as ":SKIP-CHECKS") corresponding to the declaration.
1020 (defun explicit-check->really-assert
(explicit-check)
1021 (case explicit-check
1024 (t `(:not .
,explicit-check
))))
1026 ;;; FIXME: This is quite similar to ASSERT-NEW-DEFINITION.
1027 (defun assert-global-function-definition-type (name fun
)
1028 (declare (type functional fun
))
1029 (let ((where (info :function
:where-from name
))
1030 (explicit-check (getf (functional-plist fun
) 'explicit-check
)))
1031 (if (eq where
:declared
)
1033 (massage-global-definition-type (proclaimed-ftype name
) fun
)))
1034 (setf (leaf-type fun
) type
)
1035 (assert-definition-type
1037 :unwinnage-fun
#'compiler-notify
1038 :where
"proclamation"
1039 :really-assert
(explicit-check->really-assert explicit-check
)))
1040 ;; Can't actually test this. DEFSTRUCTs declare this, but non-toplevel
1041 ;; ones won't have an FTYPE at compile-time.
1043 (when explicit-check
1044 (warn "Explicit-check without known FTYPE is meaningless")))))
1046 ;;; If the function has both &REST and &KEY, FIND-OPTIONAL-DISPATCH-TYPES
1047 ;;; doesn't complain about the type missing &REST -- which is good, because in
1048 ;;; that case &REST is really an implementation detail and not part of the
1049 ;;; interface. However since we set the leaf type missing &REST from there
1050 ;;; would be a bad thing -- to make up a new type if necessary.
1051 (defun massage-global-definition-type (type fun
)
1052 (if (and (fun-type-p type
)
1053 (optional-dispatch-p fun
)
1054 (optional-dispatch-keyp fun
)
1055 (optional-dispatch-more-entry fun
)
1056 (not (or (fun-type-rest type
)
1057 (fun-type-wild-args type
))))
1058 (make-fun-type :required
(fun-type-required type
)
1059 :optional
(fun-type-optional type
)
1060 :rest
*universal-type
*
1061 :keyp
(fun-type-keyp type
)
1062 :keywords
(fun-type-keywords type
)
1063 :allowp
(fun-type-allowp type
)
1064 :returns
(fun-type-returns type
))
1067 ;;; Call FUN with (arg-lvar arg-type)
1068 (defun map-combination-args-and-types (fun call
)
1069 (declare (type function fun
) (type combination call
))
1070 (binding* ((type (lvar-type (combination-fun call
)))
1071 (nil (fun-type-p type
) :exit-if-null
)
1072 (args (combination-args call
)))
1073 (dolist (req (fun-type-required type
))
1074 (when (null args
) (return-from map-combination-args-and-types
))
1075 (let ((arg (pop args
)))
1076 (funcall fun arg req
)))
1077 (dolist (opt (fun-type-optional type
))
1078 (when (null args
) (return-from map-combination-args-and-types
))
1079 (let ((arg (pop args
)))
1080 (funcall fun arg opt
)))
1082 (let ((rest (fun-type-rest type
)))
1085 (funcall fun arg rest
))))
1087 (dolist (key (fun-type-keywords type
))
1088 (let ((name (key-info-name key
)))
1089 (do ((arg args
(cddr arg
)))
1091 (let ((keyname (first arg
)))
1092 (when (and (constant-lvar-p keyname
)
1093 (eq (lvar-value keyname
) name
))
1094 (funcall fun
(second arg
) (key-info-type key
)))))))))
1096 ;;; Assert that CALL is to a function of the specified TYPE. It is
1097 ;;; assumed that the call is legal and has only constants in the
1098 ;;; keyword positions.
1099 (defun assert-call-type (call type
&optional
(trusted t
))
1100 (declare (type combination call
) (type fun-type type
))
1101 (let ((policy (lexenv-policy (node-lexenv call
)))
1102 (returns (fun-type-returns type
)))
1104 (derive-node-type call returns
)
1105 (let ((lvar (node-lvar call
)))
1106 ;; If the value is used in a non-tail position, and the lvar
1107 ;; is a single-use, assert the type. Multiple use sites need
1108 ;; to be elided because the assertion has to apply to all
1109 ;; uses. Tail positions are elided because the assertion
1110 ;; would cause us not the be in a tail-position anymore. MV
1111 ;; calls are elided because not only are the assertions of
1112 ;; less use there, but they can cause the MV call conversion
1115 (not (return-p (lvar-dest lvar
)))
1116 (not (mv-combination-p (lvar-dest lvar
)))
1117 (lvar-has-single-use-p lvar
))
1118 (when (assert-lvar-type lvar returns policy
)
1119 (reoptimize-lvar lvar
)))))
1120 (let* ((name (lvar-fun-name (combination-fun call
) t
))
1122 (info :function
:info name
))))
1124 (fun-info-call-type-deriver info
))
1125 (funcall (fun-info-call-type-deriver info
) call trusted
)
1126 (map-combination-args-and-types
1128 (when (and (assert-lvar-type arg type policy
)
1130 (reoptimize-lvar arg
)))
1134 ;;;; FIXME: Move to some other file.
1135 (defun check-catch-tag-type (tag)
1136 (declare (type lvar tag
))
1137 (let ((ctype (lvar-type tag
)))
1138 (when (csubtypep ctype
(specifier-type '(or number character
)))
1139 (let ((sources (lvar-all-sources tag
)))
1140 (if (singleton-p sources
)
1141 (compiler-style-warn
1142 "~@<Using ~S of type ~/sb!impl:print-type/ as ~
1143 a catch tag (which tends to be unportable because THROW ~
1144 and CATCH use EQ comparison)~@:>"
1145 (first sources
) (lvar-type tag
))
1146 (compiler-style-warn
1147 "~@<Using ~{~S~^~#[~; or ~:;, ~]~} in ~S of type ~
1148 ~/sb!impl:print-type/ as a catch tag (which tends to be ~
1149 unportable because THROW and CATCH use EQ comparison)~@:>"
1150 (rest sources
) (first sources
) (lvar-type tag
)))))))
1152 (defun %compile-time-type-error
(values atype dtype detail context
)
1153 (declare (ignore dtype
))
1154 (if (and (consp atype
) (eq (car atype
) 'values
))
1155 (if (singleton-p detail
)
1156 (error 'simple-type-error
1158 :expected-type atype
1160 "~@<Value set ~2I~_[~{~S~^ ~}] ~I~_from ~S in~_~A ~
1161 ~I~_is not of type ~
1162 ~2I~_~/sb!impl:print-type-specifier/.~:>"
1163 :format-arguments
(list values
1164 (first detail
) context
1166 (error 'simple-type-error
1168 :expected-type atype
1170 "~@<Value set ~2I~_[~{~S~^ ~}] ~
1171 ~I~_from ~2I~_~{~S~^~#[~; or ~:;, ~]~} ~
1172 ~I~_of ~2I~_~S ~I~_in~_~A ~I~_is not of type ~
1173 ~2I~_~/sb!impl:print-type-specifier/.~:>"
1174 :format-arguments
(list values
1175 (rest detail
) (first detail
)
1178 (if (singleton-p detail
)
1179 (error 'simple-type-error
1181 :expected-type atype
1183 "~@<Value of ~S in ~_~A ~I~_is ~2I~_~S, ~
1184 ~I~_not a ~2I~_~/sb!impl:print-type-specifier/.~:@>"
1185 :format-arguments
(list (car detail
) context
1188 (error 'simple-type-error
1190 :expected-type atype
1192 "~@<Value from ~2I~_~{~S~^~#[~; or ~:;, ~]~} ~
1193 ~I~_of ~2I~_~S ~I~_in~_~A ~I~_is ~2I~_~S, ~
1194 ~I~_not a ~2I~_~/sb!impl:print-type-specifier/.~:@>"
1195 :format-arguments
(list (rest detail
) (first detail
) context
1199 (defoptimizer (%compile-time-type-error ir2-convert
)
1200 ((objects atype dtype detail context
) node block
)
1201 (declare (ignore objects context
))
1202 (let ((*compiler-error-context
* node
))
1203 (setf (node-source-path node
)
1204 (cdr (node-source-path node
)))
1205 (let ((atype (lvar-value atype
))
1206 (dtype (lvar-value dtype
))
1207 (detail (lvar-value detail
)))
1208 (unless (eq atype nil
)
1209 (if (singleton-p detail
)
1210 (let ((detail (first detail
)))
1211 (if (constantp detail
)
1214 "~@<Constant ~2I~_~S ~Iconflicts with its ~
1216 ~2I~_~/sb!impl::print-type-specifier/.~@:>"
1217 :format-arguments
(list (eval detail
) atype
))
1220 "~@<Derived type of ~S is ~2I~_~S, ~
1221 ~I~_conflicting with its asserted type ~
1222 ~2I~_~/sb!impl:print-type-specifier/.~@:>"
1223 :format-arguments
(list detail dtype atype
))))
1226 "~@<Derived type of ~2I~_~{~S~^~#[~; and ~:;, ~
1227 ~]~} ~I~_in ~2I~_~S ~I~_is ~
1228 ~2I~_~/sb!impl:print-type-specifier/, ~
1229 ~I~_conflicting with their asserted type ~
1230 ~2I~_~/sb!impl:print-type-specifier/.~@:>"
1231 :format-arguments
(list (rest detail
) (first detail
)
1233 (ir2-convert-full-call node block
)))