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   (let (lossages allow-other-keys)
 248     (do ((key (nthcdr pre-key args) (cddr key))
 249          (n (1+ pre-key) (+ n 2)))
 250         ((null key))
 251       (declare (fixnum n))
 252       (let ((k (first key))
 253             (v (second key)))
 254         (cond
 255           ((not (check-arg-type k (specifier-type 'symbol) n)))
 256           ((not (constant-lvar-p k))
 257            (note-unwinnage "~@<The ~:R argument (in keyword position) is not ~
 258                             a constant, weakening keyword argument ~
 259                             checking.~:@>" n)
 260            ;; An unknown key may turn out to be :ALLOW-OTHER-KEYS at runtime,
 261            ;; so we cannot signal full warnings for keys that look bad.
 262            (unless allow-other-keys
 263              (setf allow-other-keys :maybe)))
 264           (t
 265            (let* ((name (lvar-value k))
 266                   (info (find name (fun-type-keywords type)
 267                               :key #'key-info-name)))
 268              (cond ((eq name :allow-other-keys)
 269                     (unless allow-other-keys
 270                       (if (constant-lvar-p v)
 271                           (setf allow-other-keys (if (lvar-value v)
 272                                                      :yes
 273                                                      :no))
 274                           (setf allow-other-keys :maybe))))
 275                    ((not info)
 276                     (unless (fun-type-allowp type)
 277                       (pushnew name lossages :test #'eq)))
 278                    (t
 279                     (check-arg-type (second key) (key-info-type info)
 280                                     (1+ n)))))))))
 281     (when (and lossages (member allow-other-keys '(nil :no)))
 282       (setf lossages (nreverse lossages))
 283       (if (cdr lossages)
 284           (note-lossage "~@<~{~S~^, ~} and ~S are not a known argument keywords.~:@>"
 285                         (butlast lossages)
 286                         (car (last lossages)))
 287           (note-lossage "~S is not a known argument keyword."
 288                         (car lossages)))))
 289   (values))
 290
 291 ;;; Construct a function type from a definition.
 292 ;;;
 293 ;;; Due to the lack of a (LIST X) type specifier, we can't reconstruct
 294 ;;; the &REST type.
 295 (declaim (ftype (sfunction (functional) fun-type) definition-type))
 296 (defun definition-type (functional)
 297   (if (lambda-p functional)
 298       (make-fun-type
 299        :required (mapcar #'leaf-type (lambda-vars functional))
 300        :returns (tail-set-type (lambda-tail-set functional)))
 301       (let ((rest nil))
 302         (collect ((req)
 303                   (opt)
 304                   (keys))
 305           (dolist (arg (optional-dispatch-arglist functional))
 306             (let ((info (lambda-var-arg-info arg))
 307                   (type (leaf-type arg)))
 308               (if info
 309                   (ecase (arg-info-kind info)
 310                     (:required (req type))
 311                     (:optional (opt type))
 312                     (:keyword
 313                      (keys (make-key-info :name (arg-info-key info)
 314                                           :type type)))
 315                     ((:rest :more-context)
 316                      (setq rest *universal-type*))
 317                     (:more-count))
 318                   (req type))))
 319
 320           (make-fun-type
 321            :required (req)
 322            :optional (opt)
 323            :rest rest
 324            :keywords (keys)
 325            :keyp (optional-dispatch-keyp functional)
 326            :allowp (optional-dispatch-allowp functional)
 327            :returns (tail-set-type
 328                      (lambda-tail-set
 329                       (optional-dispatch-main-entry functional))))))))
 330 \f
 331 ;;;; approximate function types
 332 ;;;;
 333 ;;;; FIXME: This is stuff to look at when I get around to fixing function
 334 ;;;; type inference and declarations.
 335 ;;;;
 336 ;;;; Approximate function types provide a condensed representation of all the
 337 ;;;; different ways that a function has been used. If we have no declared or
 338 ;;;; defined type for a function, then we build an approximate function type by
 339 ;;;; examining each use of the function. When we encounter a definition or
 340 ;;;; proclamation, we can check the actual type for compatibity with the
 341 ;;;; previous uses.
 342
 343 (defstruct (approximate-fun-type (:copier nil))
 344   ;; the smallest and largest numbers of arguments that this function
 345   ;; has been called with.
 346   (min-args sb!xc:call-arguments-limit
 347             :type (integer 0 #.sb!xc:call-arguments-limit))
 348   (max-args 0
 349             :type (integer 0 #.sb!xc:call-arguments-limit))
 350   ;; a list of lists of the all the types that have been used in each
 351   ;; argument position
 352   (types () :type list)
 353   ;; A list of APPROXIMATE-KEY-INFO structures describing all the
 354   ;; things that looked like &KEY arguments. There are distinct
 355   ;; structures describing each argument position in which the keyword
 356   ;; appeared.
 357   (keys () :type list))
 358
 359 (defstruct (approximate-key-info (:copier nil))
 360   ;; The keyword name of this argument. Although keyword names don't
 361   ;; have to be keywords, we only match on keywords when figuring an
 362   ;; approximate type.
 363   (name (missing-arg) :type keyword)
 364   ;; The position at which this keyword appeared. 0 if it appeared as the
 365   ;; first argument, etc.
 366   (position (missing-arg)
 367             :type (integer 0 #.sb!xc:call-arguments-limit))
 368   ;; a list of all the argument types that have been used with this keyword
 369   (types nil :type list)
 370   ;; true if this keyword has appeared only in calls with an obvious
 371   ;; :ALLOW-OTHER-KEYS
 372   (allowp nil :type (member t nil)))
 373
 374 ;;; Return an APPROXIMATE-FUN-TYPE representing the context of
 375 ;;; CALL. If TYPE is supplied and not null, then we merge the
 376 ;;; information into the information already accumulated in TYPE.
 377 (declaim (ftype (function (combination
 378                            &optional (or approximate-fun-type null))
 379                           approximate-fun-type)
 380                 note-fun-use))
 381 (defun note-fun-use (call &optional type)
 382   (let* ((type (or type (make-approximate-fun-type)))
 383          (types (approximate-fun-type-types type))
 384          (args (combination-args call))
 385          (nargs (length args))
 386          (allowp (some (lambda (x)
 387                          (and (constant-lvar-p x)
 388                               (eq (lvar-value x) :allow-other-keys)))
 389                        args)))
 390
 391     (setf (approximate-fun-type-min-args type)
 392           (min (approximate-fun-type-min-args type) nargs))
 393     (setf (approximate-fun-type-max-args type)
 394           (max (approximate-fun-type-max-args type) nargs))
 395
 396     (do ((old types (cdr old))
 397          (arg args (cdr arg)))
 398         ((null old)
 399          (setf (approximate-fun-type-types type)
 400                (nconc types
 401                       (mapcar (lambda (x)
 402                                 (list (lvar-type x)))
 403                               arg))))
 404       (when (null arg) (return))
 405       (pushnew (lvar-type (car arg))
 406                (car old)
 407                :test #'type=))
 408
 409     (collect ((keys (approximate-fun-type-keys type) cons))
 410       (do ((arg args (cdr arg))
 411            (pos 0 (1+ pos)))
 412           ((or (null arg) (null (cdr arg)))
 413            (setf (approximate-fun-type-keys type) (keys)))
 414         (let ((key (first arg))
 415               (val (second arg)))
 416           (when (constant-lvar-p key)
 417             (let ((name (lvar-value key)))
 418               (when (keywordp name)
 419                 (let ((old (find-if
 420                             (lambda (x)
 421                               (and (eq (approximate-key-info-name x) name)
 422                                    (= (approximate-key-info-position x)
 423                                       pos)))
 424                             (keys)))
 425                       (val-type (lvar-type val)))
 426                   (cond (old
 427                          (pushnew val-type
 428                                   (approximate-key-info-types old)
 429                                   :test #'type=)
 430                          (unless allowp
 431                            (setf (approximate-key-info-allowp old) nil)))
 432                         (t
 433                          (keys (make-approximate-key-info
 434                                 :name name
 435                                 :position pos
 436                                 :allowp allowp
 437                                 :types (list val-type))))))))))))
 438     type))
 439
 440 ;;; This is similar to VALID-FUN-USE, but checks an
 441 ;;; APPROXIMATE-FUN-TYPE against a real function type.
 442 (declaim (ftype (function (approximate-fun-type fun-type
 443                            &optional function function function)
 444                           (values boolean boolean))
 445                 valid-approximate-type))
 446 (defun valid-approximate-type (call-type type &optional
 447                                          (*ctype-test-fun*
 448                                           #'types-equal-or-intersect)
 449                                          (*lossage-fun*
 450                                           #'compiler-style-warn)
 451                                          (*unwinnage-fun* #'compiler-notify))
 452   (let* ((*lossage-detected* nil)
 453          (*unwinnage-detected* nil)
 454          (required (fun-type-required type))
 455          (min-args (length required))
 456          (optional (fun-type-optional type))
 457          (max-args (+ min-args (length optional)))
 458          (rest (fun-type-rest type))
 459          (keyp (fun-type-keyp type)))
 460
 461     (when (fun-type-wild-args type)
 462       (return-from valid-approximate-type (values t t)))
 463
 464     (let ((call-min (approximate-fun-type-min-args call-type)))
 465       (when (< call-min min-args)
 466         (note-lossage
 467          "~:@<The function was previously called with ~R argument~:P, ~
 468           but wants at least ~R.~:>"
 469          call-min min-args)))
 470
 471     (let ((call-max (approximate-fun-type-max-args call-type)))
 472       (cond ((<= call-max max-args))
 473             ((not (or keyp rest))
 474              (note-lossage
 475               "~:@<The function was previously called with ~R argument~:P, ~
 476                 but wants at most ~R.~:>"
 477               call-max max-args))
 478             ((and keyp (oddp (- call-max max-args)))
 479              (note-lossage
 480               "~:@<The function was previously called with an odd number of ~
 481                arguments in the keyword portion.~:>")))
 482
 483       (when (and keyp (> call-max max-args))
 484         (check-approximate-keywords call-type max-args type)))
 485
 486     (check-approximate-fixed-and-rest call-type (append required optional)
 487                                       rest)
 488
 489     (cond (*lossage-detected* (values nil t))
 490           (*unwinnage-detected* (values nil nil))
 491           (t (values t t)))))
 492
 493 ;;; Check that each of the types used at each arg position is
 494 ;;; compatible with the actual type.
 495 (declaim (ftype (function (approximate-fun-type list (or ctype null))
 496                           (values))
 497                 check-approximate-fixed-and-rest))
 498 (defun check-approximate-fixed-and-rest (call-type fixed rest)
 499   (do ((types (approximate-fun-type-types call-type) (cdr types))
 500        (n 1 (1+ n))
 501        (arg fixed (cdr arg)))
 502       ((null types))
 503     (let ((decl-type (or (car arg) rest)))
 504       (unless decl-type (return))
 505       (check-approximate-arg-type (car types) decl-type "~:R" n)))
 506   (values))
 507
 508 ;;; Check that each of the call-types is compatible with DECL-TYPE,
 509 ;;; complaining if not or if we can't tell.
 510 (declaim (ftype (function (list ctype string &rest t) (values))
 511                 check-approximate-arg-type))
 512 (defun check-approximate-arg-type (call-types decl-type context &rest args)
 513   (let ((losers *empty-type*))
 514     (dolist (ctype call-types)
 515       (multiple-value-bind (int win) (funcall *ctype-test-fun* ctype decl-type)
 516         (cond
 517          ((not win)
 518           (note-unwinnage "can't tell whether previous ~? ~
 519                            argument type ~S is a ~S"
 520                           context
 521                           args
 522                           (type-specifier ctype)
 523                           (type-specifier decl-type)))
 524          ((not int)
 525           (setq losers (type-union ctype losers))))))
 526
 527     (unless (eq losers *empty-type*)
 528       (note-lossage "~:(~?~) argument should be a ~S but was a ~S in a previous call."
 529                     context args (type-specifier decl-type) (type-specifier losers))))
 530   (values))
 531
 532 ;;; Check the types of each manifest keyword that appears in a keyword
 533 ;;; argument position. Check the validity of all keys that appeared in
 534 ;;; valid keyword positions.
 535 ;;;
 536 ;;; ### We could check the APPROXIMATE-FUN-TYPE-TYPES to make
 537 ;;; sure that all arguments in keyword positions were manifest
 538 ;;; keywords.
 539 (defun check-approximate-keywords (call-type max-args type)
 540   (let ((call-keys (approximate-fun-type-keys call-type))
 541         (keys (fun-type-keywords type)))
 542     (dolist (key keys)
 543       (let ((name (key-info-name key)))
 544         (collect ((types nil append))
 545           (dolist (call-key call-keys)
 546             (let ((pos (approximate-key-info-position call-key)))
 547               (when (and (eq (approximate-key-info-name call-key) name)
 548                          (> pos max-args) (evenp (- pos max-args)))
 549                 (types (approximate-key-info-types call-key)))))
 550           (check-approximate-arg-type (types) (key-info-type key) "~S" name))))
 551
 552     (unless (fun-type-allowp type)
 553       (collect ((names () adjoin))
 554         (dolist (call-key call-keys)
 555           (let ((pos (approximate-key-info-position call-key)))
 556             (when (and (> pos max-args) (evenp (- pos max-args))
 557                        (not (approximate-key-info-allowp call-key)))
 558               (names (approximate-key-info-name call-key)))))
 559
 560         (dolist (name (names))
 561           (unless (find name keys :key #'key-info-name)
 562             (note-lossage "Function previously called with unknown argument keyword ~S."
 563                   name)))))))
 564 \f
 565 ;;;; ASSERT-DEFINITION-TYPE
 566
 567 ;;; Intersect LAMBDA's var types with TYPES, giving a warning if there
 568 ;;; is a mismatch. If all intersections are non-null, we return lists
 569 ;;; of the variables and intersections, otherwise we return NIL, NIL.
 570 (defun try-type-intersections (vars types where)
 571   (declare (list vars types) (string where))
 572   (collect ((res))
 573     (mapc (lambda (var type)
 574             (let* ((vtype (leaf-type var))
 575                    (int (type-approx-intersection2 vtype type)))
 576               (cond
 577                ((eq int *empty-type*)
 578                 (note-lossage
 579                  "Definition's declared type for variable ~A:~%  ~S~@
 580                   conflicts with this type from ~A:~%  ~S"
 581                  (leaf-debug-name var) (type-specifier vtype)
 582                  where (type-specifier type))
 583                 (return-from try-type-intersections (values nil nil)))
 584                (t
 585                 (res int)))))
 586           vars types)
 587     (values vars (res))))
 588
 589 ;;; Check that the optional-dispatch OD conforms to TYPE. We return
 590 ;;; the values of TRY-TYPE-INTERSECTIONS if there are no syntax
 591 ;;; problems, otherwise NIL, NIL.
 592 ;;;
 593 ;;; Note that the variables in the returned list are the actual
 594 ;;; original variables (extracted from the optional dispatch arglist),
 595 ;;; rather than the variables that are arguments to the main entry.
 596 ;;; This difference is significant only for &KEY args with hairy
 597 ;;; defaults. Returning the actual vars allows us to use the right
 598 ;;; variable name in warnings.
 599 ;;;
 600 ;;; A slightly subtle point: with keywords and optionals, the type in
 601 ;;; the function type is only an assertion on calls --- it doesn't
 602 ;;; constrain the type of default values. So we have to union in the
 603 ;;; type of the default. With optionals, we can't do any assertion
 604 ;;; unless the default is constant.
 605 ;;;
 606 ;;; With keywords, we exploit our knowledge about how hairy keyword
 607 ;;; defaulting is done when computing the type assertion to put on the
 608 ;;; main-entry argument. In the case of hairy keywords, the default
 609 ;;; has been clobbered with NIL, which is the value of the main-entry
 610 ;;; arg in the unsupplied case, whatever the actual default value is.
 611 ;;; So we can just assume the default is constant, effectively
 612 ;;; unioning in NULL, and not totally blow off doing any type
 613 ;;; assertion.
 614 (defun find-optional-dispatch-types (od type where)
 615   (declare (type optional-dispatch od)
 616            (type fun-type type)
 617            (string where))
 618   (let* ((min (optional-dispatch-min-args od))
 619          (req (fun-type-required type))
 620          (opt (fun-type-optional type)))
 621     (flet ((frob (x y what)
 622              (unless (= x y)
 623                (note-lossage
 624                 "The definition has ~R ~A arg~P, but ~A has ~R."
 625                 x what x where y))))
 626       (frob min (length req) "fixed")
 627       (frob (- (optional-dispatch-max-args od) min) (length opt) "optional"))
 628     (flet ((frob (x y what)
 629              (unless (eq x y)
 630                (note-lossage
 631                 "The definition ~:[doesn't have~;has~] ~A, but ~
 632                  ~A ~:[doesn't~;does~]."
 633                 x what where y))))
 634       (frob (optional-dispatch-keyp od) (fun-type-keyp type)
 635             "&KEY arguments")
 636       (unless (optional-dispatch-keyp od)
 637         (frob (not (null (optional-dispatch-more-entry od)))
 638               (not (null (fun-type-rest type)))
 639               "&REST argument"))
 640       (frob (optional-dispatch-allowp od) (fun-type-allowp type)
 641             "&ALLOW-OTHER-KEYS"))
 642
 643     (when *lossage-detected*
 644       (return-from find-optional-dispatch-types (values nil nil)))
 645
 646     (collect ((res)
 647               (vars))
 648       (let ((keys (fun-type-keywords type))
 649             (arglist (optional-dispatch-arglist od)))
 650         (dolist (arg arglist)
 651           (cond
 652            ((lambda-var-arg-info arg)
 653             (let* ((info (lambda-var-arg-info arg))
 654                    (default (arg-info-default info))
 655                    (def-type (when (sb!xc:constantp default)
 656                                (ctype-of (constant-form-value default)))))
 657               (ecase (arg-info-kind info)
 658                 (:keyword
 659                  (let* ((key (arg-info-key info))
 660                         (kinfo (find key keys :key #'key-info-name)))
 661                    (cond
 662                     (kinfo
 663                      (res (type-union (key-info-type kinfo)
 664                                       (or def-type (specifier-type 'null)))))
 665                     (t
 666                      (note-lossage
 667                       "Defining a ~S keyword not present in ~A."
 668                       key where)
 669                      (res *universal-type*)))))
 670                 (:required (res (pop req)))
 671                 (:optional
 672                  (res (type-union (pop opt) (or def-type *universal-type*))))
 673                 (:rest
 674                  (when (fun-type-rest type)
 675                    (res (specifier-type 'list))))
 676                 (:more-context
 677                  (when (fun-type-rest type)
 678                    (res *universal-type*)))
 679                 (:more-count
 680                  (when (fun-type-rest type)
 681                    (res (specifier-type 'fixnum)))))
 682               (vars arg)
 683               (when (arg-info-supplied-p info)
 684                 (res *universal-type*)
 685                 (vars (arg-info-supplied-p info)))))
 686            (t
 687             (res (pop req))
 688             (vars arg))))
 689
 690         (dolist (key keys)
 691           (unless (find (key-info-name key) arglist
 692                         :key (lambda (x)
 693                                (let ((info (lambda-var-arg-info x)))
 694                                  (when info
 695                                    (arg-info-key info)))))
 696             (note-lossage
 697              "The definition lacks the ~S key present in ~A."
 698              (key-info-name key) where))))
 699
 700       (try-type-intersections (vars) (res) where))))
 701
 702 ;;; Check that TYPE doesn't specify any funny args, and do the
 703 ;;; intersection.
 704 (defun find-lambda-types (lambda type where)
 705   (declare (type clambda lambda) (type fun-type type) (string where))
 706   (flet ((frob (x what)
 707            (when x
 708              (note-lossage
 709               "The definition has no ~A, but the ~A did."
 710               what where))))
 711     (frob (fun-type-optional type) "&OPTIONAL arguments")
 712     (frob (fun-type-keyp type) "&KEY arguments")
 713     (frob (fun-type-rest type) "&REST argument"))
 714   (let* ((vars (lambda-vars lambda))
 715          (nvars (length vars))
 716          (req (fun-type-required type))
 717          (nreq (length req)))
 718     (unless (= nvars nreq)
 719       (note-lossage "The definition has ~R arg~:P, but the ~A has ~R."
 720                     nvars where nreq))
 721     (if *lossage-detected*
 722         (values nil nil)
 723         (try-type-intersections vars req where))))
 724
 725 ;;; Check for syntactic and type conformance between the definition
 726 ;;; FUNCTIONAL and the specified FUN-TYPE. If they are compatible
 727 ;;; and REALLY-ASSERT is T, then add type assertions to the definition
 728 ;;; from the FUN-TYPE.
 729 ;;;
 730 ;;; If there is a syntactic or type problem, then we call
 731 ;;; LOSSAGE-FUN with an error message using WHERE as context
 732 ;;; describing where FUN-TYPE came from.
 733 ;;;
 734 ;;; If there is no problem, we return T (even if REALLY-ASSERT was
 735 ;;; false). If there was a problem, we return NIL.
 736 (defun assert-definition-type
 737     (functional type &key (really-assert t)
 738      ((:lossage-fun *lossage-fun*)
 739       #'compiler-style-warn)
 740      unwinnage-fun
 741      (where "previous declaration"))
 742   (declare (type functional functional)
 743            (type function *lossage-fun*)
 744            (string where))
 745   (unless (fun-type-p type)
 746     (return-from assert-definition-type t))
 747   (let ((*lossage-detected* nil))
 748     (multiple-value-bind (vars types)
 749         (if (fun-type-wild-args type)
 750             (values nil nil)
 751             (etypecase functional
 752               (optional-dispatch
 753                (find-optional-dispatch-types functional type where))
 754               (clambda
 755                (find-lambda-types functional type where))))
 756       (let* ((type-returns (fun-type-returns type))
 757              (return (lambda-return (main-entry functional)))
 758              (dtype (when return
 759                       (lvar-derived-type (return-result return)))))
 760         (cond
 761           ((and dtype (not (values-types-equal-or-intersect dtype
 762                                                             type-returns)))
 763            (note-lossage
 764             "The result type from ~A:~%  ~S~@
 765              conflicts with the definition's result type:~%  ~S"
 766             where (type-specifier type-returns) (type-specifier dtype))
 767            nil)
 768           (*lossage-detected* nil)
 769           ((not really-assert) t)
 770           (t
 771            (let ((policy (lexenv-policy (functional-lexenv functional))))
 772              (when (policy policy (> type-check 0))
 773                (assert-lvar-type (return-result return) type-returns
 774                                  policy)))
 775            (loop for var in vars and type in types do
 776                  (cond ((basic-var-sets var)
 777                         (when (and unwinnage-fun
 778                                    (not (csubtypep (leaf-type var) type)))
 779                           (funcall unwinnage-fun
 780                                    "Assignment to argument: ~S~%  ~
 781                                     prevents use of assertion from function ~
 782                                     type ~A:~%  ~S~%"
 783                                    (leaf-debug-name var)
 784                                    where
 785                                    (type-specifier type))))
 786                        (t
 787                         (setf (leaf-type var) type)
 788                         (let ((s-type (make-single-value-type type)))
 789                           (dolist (ref (leaf-refs var))
 790                             (derive-node-type ref s-type))))))
 791            t))))))
 792
 793 ;;; FIXME: This is quite similar to ASSERT-NEW-DEFINITION.
 794 (defun assert-global-function-definition-type (name fun)
 795   (declare (type functional fun))
 796   (let ((type (info :function :type name))
 797         (where (info :function :where-from name)))
 798     (when (eq where :declared)
 799       (let ((type (massage-global-definition-type type fun)))
 800         (setf (leaf-type fun) type)
 801         (assert-definition-type
 802          fun type
 803          :unwinnage-fun #'compiler-notify
 804          :where "proclamation"
 805          :really-assert (not (awhen (info :function :info name)
 806                                (ir1-attributep (fun-info-attributes it)
 807                                                explicit-check))))))))
 808
 809 ;;; If the function has both &REST and &KEY, FIND-OPTIONAL-DISPATCH-TYPES
 810 ;;; doesn't complain about the type missing &REST -- which is good, because in
 811 ;;; that case &REST is really an implementation detail and not part of the
 812 ;;; interface. However since we set the leaf type missing &REST from there
 813 ;;; would be a bad thing -- to make up a new type if necessary.
 814 (defun massage-global-definition-type (type fun)
 815   (if (and (fun-type-p type)
 816            (optional-dispatch-p fun)
 817            (optional-dispatch-keyp fun)
 818            (optional-dispatch-more-entry fun)
 819            (not (or (fun-type-rest type)
 820                     (fun-type-wild-args type))))
 821       (make-fun-type :required (fun-type-required type)
 822                      :optional (fun-type-optional type)
 823                      :rest *universal-type*
 824                      :keyp (fun-type-keyp type)
 825                      :keywords (fun-type-keywords type)
 826                      :allowp (fun-type-allowp type)
 827                      :returns (fun-type-returns type))
 828       type))
 829 \f
 830 ;;; Call FUN with (arg-lvar arg-type)
 831 (defun map-combination-args-and-types (fun call)
 832   (declare (type function fun) (type combination call))
 833   (binding* ((type (lvar-type (combination-fun call)))
 834              (nil (fun-type-p type) :exit-if-null)
 835              (args (combination-args call)))
 836     (dolist (req (fun-type-required type))
 837       (when (null args) (return-from map-combination-args-and-types))
 838       (let ((arg (pop args)))
 839         (funcall fun arg req)))
 840     (dolist (opt (fun-type-optional type))
 841       (when (null args) (return-from map-combination-args-and-types))
 842       (let ((arg (pop args)))
 843         (funcall fun arg opt)))
 844
 845     (let ((rest (fun-type-rest type)))
 846       (when rest
 847         (dolist (arg args)
 848           (funcall fun arg rest))))
 849
 850     (dolist (key (fun-type-keywords type))
 851       (let ((name (key-info-name key)))
 852         (do ((arg args (cddr arg)))
 853             ((null arg))
 854           (let ((keyname (first arg)))
 855             (when (and (constant-lvar-p keyname)
 856                        (eq (lvar-value keyname) name))
 857               (funcall fun (second arg) (key-info-type key)))))))))
 858
 859 ;;; Assert that CALL is to a function of the specified TYPE. It is
 860 ;;; assumed that the call is legal and has only constants in the
 861 ;;; keyword positions.
 862 (defun assert-call-type (call type &optional (trusted t))
 863   (declare (type combination call) (type fun-type type))
 864   (let ((policy (lexenv-policy (node-lexenv call)))
 865         (returns (fun-type-returns type)))
 866     (if trusted
 867         (derive-node-type call returns)
 868         (let ((lvar (node-lvar call)))
 869           ;; If the value is used in a non-tail position, and the lvar
 870           ;; is a single-use, assert the type. Multiple use sites need
 871           ;; to be elided because the assertion has to apply to all
 872           ;; uses. Tail positions are elided because the assertion
 873           ;; would cause us not the be in a tail-position anymore. MV
 874           ;; calls are elided because not only are the assertions of
 875           ;; less use there, but they can cause the MV call conversion
 876           ;; to cause astray.
 877           (when (and lvar
 878                      (not (return-p (lvar-dest lvar)))
 879                      (not (mv-combination-p (lvar-dest lvar)))
 880                      (lvar-has-single-use-p lvar))
 881             (when (assert-lvar-type lvar returns policy)
 882               (reoptimize-lvar lvar)))))
 883     (map-combination-args-and-types
 884      (lambda (arg type)
 885        (when (assert-lvar-type arg type policy)
 886          (unless trusted (reoptimize-lvar arg))))
 887      call))
 888   (values))
 889 \f
 890 ;;;; FIXME: Move to some other file.
 891 (defun check-catch-tag-type (tag)
 892   (declare (type lvar tag))
 893   (let ((ctype (lvar-type tag)))
 894     (when (csubtypep ctype (specifier-type '(or number character)))
 895       (compiler-style-warn "~@<using ~S of type ~S as a catch tag (which ~
 896                             tends to be unportable because THROW and CATCH ~
 897                             use EQ comparison)~@:>"
 898                            (lvar-source tag)
 899                            (type-specifier (lvar-type tag))))))
 900
 901 (defun %compile-time-type-error (values atype dtype context)
 902   (declare (ignore dtype))
 903   (destructuring-bind (form . detail) context
 904     (if (and (consp atype) (eq (car atype) 'values))
 905         (error 'simple-type-error
 906                :datum (car values)
 907                :expected-type atype
 908                :format-control
 909                "~@<Value set ~2I~_[~{~S~^ ~}] ~I~_from ~S in ~2I~_~S ~I~_is ~
 910                    not of type ~2I~_~S.~:>"
 911                :format-arguments (list values
 912                                        detail form
 913                                        atype))
 914         (error 'simple-type-error
 915                :datum (car values)
 916                :expected-type atype
 917                :format-control "~@<Value of ~S in ~2I~_~S ~I~_is ~2I~_~S, ~
 918                                 ~I~_not a ~2I~_~S.~:@>"
 919                :format-arguments (list detail form
 920                                        (car values)
 921                                        atype)))))
 922
 923 (defoptimizer (%compile-time-type-error ir2-convert)
 924     ((objects atype dtype context) node block)
 925   (let ((*compiler-error-context* node))
 926     (setf (node-source-path node)
 927           (cdr (node-source-path node)))
 928     (destructuring-bind (values atype dtype context)
 929         (basic-combination-args node)
 930       (declare (ignore values))
 931       (let ((atype (lvar-value atype))
 932             (dtype (lvar-value dtype))
 933             (detail (cdr (lvar-value context))))
 934         (unless (eq atype nil)
 935           (if (constantp detail)
 936               (warn 'type-warning
 937                  :format-control
 938                  "~@<Constant ~2I~_~S ~Iconflicts with its asserted type ~
 939                      ~2I~_~S.~@:>"
 940                  :format-arguments (list (eval detail) atype))
 941               (warn 'type-warning
 942                  :format-control
 943                  "~@<Derived type of ~S is ~2I~_~S, ~I~_conflicting with ~
 944                      its asserted type ~2I~_~S.~@:>"
 945                  :format-arguments (list detail dtype atype))))))
 946     (ir2-convert-full-call node block)))