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