src/compiler/ctype.lisp

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