/[cmucl]/src/compiler/ctype.lisp
ViewVC logotype

Contents of /src/compiler/ctype.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.38 - (show annotations)
Thu May 27 23:43:16 2010 UTC (3 years, 10 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.37: +2 -2 lines
Too many args to NOTE-LOSSAGE message in
FIND-OPTIONAL-DISPATCH-TYPES.
1 ;;; -*- Package: C; Log: C.Log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/ctype.lisp,v 1.38 2010/05/27 23:43:16 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file contains code which knows about both the type representation
13 ;;; and the compiler IR1 representation. This stuff is used for doing type
14 ;;; checking.
15 ;;;
16 ;;; Written by Rob MacLachlan
17 ;;;
18 ;;; WARNING: Watch out when marking translatable strings. You can
19 ;;; really, really slow down the compiler if you do it in a simple
20 ;;; fashion! (Compile times for cmucl went up by a factor of about
21 ;;; 10!)
22 (in-package "C")
23 (intl:textdomain "cmucl")
24
25 ;;; These are the functions that are to be called when a problem is detected.
26 ;;; They are passed format arguments. If null, we don't do anything. The
27 ;;; error function is called when something is definitely incorrect. The
28 ;;; warning function is called when it is somehow impossible to tell if the
29 ;;; call is correct.
30 ;;;
31 (defvar *error-function*)
32 (defvar *warning-function*)
33
34 ;;; The function that we use for type checking. The derived type is the first
35 ;;; argument and the type we are testing against is the second argument. The
36 ;;; function should return values like Csubtypep.
37 ;;;
38 (defvar *test-function*)
39
40 (declaim (type (or function null) *error-function* *warning-function
41 *test-function*))
42
43 ;;; *lossage-detected* is set if a definite incompatibility is detected.
44 ;;; *slime-detected* is set if we can't tell whether the call is compatible or
45 ;;; not.
46 ;;;
47 (defvar *lossage-detected*)
48 (defvar *slime-detected*)
49
50
51 ;;; Note-Lossage, Note-Slime -- Internal
52 ;;;
53 ;;; Signal a warning if appropriate and set the *lossage-detected* flag.
54 ;;;
55 (defun %note-lossage (format-string-thunk &rest format-args)
56 (setq *lossage-detected* t)
57 (when *error-function*
58 (apply *error-function* (funcall format-string-thunk) format-args)))
59
60 (defmacro note-lossage (format-string &rest format-args)
61 `(%note-lossage #'(lambda ()
62 ,format-string)
63 ,@format-args))
64 ;;;
65 (defun %note-slime (format-string-thunk &rest format-args)
66 (setq *slime-detected* t)
67 (when *warning-function*
68 (apply *warning-function* (funcall format-string-thunk) format-args)))
69
70 (defmacro note-slime (format-string &rest format-args)
71 `(%note-slime #'(lambda ()
72 ,format-string)
73 ,@format-args))
74
75
76 (declaim (special *compiler-error-context*))
77
78
79 ;;;; Stuff for checking a call against a function type.
80
81 ;;; ALWAYS-SUBTYPEP -- Interface
82 ;;;
83 ;;; A dummy version of SUBTYPEP useful when we want a functional like
84 ;;; subtypep that always returns true.
85 ;;;
86 (defun always-subtypep (type1 type2)
87 (declare (ignore type1 type2))
88 (values t t))
89
90
91 ;;; Valid-Function-Use -- Interface
92 ;;;
93 ;;; Determine whether a use of a function is consistent with its type.
94 ;;; These values are returned:
95 ;;; T, T: the call is definitely valid.
96 ;;; NIL, T: the call is definitely invalid.
97 ;;; NIL, NIL: unable to determine if the call is valid.
98 ;;;
99 ;;; The Argument-Test function is used to determine whether an argument type
100 ;;; matches the type we are checking against. Similarly, the Result-Test is
101 ;;; used to determine whether the result type matches the specified result.
102 ;;;
103 ;;; Unlike the argument test, the result test may be called on values or
104 ;;; function types. If Strict-Result is true and safety is non-zero, then the
105 ;;; Node-Derived-Type is always used. Otherwise, if Cont's Type-Check is true,
106 ;;; then the Node-Derived-Type is intersected with the Cont's Asserted-Type.
107 ;;;
108 ;;; The error and warning functions are functions that are called to explain
109 ;;; the result. We bind *compiler-error-context* to the combination node so
110 ;;; that Compiler-Warning and related functions will do the right thing if
111 ;;; they are supplied.
112 ;;;
113 (defun valid-function-use (call type &key
114 ((:argument-test *test-function*) #'csubtypep)
115 (result-test #'values-subtypep)
116 (strict-result nil)
117 ((:error-function *error-function*))
118 ((:warning-function *warning-function*)))
119 (declare (type function result-test) (type combination call)
120 (type function-type type))
121 (let* ((*lossage-detected* nil)
122 (*slime-detected* nil)
123 (*compiler-error-context* call)
124 (args (combination-args call))
125 (nargs (length args))
126 (required (function-type-required type))
127 (min-args (length required))
128 (optional (function-type-optional type))
129 (max-args (+ min-args (length optional)))
130 (rest (function-type-rest type))
131 (keyp (function-type-keyp type)))
132
133 (cond
134 ((function-type-wild-args type)
135 (do ((i 1 (1+ i))
136 (arg args (cdr arg)))
137 ((null arg))
138 (check-arg-type (car arg) *wild-type* i)))
139 ((not (or optional keyp rest))
140 (if (/= nargs min-args)
141 (note-lossage
142 (intl:ngettext "Function called with ~R argument, but wants exactly ~R."
143 "Function called with ~R arguments, but wants exactly ~R."
144 nargs)
145 nargs min-args)
146 (check-fixed-and-rest args required nil)))
147 ((< nargs min-args)
148 (note-lossage
149 (intl:ngettext "Function called with ~R argument, but wants at least ~R."
150 "Function called with ~R arguments, but wants at least ~R."
151 nargs)
152 nargs min-args))
153 ((<= nargs max-args)
154 (check-fixed-and-rest args (append required optional) rest))
155 ((not (or keyp rest))
156 (note-lossage
157 (intl:ngettext "Function called with ~R argument, but wants at most ~R."
158 "Function called with ~R arguments, but wants at most ~R."
159 nargs)
160 nargs max-args))
161 ((and keyp (oddp (- nargs max-args)))
162 (note-lossage
163 (intl:gettext "Function has an odd number of arguments in the keyword portion.")))
164 (t
165 (check-fixed-and-rest args (append required optional) rest)
166 (when keyp
167 (check-keywords args max-args type))))
168
169 (let* ((dtype (node-derived-type call))
170 (return-type (function-type-returns type))
171 (cont (node-cont call))
172 (out-type
173 (if (or (not (continuation-type-check cont))
174 (and strict-result (policy call (/= safety 0))))
175 dtype
176 (values-type-intersection (continuation-asserted-type cont)
177 dtype))))
178 (multiple-value-bind (int win)
179 (funcall result-test out-type return-type)
180 (cond ((not win)
181 (note-slime (intl:gettext "Can't tell whether the result is a ~S.")
182 (type-specifier return-type)))
183 ((not int)
184 (note-lossage (intl:gettext "The result is a ~S, not a ~S.")
185 (type-specifier out-type)
186 (type-specifier return-type))))))
187
188 (cond (*lossage-detected* (values nil t))
189 (*slime-detected* (values nil nil))
190 (t (values t t)))))
191
192
193 ;;; Check-Arg-Type -- Internal
194 ;;;
195 ;;; Check that the derived type of the continuation Cont is compatible with
196 ;;; Type. N is the arg number, for error message purposes. We return true if
197 ;;; arg is definitely o.k. If the type is a magic CONSTANT-TYPE, then we check
198 ;;; for the argument being a constant value of the specified type. If there is
199 ;;; a manfest type error (DERIVED-TYPE = NIL), then we flame about the asserted
200 ;;; type even when our type is satisfied under the test.
201 ;;;
202 (defun check-arg-type (cont type n)
203 (declare (type continuation cont) (type ctype type) (type index n))
204 (cond
205 ((not (constant-type-p type))
206 (let ((ctype (continuation-type cont)))
207 (multiple-value-bind (int win)
208 (funcall *test-function* ctype type)
209 (cond ((not win)
210 (note-slime (intl:gettext "Can't tell whether the ~:R argument is a ~S.") n
211 (type-specifier type))
212 nil)
213 ((not int)
214 (note-lossage (intl:gettext "The ~:R argument is a ~S, not a ~S.") n
215 (type-specifier ctype)
216 (type-specifier type))
217 nil)
218 ((eq ctype *empty-type*)
219 (note-slime (intl:gettext "The ~:R argument never returns a value.") n)
220 nil)
221 (t t)))))
222 ((not (constant-continuation-p cont))
223 (note-slime (intl:gettext "The ~:R argument is not a constant.") n)
224 nil)
225 (t
226 (let ((val (continuation-value cont))
227 (type (constant-type-type type)))
228 (multiple-value-bind (res win)
229 (ctypep val type)
230 (cond ((not win)
231 (note-slime (intl:gettext "Can't tell whether the ~:R argument is a ~
232 constant ~S:~% ~S")
233 n (type-specifier type) val)
234 nil)
235 ((not res)
236 (note-lossage (intl:gettext "The ~:R argument is not a constant ~S:~% ~S")
237 n (type-specifier type) val)
238 nil)
239 (t t)))))))
240
241
242 ;;; Check-Fixed-And-Rest -- Internal
243 ;;;
244 ;;; Check that each of the type of each supplied argument intersects with
245 ;;; the type specified for that argument. If we can't tell, then we complain
246 ;;; about the slime.
247 ;;;
248 (defun check-fixed-and-rest (args types rest)
249 (declare (list args types) (type (or ctype null) rest))
250 (do ((arg args (cdr arg))
251 (type types (cdr type))
252 (n 1 (1+ n)))
253 ((or (null type) (null arg))
254 (when rest
255 (dolist (arg arg)
256 (check-arg-type arg rest n)
257 (incf n))))
258 (declare (fixnum n))
259 (check-arg-type (car arg) (car type) n)))
260
261
262 ;;; Check-Keywords -- Internal
263 ;;;
264 ;;; Check that the keyword args are of the correct type. Each keyword
265 ;;; should be known and the corresponding argument should be of the correct
266 ;;; type. If the keyword isn't a constant, then we can't tell, so we note
267 ;;; slime.
268 ;;;
269 (defun check-keywords (args pre-key type)
270 (declare (list args) (fixnum pre-key))
271 (let ((allow-other-keys nil)
272 (allow-other-keys-seen nil))
273 (do ((key (nthcdr pre-key args) (cddr key))
274 (n (1+ pre-key) (+ n 2)))
275 ((null key))
276 (declare (fixnum n))
277 (let ((k (car key)))
278 (cond
279 ((not (check-arg-type k (specifier-type 'symbol) n)))
280 ((not (constant-continuation-p k))
281 (note-slime (intl:gettext "The ~:R argument (in keyword position) is not a constant.")
282 n))
283 (t
284 (let* ((name (continuation-value k))
285 (info (find name (function-type-keywords type)
286 :key #'key-info-name)))
287 (cond (allow-other-keys)
288 ((eq name :allow-other-keys)
289 (unless allow-other-keys-seen
290 (let ((value (second key)))
291 ;; If the value of :allow-other-keys has a
292 ;; known constant value, use that so we can
293 ;; enable (or disable) checking of args at
294 ;; compile time.
295 ;;
296 ;; If :allow-other-keys is not a compile-time
297 ;; constant, set ALLOW-OTHER-KEYS to T so that
298 ;; we don't do checking at compile time, but
299 ;; also warn that it's not constant. Run-time
300 ;; checking, of course, still happens.
301 (if (constant-continuation-p value)
302 (setq allow-other-keys (continuation-value value))
303 (progn
304 (setq allow-other-keys t)
305 (note-slime (intl:gettext "The value of ~S is not a constant")
306 :allow-other-keys)))
307 (setq allow-other-keys-seen t))))
308 ((not info)
309 (unless (function-type-allowp type)
310 (note-lossage (intl:gettext "~S is not a known argument keyword.")
311 name)))
312 (t
313 (check-arg-type (second key) (key-info-type info)
314 (1+ n)))))))))))
315
316
317 ;;; Definition-Type -- Interface
318 ;;;
319 ;;; Construct a function type from a definition.
320 ;;;
321 ;;; Due to the lack of a (list x) type specifier, we can't reconstruct the
322 ;;; &rest type.
323 ;;;
324 (defun definition-type (functional)
325 (declare (type functional functional) (values function-type))
326 (if (lambda-p functional)
327 (make-function-type
328 :required (mapcar #'leaf-type (lambda-vars functional))
329 :returns (tail-set-type (lambda-tail-set functional)))
330 (let ((rest nil))
331 (collect ((req)
332 (opt)
333 (keys))
334 (dolist (arg (optional-dispatch-arglist functional))
335 (let ((info (lambda-var-arg-info arg))
336 (type (leaf-type arg)))
337 (if info
338 (ecase (arg-info-kind info)
339 (:required (req type))
340 (:optional (opt type))
341 (:keyword
342 (keys (make-key-info :name (arg-info-keyword info)
343 :type type)))
344 ((:rest :more-context)
345 (setq rest *universal-type*))
346 (:more-count))
347 (req type))))
348
349 (make-function-type
350 :required (req) :optional (opt) :rest rest :keywords (keys)
351 :keyp (optional-dispatch-keyp functional)
352 :allowp (optional-dispatch-allowp functional)
353 :returns (tail-set-type
354 (lambda-tail-set
355 (optional-dispatch-main-entry functional))))))))
356
357
358
359 ;;;; Approximate function types:
360 ;;;
361 ;;; Approximate function types provide a condensed representation of all the
362 ;;; different ways that a function has been used. If we have no declared or
363 ;;; defined type for a function, then we build an approximate function type
364 ;;; by examining each use of the function. When we encounter a definition or
365 ;;; proclamation, we can check the actual type for compatibity with the
366 ;;; previous uses.
367
368
369 (defstruct (approximate-function-type)
370 ;;
371 ;; The smallest and largest numbers of arguments that this function has been
372 ;; called with.
373 (min-args call-arguments-limit :type fixnum)
374 (max-args 0 :type fixnum)
375 ;;
376 ;; A list of lists of the all the types that have been used in each argument
377 ;; position.
378 (types () :type list)
379 ;;
380 ;; A list of the Approximate-Key-Info structures describing all the things
381 ;; that looked like keyword arguments. There are distinct structures
382 ;; describing each argument position in which the keyword appeared.
383 (keys () :type list))
384
385
386 (defstruct (approximate-key-info)
387 ;;
388 ;; The keyword name of this argument. Although keyword names don't have to
389 ;; be keywords, we only match on keywords when figuring an approximate type.
390 (name (required-argument) :type keyword)
391 ;;
392 ;; The position at which this keyword appeared. 0 if it appeared as the
393 ;; first argument, etc.
394 (position (required-argument) :type fixnum)
395 ;;
396 ;; A list of all the argument types that have been used with this keyword.
397 (types nil :type list)
398 ;;
399 ;; True if this keyword has appeared only in calls with an obvious
400 ;; :allow-other-keys.
401 (allowp nil :type (member t nil)))
402
403
404 ;;; Note-Function-Use -- Interface
405 ;;;
406 ;;; Return an Approximate-Function-Type representing the context of Call.
407 ;;; If Type is supplied and not null, then we merge the information into the
408 ;;; information already accumulated in Type.
409 ;;;
410 (defun note-function-use (call &optional type)
411 (declare (type combination call)
412 (type (or approximate-function-type null) type)
413 (values approximate-function-type))
414 (let* ((type (or type (make-approximate-function-type)))
415 (types (approximate-function-type-types type))
416 (args (combination-args call))
417 (nargs (length args))
418 (allowp (some #'(lambda (x)
419 (and (constant-continuation-p x)
420 (eq (continuation-value x) :allow-other-keys)))
421 args)))
422
423 (setf (approximate-function-type-min-args type)
424 (min (approximate-function-type-min-args type) nargs))
425 (setf (approximate-function-type-max-args type)
426 (max (approximate-function-type-max-args type) nargs))
427
428 (do ((old types (cdr old))
429 (arg args (cdr arg)))
430 ((null old)
431 (setf (approximate-function-type-types type)
432 (nconc types
433 (mapcar #'(lambda (x)
434 (list (continuation-type x)))
435 arg))))
436 (when (null arg) (return))
437 (pushnew (continuation-type (car arg))
438 (car old)
439 :test #'type=))
440
441 (collect ((keys (approximate-function-type-keys type) cons))
442 (do ((arg args (cdr arg))
443 (pos 0 (1+ pos)))
444 ((or (null arg) (null (cdr arg)))
445 (setf (approximate-function-type-keys type) (keys)))
446 (let ((key (first arg))
447 (val (second arg)))
448 (when (constant-continuation-p key)
449 (let ((name (continuation-value key)))
450 (when (keywordp name)
451 (let ((old (find-if
452 #'(lambda (x)
453 (and (eq (approximate-key-info-name x) name)
454 (= (approximate-key-info-position x)
455 pos)))
456 (keys)))
457 (val-type (continuation-type val)))
458 (cond (old
459 (pushnew val-type
460 (approximate-key-info-types old)
461 :test #'type=)
462 (unless allowp
463 (setf (approximate-key-info-allowp old) nil)))
464 (t
465 (keys (make-approximate-key-info
466 :name name :position pos :allowp allowp
467 :types (list val-type))))))))))))
468 type))
469
470
471 ;;; Valid-Approximate-Type -- Interface
472 ;;;
473 ;;; Similar to Valid-Function-Use, but checks an Approximate-Function-Type
474 ;;; against a real function type.
475 ;;;
476 (defun valid-approximate-type (call-type type &optional
477 (*test-function* #'types-intersect)
478 (*error-function* #'compiler-warning)
479 (*warning-function* #'compiler-note))
480 (declare (type approximate-function-type call-type)
481 (type function-type type)
482 (function *test-function* *error-function* *warning-function*)
483 (values boolean boolean))
484 (let* ((*lossage-detected* nil)
485 (*slime-detected* nil)
486 (required (function-type-required type))
487 (min-args (length required))
488 (optional (function-type-optional type))
489 (max-args (+ min-args (length optional)))
490 (rest (function-type-rest type))
491 (keyp (function-type-keyp type)))
492
493 (when (function-type-wild-args type)
494 (return-from valid-approximate-type (values t t)))
495
496 (let ((call-min (approximate-function-type-min-args call-type)))
497 (when (< call-min min-args)
498 (note-lossage
499 (intl:ngettext "Function previously called with ~R argument, but wants at least ~R."
500 "Function previously called with ~R arguments, but wants at least ~R."
501 call-min)
502 call-min min-args)))
503
504 (let ((call-max (approximate-function-type-max-args call-type)))
505 (cond ((<= call-max max-args))
506 ((not (or keyp rest))
507 (note-lossage
508 (intl:ngettext "Function previously called with ~R argument, but wants at most ~R."
509 "Function previously called with ~R arguments, but wants at most ~R."
510 call-max)
511 call-max max-args))
512 ((and keyp (oddp (- call-max max-args)))
513 (note-lossage
514 (intl:gettext "Function previously called with an odd number of arguments in ~
515 the keyword portion."))))
516
517 (when (and keyp (> call-max max-args))
518 (check-approximate-keywords call-type max-args type)))
519
520 (check-approximate-fixed-and-rest call-type (append required optional)
521 rest)
522
523 (cond (*lossage-detected* (values nil t))
524 (*slime-detected* (values nil nil))
525 (t (values t t)))))
526
527
528 ;;; Check-Approximate-Fixed-And-Rest -- Internal
529 ;;;
530 ;;; Check that each of the types used at each arg position is compatible
531 ;;; with the actual type.
532 ;;;
533 (defun check-approximate-fixed-and-rest (call-type fixed rest)
534 (declare (type approximate-function-type call-type)
535 (list fixed)
536 (type (or ctype null) rest))
537 (do ((types (approximate-function-type-types call-type) (cdr types))
538 (n 1 (1+ n))
539 (arg fixed (cdr arg)))
540 ((null types))
541 (let ((decl-type (or (car arg) rest)))
542 (unless decl-type (return))
543 (check-approximate-arg-type (car types) decl-type "~:R" n))))
544
545
546 ;;; Check-Approximate-Arg-Type -- Internal
547 ;;;
548 ;;; Check that each of the call-types is compatible with Decl-Type,
549 ;;; complaining if not or if we can't tell.
550 ;;;
551 (defun check-approximate-arg-type (call-types decl-type context &rest args)
552 (declare (list call-types) (type ctype decl-type) (string context))
553 (let ((losers *empty-type*))
554 (dolist (ctype call-types)
555 (multiple-value-bind (int win)
556 (funcall *test-function* ctype decl-type)
557 (cond
558 ((not win)
559 (note-slime (intl:gettext "Can't tell whether previous ~? argument type ~S is a ~S.")
560 context args (type-specifier ctype) (type-specifier decl-type)))
561 ((not int)
562 (setq losers (type-union ctype losers))))))
563
564 (unless (eq losers *empty-type*)
565 (note-lossage (intl:gettext "~:(~?~) argument should be a ~S but was a ~S in a previous call.")
566 context args (type-specifier decl-type) (type-specifier losers)))))
567
568
569 ;;; Check-Approximate-Keywords -- Internal
570 ;;;
571 ;;; Check the types of each manifest keyword that appears in a keyword
572 ;;; argument position. Check the validity of all keys that appeared in valid
573 ;;; keyword positions.
574 ;;;
575 ;;; ### We could check the Approximate-Function-Type-Types to make sure that
576 ;;; all arguments in keyword positions were manifest keywords.
577 ;;;
578 (defun check-approximate-keywords (call-type max-args type)
579 (let ((call-keys (approximate-function-type-keys call-type))
580 (keys (function-type-keywords type)))
581 (dolist (key keys)
582 (let ((name (key-info-name key)))
583 (collect ((types nil append))
584 (dolist (call-key call-keys)
585 (let ((pos (approximate-key-info-position call-key)))
586 (when (and (eq (approximate-key-info-name call-key) name)
587 (> pos max-args) (evenp (- pos max-args)))
588 (types (approximate-key-info-types call-key)))))
589 (check-approximate-arg-type (types) (key-info-type key) "~S" name))))
590
591 (unless (function-type-allowp type)
592 (collect ((names () adjoin))
593 (dolist (call-key call-keys)
594 (let ((pos (approximate-key-info-position call-key)))
595 (when (and (> pos max-args) (evenp (- pos max-args))
596 (not (approximate-key-info-allowp call-key)))
597 (names (approximate-key-info-name call-key)))))
598
599 (dolist (name (names))
600 (unless (find name keys :key #'key-info-name)
601 (note-lossage (intl:gettext "Function previously called with unknown argument keyword ~S.")
602 name)))))))
603
604
605 ;;;; ASSERT-DEFINITION-TYPE
606
607 ;;; TRY-TYPE-INTERSECTIONS -- Internal
608 ;;;
609 ;;; Intersect Lambda's var types with Types, giving a warning if there is a
610 ;;; mismatch. If all intersections are non-null, we return lists of the
611 ;;; variables and intersections, otherwise we return NIL, NIL.
612 ;;;
613 (defun try-type-intersections (vars types where)
614 (declare (list vars types) (string where))
615 (collect ((res))
616 (mapc #'(lambda (var type)
617 (let* ((vtype (leaf-type var))
618 (int (type-intersection vtype type)))
619 (cond
620 ((eq int *empty-type*)
621 (note-lossage
622 (intl:gettext "Definition's declared type for variable ~A:~% ~S~@
623 conflicts with this type from ~A:~% ~S")
624 (leaf-name var) (type-specifier vtype)
625 where (type-specifier type))
626 (return-from try-type-intersections (values nil nil)))
627 (t
628 (res int)))))
629 vars types)
630 (values vars (res))))
631
632
633 ;;; FIND-OPTIONAL-DISPATCH-TYPES -- Internal
634 ;;;
635 ;;; Check that the optional-dispatch OD conforms to Type. We return the
636 ;;; values of TRY-TYPE-INTERSECTIONS if there are no syntax problems, otherwise
637 ;;; NIL, NIL.
638 ;;;
639 ;;; Note that the variables in the returned list are the actual original
640 ;;; variables (extracted from the optional dispatch arglist), rather than the
641 ;;; variables that are arguments to the main entry. This difference is
642 ;;; significant only for keyword args with hairy defaults. Returning the
643 ;;; actual vars allows us to use the right variable name in warnings.
644 ;;;
645 ;;; A slightly subtle point: with keywords and optionals, the type in the
646 ;;; function type is only an assertion on calls --- it doesn't constrain the
647 ;;; type of default values. So we have to union in the type of the default.
648 ;;; With optionals, we can't do any assertion unless the default is constant.
649 ;;;
650 ;;; With keywords, we exploit our knowledge about how hairy keyword
651 ;;; defaulting is done when computing the type assertion to put on the
652 ;;; main-entry argument. In the case of hairy keywords, the default has been
653 ;;; clobbered with NIL, which is the value of the main-entry arg in the
654 ;;; unsupplied case, whatever the actual default value is. So we can just
655 ;;; assume the default is constant, effectively unioning in NULL, and not
656 ;;; totally blow off doing any type assertion.
657 ;;;
658 (defun find-optional-dispatch-types (od type where)
659 (declare (type optional-dispatch od) (type function-type type)
660 (string where))
661 (let* ((min (optional-dispatch-min-args od))
662 (req (function-type-required type))
663 (opt (function-type-optional type)))
664 (flet ((frob (x y what)
665 (unless (= x y)
666 (note-lossage
667 (intl:ngettext "Definition has ~R ~A arg, but ~A has ~R."
668 "Definition has ~R ~A args, but ~A has ~R."
669 x)
670 x what where y))))
671 ;; TRANSLATORS: Usage is "Definition has <n> FIXED args but <where> <m>"
672 ;; TRANSLATORS: Translate FIXED above appropriately.
673 (frob min (length req) (intl:gettext "fixed"))
674 ;; TRANSLATORS: Usage is "Definition has <n> OPTIONAL args but <where> <m>"
675 ;; TRANSLATORS: Translate OPTIONAL above appropriately.
676 (frob (- (optional-dispatch-max-args od) min) (length opt) (intl:gettext "optional")))
677 (flet ((frob (x y what)
678 (unless (eq x y)
679 ;; TRANSLATORS: This format string probably needs to be
680 ;; TRANSLATORS: updated to allow better translations.
681 (note-lossage
682 (intl:gettext "Definition ~:[doesn't have~;has~] ~A, but ~
683 ~A ~:[doesn't~;does~].")
684 x what where y))))
685 (frob (optional-dispatch-keyp od) (function-type-keyp type)
686 (intl:gettext "keyword args"))
687 (unless (optional-dispatch-keyp od)
688 (frob (not (null (optional-dispatch-more-entry od)))
689 (not (null (function-type-rest type)))
690 (intl:gettext "rest args")))
691 (frob (optional-dispatch-allowp od) (function-type-allowp type)
692 "&allow-other-keys"))
693
694 (when *lossage-detected*
695 (return-from find-optional-dispatch-types (values nil nil)))
696
697 (collect ((res)
698 (vars))
699 (let ((keys (function-type-keywords type))
700 (arglist (optional-dispatch-arglist od)))
701 (dolist (arg arglist)
702 (cond
703 ((lambda-var-arg-info arg)
704 (let* ((info (lambda-var-arg-info arg))
705 (default (arg-info-default info))
706 (def-type (when (constantp default)
707 (ctype-of (eval default)))))
708 (ecase (arg-info-kind info)
709 (:keyword
710 (let* ((key (arg-info-keyword info))
711 (kinfo (find key keys :key #'key-info-name)))
712 (cond
713 (kinfo
714 (res (type-union (key-info-type kinfo)
715 (or def-type (specifier-type 'null)))))
716 (t
717 (note-lossage
718 (intl:gettext "Defining a ~S keyword not present in ~A.")
719 key where)
720 (res *universal-type*)))))
721 (:required (res (pop req)))
722 (:optional
723 (res (type-union (pop opt) (or def-type *universal-type*))))
724 (:rest
725 (when (function-type-rest type)
726 (res (specifier-type 'list))))
727 (:more-context
728 (when (function-type-rest type)
729 (res *universal-type*)))
730 (:more-count
731 (when (function-type-rest type)
732 (res (specifier-type 'fixnum)))))
733 (vars arg)
734 (when (arg-info-supplied-p info)
735 (res *universal-type*)
736 (vars (arg-info-supplied-p info)))))
737 (t
738 (res (pop req))
739 (vars arg))))
740
741 (dolist (key keys)
742 (unless (find (key-info-name key) arglist
743 :key #'(lambda (x)
744 (let ((info (lambda-var-arg-info x)))
745 (when info
746 (arg-info-keyword info)))))
747 (note-lossage
748 (intl:gettext "Definition lacks the ~S keyword present in ~A.")
749 (key-info-name key) where))))
750
751 (try-type-intersections (vars) (res) where))))
752
753
754 ;;; FIND-LAMBDA-TYPES -- Internal
755 ;;;
756 ;;; Check that Type doesn't specify any funny args, and do the intersection.
757 ;;;
758 (defun find-lambda-types (lambda type where)
759 (declare (type clambda lambda) (type function-type type) (string where))
760 (flet ((frob (x what)
761 (when x
762 (note-lossage
763 (intl:gettext "Definition has no ~A, but the ~A did.")
764 what where))))
765 (frob (function-type-optional type) (intl:gettext "optional args"))
766 (frob (function-type-keyp type) (intl:gettext "keyword args"))
767 (frob (function-type-rest type) (intl:gettext "rest arg")))
768 (let* ((vars (lambda-vars lambda))
769 (nvars (length vars))
770 (req (function-type-required type))
771 (nreq (length req)))
772 (unless (= nvars nreq)
773 (note-lossage (intl:ngettext "Definition has ~R arg, but the ~A has ~R."
774 "Definition has ~R args, but the ~A has ~R."
775 nvars)
776 nvars where nreq))
777 (if *lossage-detected*
778 (values nil nil)
779 (try-type-intersections vars req where))))
780
781
782 ;;; ASSERT-DEFINITION-TYPE -- Interface
783 ;;;
784 ;;; Check for syntactic and type conformance between the definition
785 ;;; Functional and the specified Function-Type. If they are compatible and
786 ;;; Really-Assert is T, then add type assertions to the defintion from the
787 ;;; Function-Type.
788 ;;;
789 ;;; If there is a syntactic or type problem, then we call Error-Function
790 ;;; with an error message using Where as context describing where Function-Type
791 ;;; came from.
792 ;;;
793 ;;; If there is no problem, we return T (even if Really-Assert was false).
794 ;;; If there was a problem, we return NIL.
795 ;;;
796 (defun assert-definition-type
797 (functional type &key (really-assert t)
798 ((:error-function *error-function*) #'compiler-warning)
799 warning-function
800 (where (intl:gettext "previous declaration")))
801 (declare (type functional functional)
802 (type function *error-function*)
803 (string where))
804 (unless (function-type-p type) (return-from assert-definition-type t))
805 (let ((*lossage-detected* nil))
806 (multiple-value-bind
807 (vars types)
808 (if (function-type-wild-args type)
809 (values nil nil)
810 (etypecase functional
811 (optional-dispatch
812 (find-optional-dispatch-types functional type where))
813 (clambda
814 (find-lambda-types functional type where))))
815 (let* ((type-returns (function-type-returns type))
816 (return (lambda-return (main-entry functional)))
817 (atype (when return
818 (continuation-asserted-type (return-result return)))))
819 (cond
820 ((and atype (not (values-types-intersect atype type-returns)))
821 (note-lossage
822 (intl:gettext "The result type from ~A:~% ~S~@
823 conflicts with the definition's result type assertion:~% ~S")
824 where (type-specifier type-returns) (type-specifier atype))
825 nil)
826 (*lossage-detected* nil)
827 ((not really-assert) t)
828 (t
829 (when atype
830 (assert-continuation-type (return-result return) atype))
831 (loop for var in vars and type in types do
832 (cond ((basic-var-sets var)
833 (when (and warning-function
834 (not (csubtypep (leaf-type var) type)))
835 (funcall warning-function
836 (intl:gettext "Assignment to argument: ~S~% ~
837 prevents use of assertion from function ~
838 type ~A:~% ~S~%")
839 (leaf-name var) where (type-specifier type))))
840 (t
841 (setf (leaf-type var) type)
842 (dolist (ref (leaf-refs var))
843 (derive-node-type ref type)))))
844 t))))))

  ViewVC Help
Powered by ViewVC 1.1.5