X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fctype.lisp;h=97923ac7d42e6d7b8bc1189fc3f2a24c8e59b8eb;hb=7ce2c42adf3d62f03086de940adaee48e6161a40;hp=f0948499a64f1d0ac85239f9daddd76a2fa896c5;hpb=1d941f3d8f343f5779526b66b2358b4893a17281;p=sbcl.git diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp index f094849..97923ac 100644 --- a/src/compiler/ctype.lisp +++ b/src/compiler/ctype.lisp @@ -18,35 +18,30 @@ (in-package "SB!C") +(declaim (type (or function null) *lossage-fun* *unwinnage-fun* *ctype-test-fun*)) + ;;; These are the functions that are to be called when a problem is ;;; detected. They are passed format arguments. If null, we don't do -;;; anything. The error function is called when something is -;;; definitely incorrect. The warning function is called when it is -;;; somehow impossible to tell whether the call is correct. -;;; -;;; FIXME: *ERROR-FUNCTION* and *WARNING-FUNCTION* are now misnomers. -;;; As per the KLUDGE note below, what the Python compiler -;;; considered a "definite incompatibility" could easily be conforming -;;; ANSI Common Lisp (if the incompatibility is across a compilation -;;; unit boundary, and we don't keep track of whether it is..), so we -;;; have to just report STYLE-WARNINGs instead of ERRORs or full -;;; WARNINGs; and unlike CMU CL, we don't use the condition system -;;; at all when we're reporting notes. -(defvar *error-function*) -(defvar *warning-function*) - -;;; The function that we use for type checking. The derived type is -;;; the first argument and the type we are testing against is the +;;; anything. The LOSSAGE function is called when something is +;;; definitely incorrect. The UNWINNAGE function is called when it is +;;; somehow impossible to tell whether the call is correct. (Thus, +;;; they should correspond fairly closely to the FAILURE-P and WARNINGS-P +;;; return values of CL:COMPILE and CL:COMPILE-FILE. However, see the +;;; KLUDGE note below for *LOSSAGE-DETECTED*.) +(defvar *lossage-fun*) +(defvar *unwinnage-fun*) + +;;; the function that we use for type checking. The derived type is +;;; its first argument and the type we are testing against is its ;;; second argument. The function should return values like CSUBTYPEP. -(defvar *test-function*) +(defvar *ctype-test-fun*) ;;; FIXME: Why is this a variable? Explain. -(declaim (type (or function null) *error-function* *warning-function - *test-function*)) - ;;; *LOSSAGE-DETECTED* is set when a "definite incompatibility" is -;;; detected. *SLIME-DETECTED* is set when we can't tell whether the -;;; call is compatible or not. +;;; detected. *UNWINNAGE-DETECTED* is set when we can't tell whether the +;;; call is compatible or not. Thus, they should correspond very closely +;;; to the FAILURE-P and WARNINGS-P return values of CL:COMPILE and +;;; CL:COMPILE-FILE.) However... ;;; ;;; KLUDGE: Common Lisp is a dynamic language, even if CMU CL was not. ;;; As far as I can see, none of the "definite incompatibilities" @@ -58,21 +53,19 @@ ;;; upgrade the code to keep track of that, we have to handle all ;;; these as STYLE-WARNINGs. -- WHN 2001-02-10 (defvar *lossage-detected*) -(defvar *slime-detected*) -;;; FIXME: "SLIME" is vivid and concise, but "DEFINITE-CALL-LOSSAGE" and -;;; "POSSIBLE-CALL-LOSSAGE" would be more mnemonic. +(defvar *unwinnage-detected*) -;;; Signal a warning if appropriate and set *LOSSAGE-DETECTED*. -(declaim (ftype (function (string &rest t) (values)) note-lossage note-slime)) +;;; Signal a warning if appropriate and set *FOO-DETECTED*. +(declaim (ftype (function (string &rest t) (values)) note-lossage note-unwinnage)) (defun note-lossage (format-string &rest format-args) (setq *lossage-detected* t) - (when *error-function* - (apply *error-function* format-string format-args)) + (when *lossage-fun* + (apply *lossage-fun* format-string format-args)) (values)) -(defun note-slime (format-string &rest format-args) - (setq *slime-detected* t) - (when *warning-function* - (apply *warning-function* format-string format-args)) +(defun note-unwinnage (format-string &rest format-args) + (setq *unwinnage-detected* t) + (when *unwinnage-fun* + (apply *unwinnage-fun* format-string format-args)) (values)) (declaim (special *compiler-error-context*)) @@ -109,28 +102,28 @@ ;;; explain the result. We bind *COMPILER-ERROR-CONTEXT* to the ;;; combination node so that COMPILER-WARNING and related functions ;;; will do the right thing if they are supplied. -(defun valid-function-use (call type &key - ((:argument-test *test-function*) #'csubtypep) - (result-test #'values-subtypep) - (strict-result nil) - ((:error-function *error-function*)) - ((:warning-function *warning-function*))) +(defun valid-fun-use (call type &key + ((:argument-test *ctype-test-fun*) #'csubtypep) + (result-test #'values-subtypep) + (strict-result nil) + ((:lossage-fun *lossage-fun*)) + ((:unwinnage-fun *unwinnage-fun*))) (declare (type function result-test) (type combination call) - (type function-type type)) + (type fun-type type)) (let* ((*lossage-detected* nil) - (*slime-detected* nil) + (*unwinnage-detected* nil) (*compiler-error-context* call) (args (combination-args call)) (nargs (length args)) - (required (function-type-required type)) + (required (fun-type-required type)) (min-args (length required)) - (optional (function-type-optional type)) + (optional (fun-type-optional type)) (max-args (+ min-args (length optional))) - (rest (function-type-rest type)) - (keyp (function-type-keyp type))) + (rest (fun-type-rest type)) + (keyp (fun-type-keyp type))) (cond - ((function-type-wild-args type) + ((fun-type-wild-args type) (do ((i 1 (1+ i)) (arg args (cdr arg))) ((null arg)) @@ -157,10 +150,10 @@ (t (check-fixed-and-rest args (append required optional) rest) (when keyp - (check-keywords args max-args type)))) + (check-key-args args max-args type)))) (let* ((dtype (node-derived-type call)) - (return-type (function-type-returns type)) + (return-type (fun-type-returns type)) (cont (node-cont call)) (out-type (if (or (not (continuation-type-check cont)) @@ -170,15 +163,15 @@ dtype)))) (multiple-value-bind (int win) (funcall result-test out-type return-type) (cond ((not win) - (note-slime "can't tell whether the result is a ~S" - (type-specifier return-type))) + (note-unwinnage "can't tell whether the result is a ~S" + (type-specifier return-type))) ((not int) (note-lossage "The result is a ~S, not a ~S." (type-specifier out-type) (type-specifier return-type)))))) (cond (*lossage-detected* (values nil t)) - (*slime-detected* (values nil nil)) + (*unwinnage-detected* (values nil nil)) (t (values t t))))) ;;; Check that the derived type of the continuation CONT is compatible @@ -193,31 +186,30 @@ (cond ((not (constant-type-p type)) (let ((ctype (continuation-type cont))) - (multiple-value-bind (int win) (funcall *test-function* ctype type) + (multiple-value-bind (int win) (funcall *ctype-test-fun* ctype type) (cond ((not win) - (note-slime "can't tell whether the ~:R argument is a ~S" n - (type-specifier type)) + (note-unwinnage "can't tell whether the ~:R argument is a ~S" + n (type-specifier type)) nil) ((not int) - (note-lossage "The ~:R argument is a ~S, not a ~S." n - (type-specifier ctype) - (type-specifier type)) + (note-lossage "The ~:R argument is a ~S, not a ~S." + n (type-specifier ctype) (type-specifier type)) nil) ((eq ctype *empty-type*) - (note-slime "The ~:R argument never returns a value." n) + (note-unwinnage "The ~:R argument never returns a value." n) nil) (t t))))) ((not (constant-continuation-p cont)) - (note-slime "The ~:R argument is not a constant." n) + (note-unwinnage "The ~:R argument is not a constant." n) nil) (t (let ((val (continuation-value cont)) (type (constant-type-type type))) (multiple-value-bind (res win) (ctypep val type) (cond ((not win) - (note-slime "can't tell whether the ~:R argument is a ~ - constant ~S:~% ~S" - n (type-specifier type) val) + (note-unwinnage "can't tell whether the ~:R argument is a ~ + constant ~S:~% ~S" + n (type-specifier type) val) nil) ((not res) (note-lossage "The ~:R argument is not a constant ~S:~% ~S" @@ -227,7 +219,7 @@ ;;; Check that each of the type of each supplied argument intersects ;;; with the type specified for that argument. If we can't tell, then -;;; we complain about the slime. +;;; we can complain about the absence of manifest winnage. (declaim (ftype (function (list list (or ctype null)) (values)) check-fixed-and-rest)) (defun check-fixed-and-rest (args types rest) (do ((arg args (cdr arg)) @@ -242,12 +234,12 @@ (check-arg-type (car arg) (car type) n)) (values)) -;;; Check that the keyword args are of the correct type. Each keyword -;;; should be known and the corresponding argument should be of the -;;; correct type. If the keyword isn't a constant, then we can't tell, -;;; so we note slime. -(declaim (ftype (function (list fixnum function-type) (values)) check-keywords)) -(defun check-keywords (args pre-key type) +;;; Check that the &KEY args are of the correct type. Each key should +;;; be known and the corresponding argument should be of the correct +;;; type. If the key isn't a constant, then we can't tell, so we can +;;; complain about absence of manifest winnage. +(declaim (ftype (function (list fixnum fun-type) (values)) check-key-args)) +(defun check-key-args (args pre-key type) (do ((key (nthcdr pre-key args) (cddr key)) (n (1+ pre-key) (+ n 2))) ((null key)) @@ -256,14 +248,15 @@ (cond ((not (check-arg-type k (specifier-type 'symbol) n))) ((not (constant-continuation-p k)) - (note-slime "The ~:R argument (in keyword position) is not a constant." - n)) + (note-unwinnage "The ~:R argument (in keyword position) is not a ~ + constant." + n)) (t (let* ((name (continuation-value k)) - (info (find name (function-type-keywords type) + (info (find name (fun-type-keywords type) :key #'key-info-name))) (cond ((not info) - (unless (function-type-allowp type) + (unless (fun-type-allowp type) (note-lossage "~S is not a known argument keyword." name))) (t @@ -275,10 +268,10 @@ ;;; ;;; Due to the lack of a (LIST X) type specifier, we can't reconstruct ;;; the &REST type. -(declaim (ftype (function (functional) function-type) definition-type)) +(declaim (ftype (function (functional) fun-type) definition-type)) (defun definition-type (functional) (if (lambda-p functional) - (make-function-type + (make-fun-type :required (mapcar #'leaf-type (lambda-vars functional)) :returns (tail-set-type (lambda-tail-set functional))) (let ((rest nil)) @@ -293,14 +286,14 @@ (:required (req type)) (:optional (opt type)) (:keyword - (keys (make-key-info :name (arg-info-keyword info) + (keys (make-key-info :name (arg-info-key info) :type type))) ((:rest :more-context) (setq rest *universal-type*)) (:more-count)) (req type)))) - (make-function-type + (make-fun-type :required (req) :optional (opt) :rest rest @@ -323,82 +316,84 @@ ;;;; proclamation, we can check the actual type for compatibity with the ;;;; previous uses. -(defstruct (approximate-function-type) - ;; The smallest and largest numbers of arguments that this function has been - ;; called with. - (min-args call-arguments-limit :type fixnum) +(defstruct (approximate-fun-type (:copier nil)) + ;; the smallest and largest numbers of arguments that this function + ;; has been called with. + (min-args sb!xc:call-arguments-limit :type fixnum) (max-args 0 :type fixnum) - ;; A list of lists of the all the types that have been used in each argument - ;; position. + ;; a list of lists of the all the types that have been used in each + ;; argument position (types () :type list) - ;; A list of the Approximate-Key-Info structures describing all the things - ;; that looked like keyword arguments. There are distinct structures - ;; describing each argument position in which the keyword appeared. + ;; A list of APPROXIMATE-KEY-INFO structures describing all the + ;; things that looked like &KEY arguments. There are distinct + ;; structures describing each argument position in which the keyword + ;; appeared. (keys () :type list)) -(defstruct (approximate-key-info) - ;; The keyword name of this argument. Although keyword names don't have to - ;; be keywords, we only match on keywords when figuring an approximate type. - (name (required-argument) :type keyword) +(defstruct (approximate-key-info (:copier nil)) + ;; The keyword name of this argument. Although keyword names don't + ;; have to be keywords, we only match on keywords when figuring an + ;; approximate type. + (name (missing-arg) :type keyword) ;; The position at which this keyword appeared. 0 if it appeared as the ;; first argument, etc. - (position (required-argument) :type fixnum) - ;; A list of all the argument types that have been used with this keyword. + (position (missing-arg) :type fixnum) + ;; a list of all the argument types that have been used with this keyword (types nil :type list) - ;; True if this keyword has appeared only in calls with an obvious - ;; :allow-other-keys. + ;; true if this keyword has appeared only in calls with an obvious + ;; :ALLOW-OTHER-KEYS (allowp nil :type (member t nil))) -;;; Return an APPROXIMATE-FUNCTION-TYPE representing the context of +;;; Return an APPROXIMATE-FUN-TYPE representing the context of ;;; CALL. If TYPE is supplied and not null, then we merge the ;;; information into the information already accumulated in TYPE. (declaim (ftype (function (combination - &optional (or approximate-function-type null)) - approximate-function-type) - note-function-use)) -(defun note-function-use (call &optional type) - (let* ((type (or type (make-approximate-function-type))) - (types (approximate-function-type-types type)) + &optional (or approximate-fun-type null)) + approximate-fun-type) + note-fun-use)) +(defun note-fun-use (call &optional type) + (let* ((type (or type (make-approximate-fun-type))) + (types (approximate-fun-type-types type)) (args (combination-args call)) (nargs (length args)) - (allowp (some #'(lambda (x) - (and (constant-continuation-p x) - (eq (continuation-value x) :allow-other-keys))) - args))) + (allowp (some (lambda (x) + (and (constant-continuation-p x) + (eq (continuation-value x) :allow-other-keys))) + args))) - (setf (approximate-function-type-min-args type) - (min (approximate-function-type-min-args type) nargs)) - (setf (approximate-function-type-max-args type) - (max (approximate-function-type-max-args type) nargs)) + (setf (approximate-fun-type-min-args type) + (min (approximate-fun-type-min-args type) nargs)) + (setf (approximate-fun-type-max-args type) + (max (approximate-fun-type-max-args type) nargs)) (do ((old types (cdr old)) (arg args (cdr arg))) ((null old) - (setf (approximate-function-type-types type) + (setf (approximate-fun-type-types type) (nconc types - (mapcar #'(lambda (x) - (list (continuation-type x))) + (mapcar (lambda (x) + (list (continuation-type x))) arg)))) (when (null arg) (return)) (pushnew (continuation-type (car arg)) (car old) :test #'type=)) - (collect ((keys (approximate-function-type-keys type) cons)) + (collect ((keys (approximate-fun-type-keys type) cons)) (do ((arg args (cdr arg)) (pos 0 (1+ pos))) ((or (null arg) (null (cdr arg))) - (setf (approximate-function-type-keys type) (keys))) + (setf (approximate-fun-type-keys type) (keys))) (let ((key (first arg)) (val (second arg))) (when (constant-continuation-p key) (let ((name (continuation-value key))) (when (keywordp name) (let ((old (find-if - #'(lambda (x) - (and (eq (approximate-key-info-name x) name) - (= (approximate-key-info-position x) - pos))) + (lambda (x) + (and (eq (approximate-key-info-name x) name) + (= (approximate-key-info-position x) + pos))) (keys))) (val-type (continuation-type val))) (cond (old @@ -416,36 +411,37 @@ type)) ;;; This is similar to VALID-FUNCTION-USE, but checks an -;;; APPROXIMATE-FUNCTION-TYPE against a real function type. -(declaim (ftype (function (approximate-function-type function-type +;;; APPROXIMATE-FUN-TYPE against a real function type. +(declaim (ftype (function (approximate-fun-type fun-type &optional function function function) (values boolean boolean)) valid-approximate-type)) (defun valid-approximate-type (call-type type &optional - (*test-function* #'types-intersect) - (*error-function* - #'compiler-style-warning) - (*warning-function* #'compiler-note)) + (*ctype-test-fun* + #'types-equal-or-intersect) + (*lossage-fun* + #'compiler-style-warn) + (*unwinnage-fun* #'compiler-note)) (let* ((*lossage-detected* nil) - (*slime-detected* nil) - (required (function-type-required type)) + (*unwinnage-detected* nil) + (required (fun-type-required type)) (min-args (length required)) - (optional (function-type-optional type)) + (optional (fun-type-optional type)) (max-args (+ min-args (length optional))) - (rest (function-type-rest type)) - (keyp (function-type-keyp type))) + (rest (fun-type-rest type)) + (keyp (fun-type-keyp type))) - (when (function-type-wild-args type) + (when (fun-type-wild-args type) (return-from valid-approximate-type (values t t))) - (let ((call-min (approximate-function-type-min-args call-type))) + (let ((call-min (approximate-fun-type-min-args call-type))) (when (< call-min min-args) (note-lossage "~:@" call-min min-args))) - (let ((call-max (approximate-function-type-max-args call-type))) + (let ((call-max (approximate-fun-type-max-args call-type))) (cond ((<= call-max max-args)) ((not (or keyp rest)) (note-lossage @@ -464,16 +460,16 @@ rest) (cond (*lossage-detected* (values nil t)) - (*slime-detected* (values nil nil)) + (*unwinnage-detected* (values nil nil)) (t (values t t))))) ;;; Check that each of the types used at each arg position is ;;; compatible with the actual type. -(declaim (ftype (function (approximate-function-type list (or ctype null)) +(declaim (ftype (function (approximate-fun-type list (or ctype null)) (values)) check-approximate-fixed-and-rest)) (defun check-approximate-fixed-and-rest (call-type fixed rest) - (do ((types (approximate-function-type-types call-type) (cdr types)) + (do ((types (approximate-fun-type-types call-type) (cdr types)) (n 1 (1+ n)) (arg fixed (cdr arg))) ((null types)) @@ -489,11 +485,15 @@ (defun check-approximate-arg-type (call-types decl-type context &rest args) (let ((losers *empty-type*)) (dolist (ctype call-types) - (multiple-value-bind (int win) (funcall *test-function* ctype decl-type) + (multiple-value-bind (int win) (funcall *ctype-test-fun* ctype decl-type) (cond ((not win) - (note-slime "can't tell whether previous ~? argument type ~S is a ~S" - context args (type-specifier ctype) (type-specifier decl-type))) + (note-unwinnage "can't tell whether previous ~? ~ + argument type ~S is a ~S" + context + args + (type-specifier ctype) + (type-specifier decl-type))) ((not int) (setq losers (type-union ctype losers)))))) @@ -506,12 +506,12 @@ ;;; argument position. Check the validity of all keys that appeared in ;;; valid keyword positions. ;;; -;;; ### We could check the APPROXIMATE-FUNCTION-TYPE-TYPES to make +;;; ### We could check the APPROXIMATE-FUN-TYPE-TYPES to make ;;; sure that all arguments in keyword positions were manifest ;;; keywords. (defun check-approximate-keywords (call-type max-args type) - (let ((call-keys (approximate-function-type-keys call-type)) - (keys (function-type-keywords type))) + (let ((call-keys (approximate-fun-type-keys call-type)) + (keys (fun-type-keywords type))) (dolist (key keys) (let ((name (key-info-name key))) (collect ((types nil append)) @@ -522,7 +522,7 @@ (types (approximate-key-info-types call-key))))) (check-approximate-arg-type (types) (key-info-type key) "~S" name)))) - (unless (function-type-allowp type) + (unless (fun-type-allowp type) (collect ((names () adjoin)) (dolist (call-key call-keys) (let ((pos (approximate-key-info-position call-key))) @@ -543,19 +543,19 @@ (defun try-type-intersections (vars types where) (declare (list vars types) (string where)) (collect ((res)) - (mapc #'(lambda (var type) - (let* ((vtype (leaf-type var)) - (int (type-intersection vtype type))) - (cond - ((eq int *empty-type*) - (note-lossage - "Definition's declared type for variable ~A:~% ~S~@ - conflicts with this type from ~A:~% ~S" - (leaf-name var) (type-specifier vtype) - where (type-specifier type)) - (return-from try-type-intersections (values nil nil))) - (t - (res int))))) + (mapc (lambda (var type) + (let* ((vtype (leaf-type var)) + (int (type-approx-intersection2 vtype type))) + (cond + ((eq int *empty-type*) + (note-lossage + "Definition's declared type for variable ~A:~% ~S~@ + conflicts with this type from ~A:~% ~S" + (leaf-debug-name var) (type-specifier vtype) + where (type-specifier type)) + (return-from try-type-intersections (values nil nil))) + (t + (res int))))) vars types) (values vars (res)))) @@ -566,7 +566,7 @@ ;;; Note that the variables in the returned list are the actual ;;; original variables (extracted from the optional dispatch arglist), ;;; rather than the variables that are arguments to the main entry. -;;; This difference is significant only for keyword args with hairy +;;; This difference is significant only for &KEY args with hairy ;;; defaults. Returning the actual vars allows us to use the right ;;; variable name in warnings. ;;; @@ -585,39 +585,40 @@ ;;; unioning in NULL, and not totally blow off doing any type ;;; assertion. (defun find-optional-dispatch-types (od type where) - (declare (type optional-dispatch od) (type function-type type) + (declare (type optional-dispatch od) + (type fun-type type) (string where)) (let* ((min (optional-dispatch-min-args od)) - (req (function-type-required type)) - (opt (function-type-optional type))) + (req (fun-type-required type)) + (opt (fun-type-optional type))) (flet ((frob (x y what) (unless (= x y) (note-lossage - "Definition has ~R ~A arg~P, but ~A has ~R." + "The definition has ~R ~A arg~P, but ~A has ~R." x what x where y)))) (frob min (length req) "fixed") (frob (- (optional-dispatch-max-args od) min) (length opt) "optional")) (flet ((frob (x y what) (unless (eq x y) (note-lossage - "Definition ~:[doesn't have~;has~] ~A, but ~ + "The definition ~:[doesn't have~;has~] ~A, but ~ ~A ~:[doesn't~;does~]." x what where y)))) - (frob (optional-dispatch-keyp od) (function-type-keyp type) - "keyword args") + (frob (optional-dispatch-keyp od) (fun-type-keyp type) + "&KEY arguments") (unless (optional-dispatch-keyp od) (frob (not (null (optional-dispatch-more-entry od))) - (not (null (function-type-rest type))) - "rest args")) - (frob (optional-dispatch-allowp od) (function-type-allowp type) - "&allow-other-keys")) + (not (null (fun-type-rest type))) + "&REST arguments")) + (frob (optional-dispatch-allowp od) (fun-type-allowp type) + "&ALLOW-OTHER-KEYS")) (when *lossage-detected* (return-from find-optional-dispatch-types (values nil nil))) (collect ((res) (vars)) - (let ((keys (function-type-keywords type)) + (let ((keys (fun-type-keywords type)) (arglist (optional-dispatch-arglist od))) (dolist (arg arglist) (cond @@ -628,7 +629,7 @@ (ctype-of (eval default))))) (ecase (arg-info-kind info) (:keyword - (let* ((key (arg-info-keyword info)) + (let* ((key (arg-info-key info)) (kinfo (find key keys :key #'key-info-name))) (cond (kinfo @@ -643,13 +644,13 @@ (:optional (res (type-union (pop opt) (or def-type *universal-type*)))) (:rest - (when (function-type-rest type) + (when (fun-type-rest type) (res (specifier-type 'list)))) (:more-context - (when (function-type-rest type) + (when (fun-type-rest type) (res *universal-type*))) (:more-count - (when (function-type-rest type) + (when (fun-type-rest type) (res (specifier-type 'fixnum))))) (vars arg) (when (arg-info-supplied-p info) @@ -661,31 +662,31 @@ (dolist (key keys) (unless (find (key-info-name key) arglist - :key #'(lambda (x) - (let ((info (lambda-var-arg-info x))) - (when info - (arg-info-keyword info))))) + :key (lambda (x) + (let ((info (lambda-var-arg-info x))) + (when info + (arg-info-key info))))) (note-lossage - "The definition lacks the ~S keyword present in ~A." + "The definition lacks the ~S key present in ~A." (key-info-name key) where)))) (try-type-intersections (vars) (res) where)))) -;;; Check that Type doesn't specify any funny args, and do the +;;; Check that TYPE doesn't specify any funny args, and do the ;;; intersection. (defun find-lambda-types (lambda type where) - (declare (type clambda lambda) (type function-type type) (string where)) + (declare (type clambda lambda) (type fun-type type) (string where)) (flet ((frob (x what) (when x (note-lossage "The definition has no ~A, but the ~A did." what where)))) - (frob (function-type-optional type) "optional args") - (frob (function-type-keyp type) "keyword args") - (frob (function-type-rest type) "rest arg")) + (frob (fun-type-optional type) "&OPTIONAL arguments") + (frob (fun-type-keyp type) "&KEY arguments") + (frob (fun-type-rest type) "&REST argument")) (let* ((vars (lambda-vars lambda)) (nvars (length vars)) - (req (function-type-required type)) + (req (fun-type-required type)) (nreq (length req))) (unless (= nvars nreq) (note-lossage "The definition has ~R arg~:P, but the ~A has ~R." @@ -695,41 +696,43 @@ (try-type-intersections vars req where)))) ;;; Check for syntactic and type conformance between the definition -;;; FUNCTIONAL and the specified FUNCTION-TYPE. If they are compatible +;;; FUNCTIONAL and the specified FUN-TYPE. If they are compatible ;;; and REALLY-ASSERT is T, then add type assertions to the definition -;;; from the FUNCTION-TYPE. +;;; from the FUN-TYPE. ;;; ;;; If there is a syntactic or type problem, then we call -;;; ERROR-FUNCTION with an error message using WHERE as context -;;; describing where FUNCTION-TYPE came from. +;;; LOSSAGE-FUN with an error message using WHERE as context +;;; describing where FUN-TYPE came from. ;;; ;;; If there is no problem, we return T (even if REALLY-ASSERT was ;;; false). If there was a problem, we return NIL. (defun assert-definition-type (functional type &key (really-assert t) - ((:error-function *error-function*) - #'compiler-style-warning) - warning-function + ((:lossage-fun *lossage-fun*) + #'compiler-style-warn) + unwinnage-fun (where "previous declaration")) (declare (type functional functional) - (type function *error-function*) + (type function *lossage-fun*) (string where)) - (unless (function-type-p type) (return-from assert-definition-type t)) + (unless (fun-type-p type) + (return-from assert-definition-type t)) (let ((*lossage-detected* nil)) (multiple-value-bind (vars types) - (if (function-type-wild-args type) + (if (fun-type-wild-args type) (values nil nil) (etypecase functional (optional-dispatch (find-optional-dispatch-types functional type where)) (clambda (find-lambda-types functional type where)))) - (let* ((type-returns (function-type-returns type)) + (let* ((type-returns (fun-type-returns type)) (return (lambda-return (main-entry functional))) (atype (when return (continuation-asserted-type (return-result return))))) (cond - ((and atype (not (values-types-intersect atype type-returns))) + ((and atype (not (values-types-equal-or-intersect atype + type-returns))) (note-lossage "The result type from ~A:~% ~S~@ conflicts with the definition's result type assertion:~% ~S" @@ -739,18 +742,42 @@ ((not really-assert) t) (t (when atype - (assert-continuation-type (return-result return) atype)) + (assert-continuation-type (return-result return) atype + (lexenv-policy (functional-lexenv functional)))) (loop for var in vars and type in types do (cond ((basic-var-sets var) - (when (and warning-function + (when (and unwinnage-fun (not (csubtypep (leaf-type var) type))) - (funcall warning-function + (funcall unwinnage-fun "Assignment to argument: ~S~% ~ prevents use of assertion from function ~ type ~A:~% ~S~%" - (leaf-name var) where (type-specifier type)))) + (leaf-debug-name var) + where + (type-specifier type)))) (t (setf (leaf-type var) type) (dolist (ref (leaf-refs var)) (derive-node-type ref type))))) t)))))) + +(defun assert-global-function-definition-type (name fun) + (declare (type functional fun)) + (let ((type (info :function :type name)) + (where (info :function :where-from name))) + (when (eq where :declared) + (setf (leaf-type fun) type) + (assert-definition-type fun type + :unwinnage-fun #'compiler-note + :where "proclamation")))) + +;;;; FIXME: Move to some other file. +(defun check-catch-tag-type (tag) + (declare (type continuation tag)) + (let ((ctype (continuation-type tag))) + (when (csubtypep ctype (specifier-type '(or number character))) + (compiler-style-warn "~@" + (continuation-source tag) + (type-specifier (continuation-type tag))))))