X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fctype.lisp;h=948c0df4b95c761d109781195a1a8e98e7391f9f;hb=31361af9eb64344f521abbb245ea784c76c746e5;hp=b9bd2c475061b6f70a0b6dfaa46f2ec41ff8e3bf;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp index b9bd2c4..948c0df 100644 --- a/src/compiler/ctype.lisp +++ b/src/compiler/ctype.lisp @@ -11,6 +11,11 @@ ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. +;;;; FIXME: This is a poor name for this file, since CTYPE is the name +;;;; of the type used internally to represent Lisp types. It'd +;;;; probably be good to rename this file to "call-type.lisp" or +;;;; "ir1-type.lisp" or something. + (in-package "SB!C") ;;; These are the functions that are to be called when a problem is @@ -18,6 +23,15 @@ ;;; 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*) @@ -30,12 +44,22 @@ (declaim (type (or function null) *error-function* *warning-function *test-function*)) -;;; *LOSSAGE-DETECTED* is set when a definite incompatibility is +;;; *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. +;;; +;;; KLUDGE: Common Lisp is a dynamic language, even if CMU CL was not. +;;; As far as I can see, none of the "definite incompatibilities" +;;; detected in this file are actually definite under the ANSI spec. +;;; They would be incompatibilites if the use were within the same +;;; compilation unit as the contradictory definition (as per the spec +;;; section "3.2.2.3 Semantic Constraints") but the old Python code +;;; doesn't keep track of whether that's the case. So until/unless we +;;; 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 +;;; FIXME: "SLIME" is vivid and concise, but "DEFINITE-CALL-LOSSAGE" and ;;; "POSSIBLE-CALL-LOSSAGE" would be more mnemonic. ;;; Signal a warning if appropriate and set *LOSSAGE-DETECTED*. @@ -59,7 +83,7 @@ ;;;; function type inference and declarations. ;;; A dummy version of SUBTYPEP useful when we want a functional like -;;; subtypep that always returns true. +;;; SUBTYPEP that always returns true. (defun always-subtypep (type1 type2) (declare (ignore type1 type2)) (values t t)) @@ -70,20 +94,20 @@ ;;; NIL, T: the call is definitely invalid. ;;; NIL, NIL: unable to determine whether the call is valid. ;;; -;;; The Argument-Test function is used to determine whether an +;;; The ARGUMENT-TEST function is used to determine whether an ;;; argument type matches the type we are checking against. Similarly, -;;; the Result-Test is used to determine whether the result type +;;; the RESULT-TEST is used to determine whether the result type ;;; matches the specified result. ;;; ;;; Unlike the argument test, the result test may be called on values -;;; or function types. If Strict-Result is true and safety is -;;; non-zero, then the Node-Derived-Type is always used. Otherwise, if -;;; Cont's Type-Check is true, then the Node-Derived-Type is -;;; intersected with the Cont's Asserted-Type. +;;; or function types. If STRICT-RESULT is true and SAFETY is +;;; non-zero, then the NODE-DERIVED-TYPE is always used. Otherwise, if +;;; CONT's TYPE-CHECK is true, then the NODE-DERIVED-TYPE is +;;; intersected with the CONT's ASSERTED-TYPE. ;;; ;;; The error and warning functions are functions that are called to -;;; explain the result. We bind *compiler-error-context* to the -;;; combination node so that Compiler-Warning and related functions +;;; 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) @@ -133,7 +157,7 @@ (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)) @@ -157,8 +181,8 @@ (*slime-detected* (values nil nil)) (t (values t t))))) -;;; Check that the derived type of the continuation Cont is compatible -;;; with Type. N is the arg number, for error message purposes. We +;;; Check that the derived type of the continuation CONT is compatible +;;; with TYPE. N is the arg number, for error message purposes. We ;;; return true if arg is definitely o.k. If the type is a magic ;;; CONSTANT-TYPE, then we check for the argument being a constant ;;; value of the specified type. If there is a manifest type error @@ -171,13 +195,12 @@ (let ((ctype (continuation-type cont))) (multiple-value-bind (int win) (funcall *test-function* ctype type) (cond ((not win) - (note-slime "can't tell whether the ~:R argument is a ~S" n - (type-specifier type)) + (note-slime "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) @@ -218,12 +241,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 note +;;; slime. +(declaim (ftype (function (list fixnum function-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)) @@ -269,7 +292,7 @@ (: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*)) @@ -299,35 +322,37 @@ ;;;; 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-function-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. +(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 (required-argument) :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. + ;; 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 -;;; Call. If Type is supplied and not null, then we merge the -;;; information into the information already accumulated in Type. +;;; Return an APPROXIMATE-FUNCTION-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) @@ -391,15 +416,17 @@ :types (list val-type)))))))))))) type)) -;;; Similar to Valid-Function-Use, but checks an -;;; Approximate-Function-Type against a real function 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 &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-warning) + (*test-function* + #'types-equal-or-intersect) + (*error-function* + #'compiler-style-warning) (*warning-function* #'compiler-note)) (let* ((*lossage-detected* nil) (*slime-detected* nil) @@ -416,19 +443,21 @@ (let ((call-min (approximate-function-type-min-args call-type))) (when (< call-min min-args) (note-lossage - "Function previously called with ~R argument~:P, but wants at least ~R." + "~:@" call-min min-args))) (let ((call-max (approximate-function-type-max-args call-type))) (cond ((<= call-max max-args)) ((not (or keyp rest)) (note-lossage - "Function previously called with ~R argument~:P, but wants at most ~R." + "~:@" call-max max-args)) ((and keyp (oddp (- call-max max-args))) (note-lossage - "Function previously called with an odd number of arguments in ~ - the keyword portion."))) + "~:@"))) (when (and keyp (> call-max max-args)) (check-approximate-keywords call-type max-args type))) @@ -455,7 +484,7 @@ (check-approximate-arg-type (car types) decl-type "~:R" n))) (values)) -;;; Check that each of the call-types is compatible with Decl-Type, +;;; Check that each of the call-types is compatible with DECL-TYPE, ;;; complaining if not or if we can't tell. (declaim (ftype (function (list ctype string &rest t) (values)) check-approximate-arg-type)) @@ -479,7 +508,7 @@ ;;; 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-FUNCTION-TYPE-TYPES to make ;;; sure that all arguments in keyword positions were manifest ;;; keywords. (defun check-approximate-keywords (call-type max-args type) @@ -510,25 +539,25 @@ ;;;; ASSERT-DEFINITION-TYPE -;;; Intersect Lambda's var types with Types, giving a warning if there +;;; Intersect LAMBDA's var types with TYPES, giving a warning if there ;;; is a mismatch. If all intersections are non-null, we return lists ;;; of the variables and intersections, otherwise we return NIL, NIL. (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~@ + (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-name var) (type-specifier vtype) - where (type-specifier type)) - (return-from try-type-intersections (values nil nil))) - (t - (res int))))) + (leaf-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)))) @@ -539,7 +568,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. ;;; @@ -566,24 +595,24 @@ (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") + "&KEY arguments") (unless (optional-dispatch-keyp od) (frob (not (null (optional-dispatch-more-entry od))) (not (null (function-type-rest type))) - "rest args")) + "&REST arguments")) (frob (optional-dispatch-allowp od) (function-type-allowp type) - "&allow-other-keys")) + "&ALLOW-OTHER-KEYS")) (when *lossage-detected* (return-from find-optional-dispatch-types (values nil nil))) @@ -601,7 +630,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 @@ -637,9 +666,9 @@ :key #'(lambda (x) (let ((info (lambda-var-arg-info x))) (when info - (arg-info-keyword info))))) + (arg-info-key info))))) (note-lossage - "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)))) @@ -651,36 +680,37 @@ (flet ((frob (x what) (when x (note-lossage - "Definition has no ~A, but the ~A did." + "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 (function-type-optional type) "&OPTIONAL arguments") + (frob (function-type-keyp type) "&KEY arguments") + (frob (function-type-rest type) "&REST argument")) (let* ((vars (lambda-vars lambda)) (nvars (length vars)) (req (function-type-required type)) (nreq (length req))) (unless (= nvars nreq) - (note-lossage "Definition has ~R arg~:P, but the ~A has ~R." + (note-lossage "The definition has ~R arg~:P, but the ~A has ~R." nvars where nreq)) (if *lossage-detected* (values nil nil) (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 -;;; and Really-Assert is T, then add type assertions to the definition -;;; from the Function-Type. +;;; FUNCTIONAL and the specified FUNCTION-TYPE. If they are compatible +;;; and REALLY-ASSERT is T, then add type assertions to the definition +;;; from the FUNCTION-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. +;;; ERROR-FUNCTION with an error message using WHERE as context +;;; describing where FUNCTION-TYPE came from. ;;; -;;; If there is no problem, we return T (even if Really-Assert was +;;; 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-warning) + ((:error-function *error-function*) + #'compiler-style-warning) warning-function (where "previous declaration")) (declare (type functional functional) @@ -701,7 +731,8 @@ (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"