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