X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fctype.lisp;h=93aeb42ab0f8d4895e8dac57ab8ff3e13c24148c;hb=403bacffd903f8c5787a182f4133cffc69b55dc0;hp=8614e92ff578466f2e79b1651b5d21429a7e510f;hpb=e0814eee6f6dea52db010b45a330100f2fe65832;p=sbcl.git diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp index 8614e92..93aeb42 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,77 +102,74 @@ ;;; 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) + ((:lossage-fun *lossage-fun*)) + ((:unwinnage-fun *unwinnage-fun*))) (declare (type function result-test) (type combination call) - (type fun-type type)) + ;; FIXME: Could TYPE here actually be something like + ;; (AND GENERIC-FUNCTION (FUNCTION (T) T))? How + ;; horrible... -- CSR, 2003-05-03 + (type ctype type)) (let* ((*lossage-detected* nil) - (*slime-detected* nil) + (*unwinnage-detected* nil) (*compiler-error-context* call) - (args (combination-args call)) - (nargs (length args)) - (required (fun-type-required type)) - (min-args (length required)) - (optional (fun-type-optional type)) - (max-args (+ min-args (length optional))) - (rest (fun-type-rest type)) - (keyp (fun-type-keyp type))) - - (cond - ((fun-type-wild-args type) - (do ((i 1 (1+ i)) - (arg args (cdr arg))) - ((null arg)) - (check-arg-type (car arg) *wild-type* i))) - ((not (or optional keyp rest)) - (if (/= nargs min-args) - (note-lossage - "The function was called with ~R argument~:P, but wants exactly ~R." - nargs min-args) - (check-fixed-and-rest args required nil))) - ((< nargs min-args) - (note-lossage - "The function was called with ~R argument~:P, but wants at least ~R." - nargs min-args)) - ((<= nargs max-args) - (check-fixed-and-rest args (append required optional) rest)) - ((not (or keyp rest)) - (note-lossage - "The function was called with ~R argument~:P, but wants at most ~R." - nargs max-args)) - ((and keyp (oddp (- nargs max-args))) - (note-lossage - "The function has an odd number of arguments in the keyword portion.")) - (t - (check-fixed-and-rest args (append required optional) rest) - (when keyp - (check-key-args args max-args type)))) - - (let* ((dtype (node-derived-type call)) - (return-type (fun-type-returns type)) - (cont (node-cont call)) - (out-type - (if (or (not (continuation-type-check cont)) - (and strict-result (policy call (/= safety 0)))) - dtype - (values-type-intersection (continuation-asserted-type cont) - 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))) - ((not int) - (note-lossage "The result is a ~S, not a ~S." - (type-specifier out-type) - (type-specifier return-type)))))) - + (args (combination-args call))) + (if (fun-type-p type) + (let* ((nargs (length args)) + (required (fun-type-required type)) + (min-args (length required)) + (optional (fun-type-optional type)) + (max-args (+ min-args (length optional))) + (rest (fun-type-rest type)) + (keyp (fun-type-keyp type))) + (cond + ((fun-type-wild-args type) + (loop for arg in args + and i from 1 + do (check-arg-type arg *universal-type* i))) + ((not (or optional keyp rest)) + (if (/= nargs min-args) + (note-lossage + "The function was called with ~R argument~:P, but wants exactly ~R." + nargs min-args) + (check-fixed-and-rest args required nil))) + ((< nargs min-args) + (note-lossage + "The function was called with ~R argument~:P, but wants at least ~R." + nargs min-args)) + ((<= nargs max-args) + (check-fixed-and-rest args (append required optional) rest)) + ((not (or keyp rest)) + (note-lossage + "The function was called with ~R argument~:P, but wants at most ~R." + nargs max-args)) + ((and keyp (oddp (- nargs max-args))) + (note-lossage + "The function has an odd number of arguments in the keyword portion.")) + (t + (check-fixed-and-rest args (append required optional) rest) + (when keyp + (check-key-args args max-args type)))) + + (let* ((dtype (node-derived-type call)) + (return-type (fun-type-returns type)) + (out-type dtype)) + (multiple-value-bind (int win) (funcall result-test out-type return-type) + (cond ((not win) + (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))))))) + (loop for arg in args + and i from 1 + do (check-arg-type arg *wild-type* i))) (cond (*lossage-detected* (values nil t)) - (*slime-detected* (values nil nil)) - (t (values t t))))) + (*unwinnage-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 @@ -193,30 +183,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)) 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" @@ -226,7 +216,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)) @@ -243,8 +233,8 @@ ;;; 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. +;;; 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)) @@ -255,8 +245,9 @@ (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 (fun-type-keywords type) @@ -274,7 +265,7 @@ ;;; ;;; Due to the lack of a (LIST X) type specifier, we can't reconstruct ;;; the &REST type. -(declaim (ftype (function (functional) fun-type) definition-type)) +(declaim (ftype (sfunction (functional) fun-type) definition-type)) (defun definition-type (functional) (if (lambda-p functional) (make-fun-type @@ -356,8 +347,8 @@ (declaim (ftype (function (combination &optional (or approximate-fun-type null)) approximate-fun-type) - note-function-use)) -(defun note-function-use (call &optional 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)) @@ -416,20 +407,20 @@ :types (list val-type)))))))))))) type)) -;;; This is similar to VALID-FUNCTION-USE, but checks an +;;; This is similar to VALID-FUN-USE, but checks an ;;; 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* + (*ctype-test-fun* #'types-equal-or-intersect) - (*error-function* - #'compiler-style-warning) - (*warning-function* #'compiler-note)) + (*lossage-fun* + #'compiler-style-warn) + (*unwinnage-fun* #'compiler-notify)) (let* ((*lossage-detected* nil) - (*slime-detected* nil) + (*unwinnage-detected* nil) (required (fun-type-required type)) (min-args (length required)) (optional (fun-type-optional type)) @@ -466,7 +457,7 @@ 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 @@ -491,11 +482,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)))))) @@ -561,7 +556,7 @@ vars types) (values vars (res)))) -;;; Check that the optional-dispatch OD conforms to Type. We return +;;; Check that the optional-dispatch OD conforms to TYPE. We return ;;; the values of TRY-TYPE-INTERSECTIONS if there are no syntax ;;; problems, otherwise NIL, NIL. ;;; @@ -674,7 +669,7 @@ (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 fun-type type) (string where)) @@ -703,19 +698,19 @@ ;;; 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 +;;; 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 - (where "previous declaration")) + (functional type &key (really-assert t) + ((: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 (fun-type-p type) (return-from assert-definition-type t)) @@ -730,34 +725,80 @@ (find-lambda-types functional type where)))) (let* ((type-returns (fun-type-returns type)) (return (lambda-return (main-entry functional))) - (atype (when return - (continuation-asserted-type (return-result return))))) + (dtype (when return + (continuation-derived-type (return-result return))))) (cond - ((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" - where (type-specifier type-returns) (type-specifier atype)) - nil) - (*lossage-detected* nil) - ((not really-assert) t) - (t - (when atype - (assert-continuation-type (return-result return) atype)) - (loop for var in vars and type in types do - (cond ((basic-var-sets var) - (when (and warning-function - (not (csubtypep (leaf-type var) type))) - (funcall warning-function - "Assignment to argument: ~S~% ~ + ((and dtype (not (values-types-equal-or-intersect dtype + type-returns))) + (note-lossage + "The result type from ~A:~% ~S~@ + conflicts with the definition's result type:~% ~S" + where (type-specifier type-returns) (type-specifier dtype)) + nil) + (*lossage-detected* nil) + ((not really-assert) t) + (t + (let ((policy (lexenv-policy (functional-lexenv functional)))) + (when (policy policy (> type-check 0)) + (assert-continuation-type (return-result return) type-returns + policy))) + (loop for var in vars and type in types do + (cond ((basic-var-sets var) + (when (and unwinnage-fun + (not (csubtypep (leaf-type var) type))) + (funcall unwinnage-fun + "Assignment to argument: ~S~% ~ prevents use of assertion from function ~ type ~A:~% ~S~%" - (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)))))) + (leaf-debug-name var) + where + (type-specifier type)))) + (t + (setf (leaf-type var) type) + (dolist (ref (leaf-refs var)) + (derive-node-type ref (make-single-value-type 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-notify + :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)))))) + +(defun %compile-time-type-error (values atype dtype) + (declare (ignore dtype)) + (if (and (consp atype) + (eq (car atype) 'values)) + (error 'values-type-error :datum values :expected-type atype) + (error 'type-error :datum (car values) :expected-type atype))) + +(defoptimizer (%compile-time-type-error ir2-convert) + ((objects atype dtype) node block) + (let ((*compiler-error-context* node)) + (setf (node-source-path node) + (cdr (node-source-path node))) + (destructuring-bind (values atype dtype) + (basic-combination-args node) + (declare (ignore values)) + (let ((atype (continuation-value atype)) + (dtype (continuation-value dtype))) + (unless (eq atype nil) + (compiler-warn + "~@" + atype dtype)))) + (ir2-convert-full-call node block)))