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 ;;;; 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.
  18
  19 (in-package "SB!C")
  20
  21 (declaim (type (or function null) *lossage-fun* *unwinnage-fun* *ctype-test-fun*))
  22
  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*)
  33
  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.
  39
  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...
  45 ;;;
  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
  58 ;;; Signal a warning if appropriate and set *FOO-DETECTED*.
  59 (declaim (ftype (function (string &rest t) (values)) note-lossage note-unwinnage))
  60 (defun note-lossage (format-string &rest format-args)
  61   (setq *lossage-detected* t)
  62   (when *lossage-fun*
  63     (apply *lossage-fun* format-string format-args))
  64   (values))
  65 (defun note-unwinnage (format-string &rest format-args)
  66   (setq *unwinnage-detected* t)
  67   (when *unwinnage-fun*
  68     (apply *unwinnage-fun* format-string format-args))
  69   (values))
  70
  71 (declaim (special *compiler-error-context*))
  72 \f
  73 ;;;; stuff for checking a call against a function type
  74 ;;;;
  75 ;;;; FIXME: This is stuff to look at when I get around to fixing
  76 ;;;; function type inference and declarations.
  77
  78 ;;; A dummy version of SUBTYPEP useful when we want a functional like
  79 ;;; SUBTYPEP that always returns true.
  80 (defun always-subtypep (type1 type2)
  81   (declare (ignore type1 type2))
  82   (values t t))
  83
  84 ;;; Determine whether a use of a function is consistent with its type.
  85 ;;; These values are returned:
  86 ;;;    T, T: the call is definitely valid.
  87 ;;;    NIL, T: the call is definitely invalid.
  88 ;;;    NIL, NIL: unable to determine whether the call is valid.
  89 ;;;
  90 ;;; The ARGUMENT-TEST function is used to determine whether an
  91 ;;; argument type matches the type we are checking against. Similarly,
  92 ;;; the RESULT-TEST is used to determine whether the result type
  93 ;;; matches the specified result.
  94 ;;;
  95 ;;; Unlike the argument test, the result test may be called on values
  96 ;;; or function types. NODE-DERIVED-TYPE is intersected with the
  97 ;;; trusted asserted type.
  98 ;;;
  99 ;;; The error and warning functions are functions that are called to
 100 ;;; explain the result. We bind *COMPILER-ERROR-CONTEXT* to the
 101 ;;; combination node so that COMPILER-WARNING and related functions
 102 ;;; will do the right thing if they are supplied.
 103 (defun valid-fun-use (call type &key
 104                       ((:argument-test *ctype-test-fun*) #'csubtypep)
 105                       (result-test #'values-subtypep)
 106                       ((:lossage-fun *lossage-fun*))
 107                       ((:unwinnage-fun *unwinnage-fun*)))
 108   (declare (type (or function null) result-test) (type combination call)
 109            ;; FIXME: Could TYPE here actually be something like
 110            ;; (AND GENERIC-FUNCTION (FUNCTION (T) T))?  How
 111            ;; horrible...  -- CSR, 2003-05-03
 112            (type ctype type))
 113   (let* ((*lossage-detected* nil)
 114          (*unwinnage-detected* nil)
 115          (*compiler-error-context* call)
 116          (args (combination-args call)))
 117     (if (fun-type-p type)
 118         (let* ((nargs (length args))
 119                (required (fun-type-required type))
 120                (min-args (length required))
 121                (optional (fun-type-optional type))
 122                (max-args (+ min-args (length optional)))
 123                (rest (fun-type-rest type))
 124                (keyp (fun-type-keyp type)))
 125           (cond
 126             ((fun-type-wild-args type)
 127              (loop for arg in args
 128                    and i from 1
 129                    do (check-arg-type arg *universal-type* i)))
 130             ((not (or optional keyp rest))
 131              (if (/= nargs min-args)
 132                  (note-lossage
 133                   "The function was called with ~R argument~:P, but wants exactly ~R."
 134                   nargs min-args)
 135                  (check-fixed-and-rest args required nil)))
 136             ((< nargs min-args)
 137              (note-lossage
 138               "The function was called with ~R argument~:P, but wants at least ~R."
 139               nargs min-args))
 140             ((<= nargs max-args)
 141              (check-fixed-and-rest args (append required optional) rest))
 142             ((not (or keyp rest))
 143              (note-lossage
 144               "The function was called with ~R argument~:P, but wants at most ~R."
 145               nargs max-args))
 146             ((and keyp (oddp (- nargs max-args)))
 147              (note-lossage
 148               "The function has an odd number of arguments in the keyword portion."))
 149             (t
 150              (check-fixed-and-rest args (append required optional) rest)
 151              (when keyp
 152                (check-key-args args max-args type))))
 153
 154           (when result-test
 155             (let* ((dtype (node-derived-type call))
 156                    (out-type (or
 157                               (binding* ((lvar (node-lvar call) :exit-if-null)
 158                                          (dest (lvar-dest lvar)))
 159                                 (when (and (cast-p dest)
 160                                            (eq (cast-type-to-check dest) *wild-type*)
 161                                            (immediately-used-p lvar call))
 162                                   (values-type-intersection
 163                                    dtype (cast-asserted-type dest))))
 164                               dtype))
 165                    (return-type (fun-type-returns type)))
 166               (multiple-value-bind (int win) (funcall result-test out-type return-type)
 167                 (cond ((not win)
 168                        (note-unwinnage "can't tell whether the result is a ~S"
 169                                        (type-specifier return-type)))
 170                       ((not int)
 171                        (note-lossage "The result is a ~S, not a ~S."
 172                                      (type-specifier out-type)
 173                                      (type-specifier return-type))))))))
 174         (loop for arg in args
 175               and i from 1
 176               do (check-arg-type arg *wild-type* i)))
 177     (cond (*lossage-detected* (values nil t))
 178           (*unwinnage-detected* (values nil nil))
 179           (t (values t t)))))
 180
 181 ;;; Check that the derived type of the LVAR is compatible with TYPE. N
 182 ;;; is the arg number, for error message purposes. We return true if
 183 ;;; arg is definitely o.k. If the type is a magic CONSTANT-TYPE, then
 184 ;;; we check for the argument being a constant value of the specified
 185 ;;; type. If there is a manifest type error (DERIVED-TYPE = NIL), then
 186 ;;; we flame about the asserted type even when our type is satisfied
 187 ;;; under the test.
 188 (defun check-arg-type (lvar type n)
 189   (declare (type lvar lvar) (type ctype type) (type index n))
 190   (cond
 191    ((not (constant-type-p type))
 192     (let ((ctype (lvar-type lvar)))
 193       (multiple-value-bind (int win) (funcall *ctype-test-fun* ctype type)
 194         (cond ((not win)
 195                (note-unwinnage "can't tell whether the ~:R argument is a ~S"
 196                                n (type-specifier type))
 197                nil)
 198               ((not int)
 199                (note-lossage "The ~:R argument is a ~S, not a ~S."
 200                              n (type-specifier ctype) (type-specifier type))
 201                nil)
 202               ((eq ctype *empty-type*)
 203                (note-unwinnage "The ~:R argument never returns a value." n)
 204                nil)
 205               (t t)))))
 206     ((not (constant-lvar-p lvar))
 207      (note-unwinnage "The ~:R argument is not a constant." n)
 208      nil)
 209     (t
 210      (let ((val (lvar-value lvar))
 211            (type (constant-type-type type)))
 212        (multiple-value-bind (res win) (ctypep val type)
 213          (cond ((not win)
 214                 (note-unwinnage "can't tell whether the ~:R argument is a ~
 215                                 constant ~S:~%  ~S"
 216                                 n (type-specifier type) val)
 217                 nil)
 218                ((not res)
 219                 (note-lossage "The ~:R argument is not a constant ~S:~%  ~S"
 220                               n (type-specifier type) val)
 221                 nil)
 222                (t t)))))))
 223
 224 ;;; Check that each of the type of each supplied argument intersects
 225 ;;; with the type specified for that argument. If we can't tell, then
 226 ;;; we can complain about the absence of manifest winnage.
 227 (declaim (ftype (function (list list (or ctype null)) (values)) check-fixed-and-rest))
 228 (defun check-fixed-and-rest (args types rest)
 229   (do ((arg args (cdr arg))
 230        (type types (cdr type))
 231        (n 1 (1+ n)))
 232       ((or (null type) (null arg))
 233        (when rest
 234          (dolist (arg arg)
 235            (check-arg-type arg rest n)
 236            (incf n))))
 237     (declare (fixnum n))
 238     (check-arg-type (car arg) (car type) n))
 239   (values))
 240
 241 ;;; Check that the &KEY args are of the correct type. Each key should
 242 ;;; be known and the corresponding argument should be of the correct
 243 ;;; type. If the key isn't a constant, then we can't tell, so we can
 244 ;;; complain about absence of manifest winnage.
 245 (declaim (ftype (function (list fixnum fun-type) (values)) check-key-args))
 246 (defun check-key-args (args pre-key type)
 247   (do ((key (nthcdr pre-key args) (cddr key))
 248        (n (1+ pre-key) (+ n 2)))
 249       ((null key))
 250     (declare (fixnum n))
 251     (let ((k (car key)))
 252       (cond
 253        ((not (check-arg-type k (specifier-type 'symbol) n)))
 254        ((not (constant-lvar-p k))
 255         (note-unwinnage "The ~:R argument (in keyword position) is not a ~
 256                         constant."
 257                         n))
 258        (t
 259         (let* ((name (lvar-value k))
 260                (info (find name (fun-type-keywords type)
 261                            :key #'key-info-name)))
 262           (cond ((not info)
 263                  (unless (fun-type-allowp type)
 264                    (note-lossage "~S is not a known argument keyword."
 265                                  name)))
 266                 (t
 267                  (check-arg-type (second key) (key-info-type info)
 268                                  (1+ n)))))))))
 269   (values))
 270
 271 ;;; Construct a function type from a definition.
 272 ;;;
 273 ;;; Due to the lack of a (LIST X) type specifier, we can't reconstruct
 274 ;;; the &REST type.
 275 (declaim (ftype (sfunction (functional) fun-type) definition-type))
 276 (defun definition-type (functional)
 277   (if (lambda-p functional)
 278       (make-fun-type
 279        :required (mapcar #'leaf-type (lambda-vars functional))
 280        :returns (tail-set-type (lambda-tail-set functional)))
 281       (let ((rest nil))
 282         (collect ((req)
 283                   (opt)
 284                   (keys))
 285           (dolist (arg (optional-dispatch-arglist functional))
 286             (let ((info (lambda-var-arg-info arg))
 287                   (type (leaf-type arg)))
 288               (if info
 289                   (ecase (arg-info-kind info)
 290                     (:required (req type))
 291                     (:optional (opt type))
 292                     (:keyword
 293                      (keys (make-key-info :name (arg-info-key info)
 294                                           :type type)))
 295                     ((:rest :more-context)
 296                      (setq rest *universal-type*))
 297                     (:more-count))
 298                   (req type))))
 299
 300           (make-fun-type
 301            :required (req)
 302            :optional (opt)
 303            :rest rest
 304            :keywords (keys)
 305            :keyp (optional-dispatch-keyp functional)
 306            :allowp (optional-dispatch-allowp functional)
 307            :returns (tail-set-type
 308                      (lambda-tail-set
 309                       (optional-dispatch-main-entry functional))))))))
 310 \f
 311 ;;;; approximate function types
 312 ;;;;
 313 ;;;; FIXME: This is stuff to look at when I get around to fixing function
 314 ;;;; type inference and declarations.
 315 ;;;;
 316 ;;;; Approximate function types provide a condensed representation of all the
 317 ;;;; different ways that a function has been used. If we have no declared or
 318 ;;;; defined type for a function, then we build an approximate function type by
 319 ;;;; examining each use of the function. When we encounter a definition or
 320 ;;;; proclamation, we can check the actual type for compatibity with the
 321 ;;;; previous uses.
 322
 323 (defstruct (approximate-fun-type (:copier nil))
 324   ;; the smallest and largest numbers of arguments that this function
 325   ;; has been called with.
 326   (min-args sb!xc:call-arguments-limit :type fixnum)
 327   (max-args 0 :type fixnum)
 328   ;; a list of lists of the all the types that have been used in each
 329   ;; argument position
 330   (types () :type list)
 331   ;; A list of APPROXIMATE-KEY-INFO structures describing all the
 332   ;; things that looked like &KEY arguments. There are distinct
 333   ;; structures describing each argument position in which the keyword
 334   ;; appeared.
 335   (keys () :type list))
 336
 337 (defstruct (approximate-key-info (:copier nil))
 338   ;; The keyword name of this argument. Although keyword names don't
 339   ;; have to be keywords, we only match on keywords when figuring an
 340   ;; approximate type.
 341   (name (missing-arg) :type keyword)
 342   ;; The position at which this keyword appeared. 0 if it appeared as the
 343   ;; first argument, etc.
 344   (position (missing-arg) :type fixnum)
 345   ;; a list of all the argument types that have been used with this keyword
 346   (types nil :type list)
 347   ;; true if this keyword has appeared only in calls with an obvious
 348   ;; :ALLOW-OTHER-KEYS
 349   (allowp nil :type (member t nil)))
 350
 351 ;;; Return an APPROXIMATE-FUN-TYPE representing the context of
 352 ;;; CALL. If TYPE is supplied and not null, then we merge the
 353 ;;; information into the information already accumulated in TYPE.
 354 (declaim (ftype (function (combination
 355                            &optional (or approximate-fun-type null))
 356                           approximate-fun-type)
 357                 note-fun-use))
 358 (defun note-fun-use (call &optional type)
 359   (let* ((type (or type (make-approximate-fun-type)))
 360          (types (approximate-fun-type-types type))
 361          (args (combination-args call))
 362          (nargs (length args))
 363          (allowp (some (lambda (x)
 364                          (and (constant-lvar-p x)
 365                               (eq (lvar-value x) :allow-other-keys)))
 366                        args)))
 367
 368     (setf (approximate-fun-type-min-args type)
 369           (min (approximate-fun-type-min-args type) nargs))
 370     (setf (approximate-fun-type-max-args type)
 371           (max (approximate-fun-type-max-args type) nargs))
 372
 373     (do ((old types (cdr old))
 374          (arg args (cdr arg)))
 375         ((null old)
 376          (setf (approximate-fun-type-types type)
 377                (nconc types
 378                       (mapcar (lambda (x)
 379                                 (list (lvar-type x)))
 380                               arg))))
 381       (when (null arg) (return))
 382       (pushnew (lvar-type (car arg))
 383                (car old)
 384                :test #'type=))
 385
 386     (collect ((keys (approximate-fun-type-keys type) cons))
 387       (do ((arg args (cdr arg))
 388            (pos 0 (1+ pos)))
 389           ((or (null arg) (null (cdr arg)))
 390            (setf (approximate-fun-type-keys type) (keys)))
 391         (let ((key (first arg))
 392               (val (second arg)))
 393           (when (constant-lvar-p key)
 394             (let ((name (lvar-value key)))
 395               (when (keywordp name)
 396                 (let ((old (find-if
 397                             (lambda (x)
 398                               (and (eq (approximate-key-info-name x) name)
 399                                    (= (approximate-key-info-position x)
 400                                       pos)))
 401                             (keys)))
 402                       (val-type (lvar-type val)))
 403                   (cond (old
 404                          (pushnew val-type
 405                                   (approximate-key-info-types old)
 406                                   :test #'type=)
 407                          (unless allowp
 408                            (setf (approximate-key-info-allowp old) nil)))
 409                         (t
 410                          (keys (make-approximate-key-info
 411                                 :name name
 412                                 :position pos
 413                                 :allowp allowp
 414                                 :types (list val-type))))))))))))
 415     type))
 416
 417 ;;; This is similar to VALID-FUN-USE, but checks an
 418 ;;; APPROXIMATE-FUN-TYPE against a real function type.
 419 (declaim (ftype (function (approximate-fun-type fun-type
 420                            &optional function function function)
 421                           (values boolean boolean))
 422                 valid-approximate-type))
 423 (defun valid-approximate-type (call-type type &optional
 424                                          (*ctype-test-fun*
 425                                           #'types-equal-or-intersect)
 426                                          (*lossage-fun*
 427                                           #'compiler-style-warn)
 428                                          (*unwinnage-fun* #'compiler-notify))
 429   (let* ((*lossage-detected* nil)
 430          (*unwinnage-detected* nil)
 431          (required (fun-type-required type))
 432          (min-args (length required))
 433          (optional (fun-type-optional type))
 434          (max-args (+ min-args (length optional)))
 435          (rest (fun-type-rest type))
 436          (keyp (fun-type-keyp type)))
 437
 438     (when (fun-type-wild-args type)
 439       (return-from valid-approximate-type (values t t)))
 440
 441     (let ((call-min (approximate-fun-type-min-args call-type)))
 442       (when (< call-min min-args)
 443         (note-lossage
 444          "~:@<The function was previously called with ~R argument~:P, ~
 445           but wants at least ~R.~:>"
 446          call-min min-args)))
 447
 448     (let ((call-max (approximate-fun-type-max-args call-type)))
 449       (cond ((<= call-max max-args))
 450             ((not (or keyp rest))
 451              (note-lossage
 452               "~:@<The function was previously called with ~R argument~:P, ~
 453                 but wants at most ~R.~:>"
 454               call-max max-args))
 455             ((and keyp (oddp (- call-max max-args)))
 456              (note-lossage
 457               "~:@<The function was previously called with an odd number of ~
 458                arguments in the keyword portion.~:>")))
 459
 460       (when (and keyp (> call-max max-args))
 461         (check-approximate-keywords call-type max-args type)))
 462
 463     (check-approximate-fixed-and-rest call-type (append required optional)
 464                                       rest)
 465
 466     (cond (*lossage-detected* (values nil t))
 467           (*unwinnage-detected* (values nil nil))
 468           (t (values t t)))))
 469
 470 ;;; Check that each of the types used at each arg position is
 471 ;;; compatible with the actual type.
 472 (declaim (ftype (function (approximate-fun-type list (or ctype null))
 473                           (values))
 474                 check-approximate-fixed-and-rest))
 475 (defun check-approximate-fixed-and-rest (call-type fixed rest)
 476   (do ((types (approximate-fun-type-types call-type) (cdr types))
 477        (n 1 (1+ n))
 478        (arg fixed (cdr arg)))
 479       ((null types))
 480     (let ((decl-type (or (car arg) rest)))
 481       (unless decl-type (return))
 482       (check-approximate-arg-type (car types) decl-type "~:R" n)))
 483   (values))
 484
 485 ;;; Check that each of the call-types is compatible with DECL-TYPE,
 486 ;;; complaining if not or if we can't tell.
 487 (declaim (ftype (function (list ctype string &rest t) (values))
 488                 check-approximate-arg-type))
 489 (defun check-approximate-arg-type (call-types decl-type context &rest args)
 490   (let ((losers *empty-type*))
 491     (dolist (ctype call-types)
 492       (multiple-value-bind (int win) (funcall *ctype-test-fun* ctype decl-type)
 493         (cond
 494          ((not win)
 495           (note-unwinnage "can't tell whether previous ~? ~
 496                            argument type ~S is a ~S"
 497                           context
 498                           args
 499                           (type-specifier ctype)
 500                           (type-specifier decl-type)))
 501          ((not int)
 502           (setq losers (type-union ctype losers))))))
 503
 504     (unless (eq losers *empty-type*)
 505       (note-lossage "~:(~?~) argument should be a ~S but was a ~S in a previous call."
 506                     context args (type-specifier decl-type) (type-specifier losers))))
 507   (values))
 508
 509 ;;; Check the types of each manifest keyword that appears in a keyword
 510 ;;; argument position. Check the validity of all keys that appeared in
 511 ;;; valid keyword positions.
 512 ;;;
 513 ;;; ### We could check the APPROXIMATE-FUN-TYPE-TYPES to make
 514 ;;; sure that all arguments in keyword positions were manifest
 515 ;;; keywords.
 516 (defun check-approximate-keywords (call-type max-args type)
 517   (let ((call-keys (approximate-fun-type-keys call-type))
 518         (keys (fun-type-keywords type)))
 519     (dolist (key keys)
 520       (let ((name (key-info-name key)))
 521         (collect ((types nil append))
 522           (dolist (call-key call-keys)
 523             (let ((pos (approximate-key-info-position call-key)))
 524               (when (and (eq (approximate-key-info-name call-key) name)
 525                          (> pos max-args) (evenp (- pos max-args)))
 526                 (types (approximate-key-info-types call-key)))))
 527           (check-approximate-arg-type (types) (key-info-type key) "~S" name))))
 528
 529     (unless (fun-type-allowp type)
 530       (collect ((names () adjoin))
 531         (dolist (call-key call-keys)
 532           (let ((pos (approximate-key-info-position call-key)))
 533             (when (and (> pos max-args) (evenp (- pos max-args))
 534                        (not (approximate-key-info-allowp call-key)))
 535               (names (approximate-key-info-name call-key)))))
 536
 537         (dolist (name (names))
 538           (unless (find name keys :key #'key-info-name)
 539             (note-lossage "Function previously called with unknown argument keyword ~S."
 540                   name)))))))
 541 \f
 542 ;;;; ASSERT-DEFINITION-TYPE
 543
 544 ;;; Intersect LAMBDA's var types with TYPES, giving a warning if there
 545 ;;; is a mismatch. If all intersections are non-null, we return lists
 546 ;;; of the variables and intersections, otherwise we return NIL, NIL.
 547 (defun try-type-intersections (vars types where)
 548   (declare (list vars types) (string where))
 549   (collect ((res))
 550     (mapc (lambda (var type)
 551             (let* ((vtype (leaf-type var))
 552                    (int (type-approx-intersection2 vtype type)))
 553               (cond
 554                ((eq int *empty-type*)
 555                 (note-lossage
 556                  "Definition's declared type for variable ~A:~%  ~S~@
 557                   conflicts with this type from ~A:~%  ~S"
 558                  (leaf-debug-name var) (type-specifier vtype)
 559                  where (type-specifier type))
 560                 (return-from try-type-intersections (values nil nil)))
 561                (t
 562                 (res int)))))
 563           vars types)
 564     (values vars (res))))
 565
 566 ;;; Check that the optional-dispatch OD conforms to TYPE. We return
 567 ;;; the values of TRY-TYPE-INTERSECTIONS if there are no syntax
 568 ;;; problems, otherwise NIL, NIL.
 569 ;;;
 570 ;;; Note that the variables in the returned list are the actual
 571 ;;; original variables (extracted from the optional dispatch arglist),
 572 ;;; rather than the variables that are arguments to the main entry.
 573 ;;; This difference is significant only for &KEY args with hairy
 574 ;;; defaults. Returning the actual vars allows us to use the right
 575 ;;; variable name in warnings.
 576 ;;;
 577 ;;; A slightly subtle point: with keywords and optionals, the type in
 578 ;;; the function type is only an assertion on calls --- it doesn't
 579 ;;; constrain the type of default values. So we have to union in the
 580 ;;; type of the default. With optionals, we can't do any assertion
 581 ;;; unless the default is constant.
 582 ;;;
 583 ;;; With keywords, we exploit our knowledge about how hairy keyword
 584 ;;; defaulting is done when computing the type assertion to put on the
 585 ;;; main-entry argument. In the case of hairy keywords, the default
 586 ;;; has been clobbered with NIL, which is the value of the main-entry
 587 ;;; arg in the unsupplied case, whatever the actual default value is.
 588 ;;; So we can just assume the default is constant, effectively
 589 ;;; unioning in NULL, and not totally blow off doing any type
 590 ;;; assertion.
 591 (defun find-optional-dispatch-types (od type where)
 592   (declare (type optional-dispatch od)
 593            (type fun-type type)
 594            (string where))
 595   (let* ((min (optional-dispatch-min-args od))
 596          (req (fun-type-required type))
 597          (opt (fun-type-optional type)))
 598     (flet ((frob (x y what)
 599              (unless (= x y)
 600                (note-lossage
 601                 "The definition has ~R ~A arg~P, but ~A has ~R."
 602                 x what x where y))))
 603       (frob min (length req) "fixed")
 604       (frob (- (optional-dispatch-max-args od) min) (length opt) "optional"))
 605     (flet ((frob (x y what)
 606              (unless (eq x y)
 607                (note-lossage
 608                 "The definition ~:[doesn't have~;has~] ~A, but ~
 609                 ~A ~:[doesn't~;does~]."
 610                 x what where y))))
 611       (frob (optional-dispatch-keyp od) (fun-type-keyp type)
 612             "&KEY arguments")
 613       (unless (optional-dispatch-keyp od)
 614         (frob (not (null (optional-dispatch-more-entry od)))
 615               (not (null (fun-type-rest type)))
 616               "&REST arguments"))
 617       (frob (optional-dispatch-allowp od) (fun-type-allowp type)
 618             "&ALLOW-OTHER-KEYS"))
 619
 620     (when *lossage-detected*
 621       (return-from find-optional-dispatch-types (values nil nil)))
 622
 623     (collect ((res)
 624               (vars))
 625       (let ((keys (fun-type-keywords type))
 626             (arglist (optional-dispatch-arglist od)))
 627         (dolist (arg arglist)
 628           (cond
 629            ((lambda-var-arg-info arg)
 630             (let* ((info (lambda-var-arg-info arg))
 631                    (default (arg-info-default info))
 632                    (def-type (when (constantp default)
 633                                (ctype-of (eval default)))))
 634               (ecase (arg-info-kind info)
 635                 (:keyword
 636                  (let* ((key (arg-info-key info))
 637                         (kinfo (find key keys :key #'key-info-name)))
 638                    (cond
 639                     (kinfo
 640                      (res (type-union (key-info-type kinfo)
 641                                       (or def-type (specifier-type 'null)))))
 642                     (t
 643                      (note-lossage
 644                       "Defining a ~S keyword not present in ~A."
 645                       key where)
 646                      (res *universal-type*)))))
 647                 (:required (res (pop req)))
 648                 (:optional
 649                  (res (type-union (pop opt) (or def-type *universal-type*))))
 650                 (:rest
 651                  (when (fun-type-rest type)
 652                    (res (specifier-type 'list))))
 653                 (:more-context
 654                  (when (fun-type-rest type)
 655                    (res *universal-type*)))
 656                 (:more-count
 657                  (when (fun-type-rest type)
 658                    (res (specifier-type 'fixnum)))))
 659               (vars arg)
 660               (when (arg-info-supplied-p info)
 661                 (res *universal-type*)
 662                 (vars (arg-info-supplied-p info)))))
 663            (t
 664             (res (pop req))
 665             (vars arg))))
 666
 667         (dolist (key keys)
 668           (unless (find (key-info-name key) arglist
 669                         :key (lambda (x)
 670                                (let ((info (lambda-var-arg-info x)))
 671                                  (when info
 672                                    (arg-info-key info)))))
 673             (note-lossage
 674              "The definition lacks the ~S key present in ~A."
 675              (key-info-name key) where))))
 676
 677       (try-type-intersections (vars) (res) where))))
 678
 679 ;;; Check that TYPE doesn't specify any funny args, and do the
 680 ;;; intersection.
 681 (defun find-lambda-types (lambda type where)
 682   (declare (type clambda lambda) (type fun-type type) (string where))
 683   (flet ((frob (x what)
 684            (when x
 685              (note-lossage
 686               "The definition has no ~A, but the ~A did."
 687               what where))))
 688     (frob (fun-type-optional type) "&OPTIONAL arguments")
 689     (frob (fun-type-keyp type) "&KEY arguments")
 690     (frob (fun-type-rest type) "&REST argument"))
 691   (let* ((vars (lambda-vars lambda))
 692          (nvars (length vars))
 693          (req (fun-type-required type))
 694          (nreq (length req)))
 695     (unless (= nvars nreq)
 696       (note-lossage "The definition has ~R arg~:P, but the ~A has ~R."
 697                     nvars where nreq))
 698     (if *lossage-detected*
 699         (values nil nil)
 700         (try-type-intersections vars req where))))
 701
 702 ;;; Check for syntactic and type conformance between the definition
 703 ;;; FUNCTIONAL and the specified FUN-TYPE. If they are compatible
 704 ;;; and REALLY-ASSERT is T, then add type assertions to the definition
 705 ;;; from the FUN-TYPE.
 706 ;;;
 707 ;;; If there is a syntactic or type problem, then we call
 708 ;;; LOSSAGE-FUN with an error message using WHERE as context
 709 ;;; describing where FUN-TYPE came from.
 710 ;;;
 711 ;;; If there is no problem, we return T (even if REALLY-ASSERT was
 712 ;;; false). If there was a problem, we return NIL.
 713 (defun assert-definition-type
 714     (functional type &key (really-assert t)
 715      ((:lossage-fun *lossage-fun*)
 716       #'compiler-style-warn)
 717      unwinnage-fun
 718      (where "previous declaration"))
 719   (declare (type functional functional)
 720            (type function *lossage-fun*)
 721            (string where))
 722   (unless (fun-type-p type)
 723     (return-from assert-definition-type t))
 724   (let ((*lossage-detected* nil))
 725     (multiple-value-bind (vars types)
 726         (if (fun-type-wild-args type)
 727             (values nil nil)
 728             (etypecase functional
 729               (optional-dispatch
 730                (find-optional-dispatch-types functional type where))
 731               (clambda
 732                (find-lambda-types functional type where))))
 733       (let* ((type-returns (fun-type-returns type))
 734              (return (lambda-return (main-entry functional)))
 735              (dtype (when return
 736                       (lvar-derived-type (return-result return)))))
 737         (cond
 738           ((and dtype (not (values-types-equal-or-intersect dtype
 739                                                             type-returns)))
 740            (note-lossage
 741             "The result type from ~A:~%  ~S~@
 742            conflicts with the definition's result type:~%  ~S"
 743             where (type-specifier type-returns) (type-specifier dtype))
 744            nil)
 745           (*lossage-detected* nil)
 746           ((not really-assert) t)
 747           (t
 748            (let ((policy (lexenv-policy (functional-lexenv functional))))
 749              (when (policy policy (> type-check 0))
 750                (assert-lvar-type (return-result return) type-returns
 751                                  policy)))
 752            (loop for var in vars and type in types do
 753                  (cond ((basic-var-sets var)
 754                         (when (and unwinnage-fun
 755                                    (not (csubtypep (leaf-type var) type)))
 756                           (funcall unwinnage-fun
 757                                    "Assignment to argument: ~S~%  ~
 758                                prevents use of assertion from function ~
 759                                type ~A:~%  ~S~%"
 760                                    (leaf-debug-name var)
 761                                    where
 762                                    (type-specifier type))))
 763                        (t
 764                         (setf (leaf-type var) type)
 765                         (dolist (ref (leaf-refs var))
 766                           (derive-node-type ref (make-single-value-type type))))))
 767            t))))))
 768
 769 ;;; FIXME: This is quite similar to ASSERT-NEW-DEFINITION.
 770 (defun assert-global-function-definition-type (name fun)
 771   (declare (type functional fun))
 772   (let ((type (info :function :type name))
 773         (where (info :function :where-from name)))
 774     (when (eq where :declared)
 775       (setf (leaf-type fun) type)
 776       (assert-definition-type
 777        fun type
 778        :unwinnage-fun #'compiler-notify
 779        :where "proclamation"
 780        :really-assert (not (awhen (info :function :info name)
 781                              (ir1-attributep (fun-info-attributes it)
 782                                              explicit-check)))))))
 783 \f
 784 ;;; Call FUN with (arg-lvar arg-type)
 785 (defun map-combination-args-and-types (fun call)
 786   (declare (type function fun) (type combination call))
 787   (binding* ((type (lvar-type (combination-fun call)))
 788              (nil (fun-type-p type) :exit-if-null)
 789              (args (combination-args call)))
 790     (dolist (req (fun-type-required type))
 791       (when (null args) (return-from map-combination-args-and-types))
 792       (let ((arg (pop args)))
 793         (funcall fun arg req)))
 794     (dolist (opt (fun-type-optional type))
 795       (when (null args) (return-from map-combination-args-and-types))
 796       (let ((arg (pop args)))
 797         (funcall fun arg opt)))
 798
 799     (let ((rest (fun-type-rest type)))
 800       (when rest
 801         (dolist (arg args)
 802           (funcall fun arg rest))))
 803
 804     (dolist (key (fun-type-keywords type))
 805       (let ((name (key-info-name key)))
 806         (do ((arg args (cddr arg)))
 807             ((null arg))
 808           (when (eq (lvar-value (first arg)) name)
 809             (funcall fun (second arg) (key-info-type key))))))))
 810
 811 ;;; Assert that CALL is to a function of the specified TYPE. It is
 812 ;;; assumed that the call is legal and has only constants in the
 813 ;;; keyword positions.
 814 (defun assert-call-type (call type)
 815   (declare (type combination call) (type fun-type type))
 816   (derive-node-type call (fun-type-returns type))
 817   (let ((policy (lexenv-policy (node-lexenv call))))
 818     (map-combination-args-and-types
 819      (lambda (arg type)
 820        (assert-lvar-type arg type policy))
 821      call))
 822   (values))
 823 \f
 824 ;;;; FIXME: Move to some other file.
 825 (defun check-catch-tag-type (tag)
 826   (declare (type lvar tag))
 827   (let ((ctype (lvar-type tag)))
 828     (when (csubtypep ctype (specifier-type '(or number character)))
 829       (compiler-style-warn "~@<using ~S of type ~S as a catch tag (which ~
 830                             tends to be unportable because THROW and CATCH ~
 831                             use EQ comparison)~@:>"
 832                            (lvar-source tag)
 833                            (type-specifier (lvar-type tag))))))
 834
 835 (defun %compile-time-type-error (values atype dtype)
 836   (declare (ignore dtype))
 837   (if (and (consp atype)
 838            (eq (car atype) 'values))
 839       (error 'values-type-error :datum values :expected-type atype)
 840       (error 'type-error :datum (car values) :expected-type atype)))
 841
 842 (defoptimizer (%compile-time-type-error ir2-convert)
 843     ((objects atype dtype) node block)
 844   (let ((*compiler-error-context* node))
 845     (setf (node-source-path node)
 846           (cdr (node-source-path node)))
 847     (destructuring-bind (values atype dtype)
 848         (basic-combination-args node)
 849       (declare (ignore values))
 850       (let ((atype (lvar-value atype))
 851             (dtype (lvar-value dtype)))
 852       (unless (eq atype nil)
 853         (compiler-warn
 854          "~@<Asserted type ~S conflicts with derived type ~S.~@:>"
 855          atype dtype))))
 856     (ir2-convert-full-call node block)))