X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fctype.lisp;h=62aa72ebee8864eed8fc7ac4926c26bbc595d471;hb=7f1e94ae961a198e00daf281eb1dc858e5b2dcc7;hp=8614e92ff578466f2e79b1651b5d21429a7e510f;hpb=e0814eee6f6dea52db010b45a330100f2fe65832;p=sbcl.git diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp index 8614e92..62aa72e 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*)) @@ -100,133 +93,137 @@ ;;; 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. NODE-DERIVED-TYPE is intersected with the +;;; trusted 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 ;;; 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*))) - (declare (type function result-test) (type combination call) - (type fun-type type)) +(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 (or function null) result-test) (type combination call) + ;; 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) - (*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)))))) - + (*unwinnage-detected* nil) + (*compiler-error-context* call) + (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)))) + + (when result-test + (let* ((dtype (node-derived-type call)) + (out-type (or + (binding* ((lvar (node-lvar call) :exit-if-null) + (dest (lvar-dest lvar))) + (when (and (cast-p dest) + (eq (cast-type-to-check dest) *wild-type*) + (immediately-used-p lvar call)) + (values-type-intersection + dtype (cast-asserted-type dest)))) + dtype)) + (return-type (fun-type-returns type))) + (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))))) - -;;; 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 -;;; (DERIVED-TYPE = NIL), then we flame about the asserted type even -;;; when our type is satisfied under the test. -(defun check-arg-type (cont type n) - (declare (type continuation cont) (type ctype type) (type index n)) + (*unwinnage-detected* (values nil nil)) + (t (values t t))))) + +;;; Check that the derived type of the LVAR 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 (DERIVED-TYPE = NIL), then +;;; we flame about the asserted type even when our type is satisfied +;;; under the test. +(defun check-arg-type (lvar type n) + (declare (type lvar lvar) (type ctype type) (type index n)) (cond ((not (constant-type-p type)) - (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)) - 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) - nil) - (t t))))) - ((not (constant-continuation-p cont)) - (note-slime "The ~:R argument is not a constant." n) + (let ((ctype (lvar-type lvar))) + (multiple-value-bind (int win) (funcall *ctype-test-fun* ctype type) + (cond ((not win) + (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-unwinnage "The ~:R argument never returns a value." n) + nil) + (t t))))) + ((not (constant-lvar-p lvar)) + (note-unwinnage "The ~:R argument is not a constant." n) nil) (t - (let ((val (continuation-value cont)) - (type (constant-type-type type))) + (let ((val (lvar-value lvar)) + (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) - nil) - ((not res) - (note-lossage "The ~:R argument is not a constant ~S:~% ~S" - n (type-specifier type) val) - nil) - (t t))))))) + (cond ((not win) + (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" + n (type-specifier type) val) + nil) + (t t))))))) ;;; 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)) @@ -234,81 +231,102 @@ (n 1 (1+ n))) ((or (null type) (null arg)) (when rest - (dolist (arg arg) - (check-arg-type arg rest n) - (incf n)))) + (dolist (arg arg) + (check-arg-type arg rest n) + (incf n)))) (declare (fixnum n)) (check-arg-type (car arg) (car type) n)) (values)) ;;; 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)) - (n (1+ pre-key) (+ n 2))) - ((null key)) - (declare (fixnum n)) - (let ((k (car key))) - (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)) - (t - (let* ((name (continuation-value k)) - (info (find name (fun-type-keywords type) - :key #'key-info-name))) - (cond ((not info) - (unless (fun-type-allowp type) - (note-lossage "~S is not a known argument keyword." - name))) - (t - (check-arg-type (second key) (key-info-type info) - (1+ n))))))))) + (let (lossages allow-other-keys) + (do ((key (nthcdr pre-key args) (cddr key)) + (n (1+ pre-key) (+ n 2))) + ((null key)) + (declare (fixnum n)) + (let ((k (first key)) + (v (second key))) + (cond + ((not (check-arg-type k (specifier-type 'symbol) n))) + ((not (constant-lvar-p k)) + (note-unwinnage "~@" n) + ;; An unknown key may turn out to be :ALLOW-OTHER-KEYS at runtime, + ;; so we cannot signal full warnings for keys that look bad. + (unless allow-other-keys + (setf allow-other-keys :maybe))) + (t + (let* ((name (lvar-value k)) + (info (find name (fun-type-keywords type) + :key #'key-info-name))) + (cond ((eq name :allow-other-keys) + (unless allow-other-keys + (if (constant-lvar-p v) + (setf allow-other-keys (if (lvar-value v) + :yes + :no)) + (setf allow-other-keys :maybe)))) + ((not info) + (unless (fun-type-allowp type) + (pushnew name lossages :test #'eq))) + (t + (check-arg-type (second key) (key-info-type info) + (1+ n))))))))) + (when (and lossages (member allow-other-keys '(nil :no))) + (setf lossages (nreverse lossages)) + (if (cdr lossages) + (note-lossage "~@<~{~S~^, ~} and ~S are not a known argument keywords.~:@>" + (butlast lossages) + (car (last lossages))) + (note-lossage "~S is not a known argument keyword." + (car lossages))))) (values)) ;;; Construct a function type from a definition. ;;; ;;; 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 :required (mapcar #'leaf-type (lambda-vars functional)) :returns (tail-set-type (lambda-tail-set functional))) (let ((rest nil)) - (collect ((req) - (opt) - (keys)) - (dolist (arg (optional-dispatch-arglist functional)) - (let ((info (lambda-var-arg-info arg)) - (type (leaf-type arg))) - (if info - (ecase (arg-info-kind info) - (:required (req type)) - (:optional (opt type)) - (:keyword - (keys (make-key-info :name (arg-info-key info) - :type type))) - ((:rest :more-context) - (setq rest *universal-type*)) - (:more-count)) - (req type)))) - - (make-fun-type - :required (req) - :optional (opt) - :rest rest - :keywords (keys) - :keyp (optional-dispatch-keyp functional) - :allowp (optional-dispatch-allowp functional) - :returns (tail-set-type - (lambda-tail-set - (optional-dispatch-main-entry functional)))))))) + (collect ((req) + (opt) + (keys)) + (dolist (arg (optional-dispatch-arglist functional)) + (let ((info (lambda-var-arg-info arg)) + (type (leaf-type arg))) + (if info + (ecase (arg-info-kind info) + (:required (req type)) + (:optional (opt type)) + (:keyword + (keys (make-key-info :name (arg-info-key info) + :type type))) + ((:rest :more-context) + (setq rest *universal-type*)) + (:more-count)) + (req type)))) + + (make-fun-type + :required (req) + :optional (opt) + :rest rest + :keywords (keys) + :keyp (optional-dispatch-keyp functional) + :allowp (optional-dispatch-allowp functional) + :returns (tail-set-type + (lambda-tail-set + (optional-dispatch-main-entry functional)))))))) ;;;; approximate function types ;;;; @@ -325,8 +343,10 @@ (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) + (min-args sb!xc:call-arguments-limit + :type (integer 0 #.sb!xc:call-arguments-limit)) + (max-args 0 + :type (integer 0 #.sb!xc:call-arguments-limit)) ;; a list of lists of the all the types that have been used in each ;; argument position (types () :type list) @@ -343,7 +363,8 @@ (name (missing-arg) :type keyword) ;; The position at which this keyword appeared. 0 if it appeared as the ;; first argument, etc. - (position (missing-arg) :type fixnum) + (position (missing-arg) + :type (integer 0 #.sb!xc:call-arguments-limit)) ;; 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 @@ -354,126 +375,126 @@ ;;; 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-fun-type null)) - approximate-fun-type) - note-function-use)) -(defun note-function-use (call &optional 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))) + (types (approximate-fun-type-types type)) + (args (combination-args call)) + (nargs (length args)) + (allowp (some (lambda (x) + (and (constant-lvar-p x) + (eq (lvar-value x) :allow-other-keys))) + args))) (setf (approximate-fun-type-min-args type) - (min (approximate-fun-type-min-args type) nargs)) + (min (approximate-fun-type-min-args type) nargs)) (setf (approximate-fun-type-max-args type) - (max (approximate-fun-type-max-args type) nargs)) + (max (approximate-fun-type-max-args type) nargs)) (do ((old types (cdr old)) - (arg args (cdr arg))) - ((null old) - (setf (approximate-fun-type-types type) - (nconc types - (mapcar (lambda (x) - (list (continuation-type x))) - arg)))) + (arg args (cdr arg))) + ((null old) + (setf (approximate-fun-type-types type) + (nconc types + (mapcar (lambda (x) + (list (lvar-type x))) + arg)))) (when (null arg) (return)) - (pushnew (continuation-type (car arg)) - (car old) - :test #'type=)) + (pushnew (lvar-type (car arg)) + (car old) + :test #'type=)) (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-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))) - (keys))) - (val-type (continuation-type val))) - (cond (old - (pushnew val-type - (approximate-key-info-types old) - :test #'type=) - (unless allowp - (setf (approximate-key-info-allowp old) nil))) - (t - (keys (make-approximate-key-info - :name name - :position pos - :allowp allowp - :types (list val-type)))))))))))) + (pos 0 (1+ pos))) + ((or (null arg) (null (cdr arg))) + (setf (approximate-fun-type-keys type) (keys))) + (let ((key (first arg)) + (val (second arg))) + (when (constant-lvar-p key) + (let ((name (lvar-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))) + (keys))) + (val-type (lvar-type val))) + (cond (old + (pushnew val-type + (approximate-key-info-types old) + :test #'type=) + (unless allowp + (setf (approximate-key-info-allowp old) nil))) + (t + (keys (make-approximate-key-info + :name name + :position pos + :allowp allowp + :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)) + &optional function function function) + (values boolean boolean)) + valid-approximate-type)) (defun valid-approximate-type (call-type type &optional - (*test-function* - #'types-equal-or-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-notify)) (let* ((*lossage-detected* nil) - (*slime-detected* nil) - (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))) + (*unwinnage-detected* nil) + (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))) (when (fun-type-wild-args type) (return-from valid-approximate-type (values t t))) (let ((call-min (approximate-fun-type-min-args call-type))) (when (< call-min min-args) - (note-lossage - "~:@" - call-min min-args))) + call-min min-args))) (let ((call-max (approximate-fun-type-max-args call-type))) (cond ((<= call-max max-args)) - ((not (or keyp rest)) - (note-lossage - "~:@" - call-max max-args)) - ((and keyp (oddp (- call-max max-args))) - (note-lossage - "~:@"))) (when (and keyp (> call-max max-args)) - (check-approximate-keywords call-type max-args type))) + (check-approximate-keywords call-type max-args type))) (check-approximate-fixed-and-rest call-type (append required optional) - rest) + rest) (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 each of the types used at each arg position is ;;; compatible with the actual type. (declaim (ftype (function (approximate-fun-type list (or ctype null)) - (values)) - check-approximate-fixed-and-rest)) + (values)) + check-approximate-fixed-and-rest)) (defun check-approximate-fixed-and-rest (call-type fixed rest) (do ((types (approximate-fun-type-types call-type) (cdr types)) (n 1 (1+ n)) @@ -487,21 +508,25 @@ ;;; 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)) + check-approximate-arg-type)) (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) - (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))) - ((not int) - (setq losers (type-union ctype losers)))))) + (multiple-value-bind (int win) (funcall *ctype-test-fun* ctype decl-type) + (cond + ((not win) + (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)))))) (unless (eq losers *empty-type*) (note-lossage "~:(~?~) argument should be a ~S but was a ~S in a previous call." - context args (type-specifier decl-type) (type-specifier losers)))) + context args (type-specifier decl-type) (type-specifier losers)))) (values)) ;;; Check the types of each manifest keyword that appears in a keyword @@ -513,29 +538,29 @@ ;;; keywords. (defun check-approximate-keywords (call-type max-args type) (let ((call-keys (approximate-fun-type-keys call-type)) - (keys (fun-type-keywords type))) + (keys (fun-type-keywords type))) (dolist (key keys) (let ((name (key-info-name key))) - (collect ((types nil append)) - (dolist (call-key call-keys) - (let ((pos (approximate-key-info-position call-key))) - (when (and (eq (approximate-key-info-name call-key) name) - (> pos max-args) (evenp (- pos max-args))) - (types (approximate-key-info-types call-key))))) - (check-approximate-arg-type (types) (key-info-type key) "~S" name)))) + (collect ((types nil append)) + (dolist (call-key call-keys) + (let ((pos (approximate-key-info-position call-key))) + (when (and (eq (approximate-key-info-name call-key) name) + (> pos max-args) (evenp (- pos max-args))) + (types (approximate-key-info-types call-key))))) + (check-approximate-arg-type (types) (key-info-type key) "~S" name)))) (unless (fun-type-allowp type) (collect ((names () adjoin)) - (dolist (call-key call-keys) - (let ((pos (approximate-key-info-position call-key))) - (when (and (> pos max-args) (evenp (- pos max-args)) - (not (approximate-key-info-allowp call-key))) - (names (approximate-key-info-name call-key))))) - - (dolist (name (names)) - (unless (find name keys :key #'key-info-name) - (note-lossage "Function previously called with unknown argument keyword ~S." - name))))))) + (dolist (call-key call-keys) + (let ((pos (approximate-key-info-position call-key))) + (when (and (> pos max-args) (evenp (- pos max-args)) + (not (approximate-key-info-allowp call-key))) + (names (approximate-key-info-name call-key))))) + + (dolist (name (names)) + (unless (find name keys :key #'key-info-name) + (note-lossage "Function previously called with unknown argument keyword ~S." + name))))))) ;;;; ASSERT-DEFINITION-TYPE @@ -546,22 +571,22 @@ (declare (list vars types) (string where)) (collect ((res)) (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) + (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)))) -;;; 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. ;;; @@ -588,114 +613,114 @@ ;;; assertion. (defun find-optional-dispatch-types (od type where) (declare (type optional-dispatch od) - (type fun-type type) - (string where)) + (type fun-type type) + (string where)) (let* ((min (optional-dispatch-min-args od)) - (req (fun-type-required type)) - (opt (fun-type-optional type))) + (req (fun-type-required type)) + (opt (fun-type-optional type))) (flet ((frob (x y what) - (unless (= x y) - (note-lossage - "The definition has ~R ~A arg~P, but ~A has ~R." - x what x where y)))) + (unless (= x y) + (note-lossage + "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 - "The definition ~:[doesn't have~;has~] ~A, but ~ - ~A ~:[doesn't~;does~]." - x what where y)))) + (unless (eq x y) + (note-lossage + "The definition ~:[doesn't have~;has~] ~A, but ~ + ~A ~:[doesn't~;does~]." + x what where y)))) (frob (optional-dispatch-keyp od) (fun-type-keyp type) - "&KEY arguments") + "&KEY arguments") (unless (optional-dispatch-keyp od) - (frob (not (null (optional-dispatch-more-entry od))) - (not (null (fun-type-rest type))) - "&REST arguments")) + (frob (not (null (optional-dispatch-more-entry od))) + (not (null (fun-type-rest type))) + "&REST argument")) (frob (optional-dispatch-allowp od) (fun-type-allowp type) - "&ALLOW-OTHER-KEYS")) + "&ALLOW-OTHER-KEYS")) (when *lossage-detected* (return-from find-optional-dispatch-types (values nil nil))) (collect ((res) - (vars)) + (vars)) (let ((keys (fun-type-keywords type)) - (arglist (optional-dispatch-arglist od))) - (dolist (arg arglist) - (cond - ((lambda-var-arg-info arg) - (let* ((info (lambda-var-arg-info arg)) - (default (arg-info-default info)) - (def-type (when (constantp default) - (ctype-of (eval default))))) - (ecase (arg-info-kind info) - (:keyword - (let* ((key (arg-info-key info)) - (kinfo (find key keys :key #'key-info-name))) - (cond - (kinfo - (res (type-union (key-info-type kinfo) - (or def-type (specifier-type 'null))))) - (t - (note-lossage - "Defining a ~S keyword not present in ~A." - key where) - (res *universal-type*))))) - (:required (res (pop req))) - (:optional - (res (type-union (pop opt) (or def-type *universal-type*)))) - (:rest - (when (fun-type-rest type) - (res (specifier-type 'list)))) - (:more-context - (when (fun-type-rest type) - (res *universal-type*))) - (:more-count - (when (fun-type-rest type) - (res (specifier-type 'fixnum))))) - (vars arg) - (when (arg-info-supplied-p info) - (res *universal-type*) - (vars (arg-info-supplied-p info))))) - (t - (res (pop req)) - (vars arg)))) - - (dolist (key keys) - (unless (find (key-info-name key) arglist - :key (lambda (x) - (let ((info (lambda-var-arg-info x))) - (when info - (arg-info-key info))))) - (note-lossage - "The definition lacks the ~S key present in ~A." - (key-info-name key) where)))) + (arglist (optional-dispatch-arglist od))) + (dolist (arg arglist) + (cond + ((lambda-var-arg-info arg) + (let* ((info (lambda-var-arg-info arg)) + (default (arg-info-default info)) + (def-type (when (sb!xc:constantp default) + (ctype-of (constant-form-value default))))) + (ecase (arg-info-kind info) + (:keyword + (let* ((key (arg-info-key info)) + (kinfo (find key keys :key #'key-info-name))) + (cond + (kinfo + (res (type-union (key-info-type kinfo) + (or def-type (specifier-type 'null))))) + (t + (note-lossage + "Defining a ~S keyword not present in ~A." + key where) + (res *universal-type*))))) + (:required (res (pop req))) + (:optional + (res (type-union (pop opt) (or def-type *universal-type*)))) + (:rest + (when (fun-type-rest type) + (res (specifier-type 'list)))) + (:more-context + (when (fun-type-rest type) + (res *universal-type*))) + (:more-count + (when (fun-type-rest type) + (res (specifier-type 'fixnum))))) + (vars arg) + (when (arg-info-supplied-p info) + (res *universal-type*) + (vars (arg-info-supplied-p info))))) + (t + (res (pop req)) + (vars arg)))) + + (dolist (key keys) + (unless (find (key-info-name key) arglist + :key (lambda (x) + (let ((info (lambda-var-arg-info x))) + (when info + (arg-info-key info))))) + (note-lossage + "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 fun-type type) (string where)) (flet ((frob (x what) - (when x - (note-lossage - "The definition has no ~A, but the ~A did." - what where)))) + (when x + (note-lossage + "The definition has no ~A, but the ~A did." + what where)))) (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 (fun-type-required type)) - (nreq (length req))) + (nvars (length vars)) + (req (fun-type-required type)) + (nreq (length req))) (unless (= nvars nreq) (note-lossage "The definition has ~R arg~:P, but the ~A has ~R." - nvars where nreq)) + nvars where nreq)) (if *lossage-detected* - (values nil nil) - (try-type-intersections vars req where)))) + (values nil nil) + (try-type-intersections vars req where)))) ;;; Check for syntactic and type conformance between the definition ;;; FUNCTIONAL and the specified FUN-TYPE. If they are compatible @@ -703,61 +728,259 @@ ;;; 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*) - (string where)) + (type function *lossage-fun*) + (string where)) (unless (fun-type-p type) (return-from assert-definition-type t)) (let ((*lossage-detected* nil)) (multiple-value-bind (vars types) - (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)))) + (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 (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-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~% ~ - 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)))))) + (return (lambda-return (main-entry functional))) + (dtype (when return + (lvar-derived-type (return-result return))))) + (cond + ((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-lvar-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) + (let ((s-type (make-single-value-type type))) + (dolist (ref (leaf-refs var)) + (derive-node-type ref s-type)))))) + t)))))) + +;;; FIXME: This is quite similar to ASSERT-NEW-DEFINITION. +(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) + (let ((type (massage-global-definition-type type fun))) + (setf (leaf-type fun) type) + (assert-definition-type + fun type + :unwinnage-fun #'compiler-notify + :where "proclamation" + :really-assert (not (awhen (info :function :info name) + (ir1-attributep (fun-info-attributes it) + explicit-check)))))))) + +;;; If the function has both &REST and &KEY, FIND-OPTIONAL-DISPATCH-TYPES +;;; doesn't complain about the type missing &REST -- which is good, because in +;;; that case &REST is really an implementation detail and not part of the +;;; interface. However since we set the leaf type missing &REST from there +;;; would be a bad thing -- to make up a new type if necessary. +(defun massage-global-definition-type (type fun) + (if (and (fun-type-p type) + (optional-dispatch-p fun) + (optional-dispatch-keyp fun) + (optional-dispatch-more-entry fun) + (not (or (fun-type-rest type) + (fun-type-wild-args type)))) + (make-fun-type :required (fun-type-required type) + :optional (fun-type-optional type) + :rest *universal-type* + :keyp (fun-type-keyp type) + :keywords (fun-type-keywords type) + :allowp (fun-type-allowp type) + :returns (fun-type-returns type)) + type)) + +;;; Call FUN with (arg-lvar arg-type) +(defun map-combination-args-and-types (fun call) + (declare (type function fun) (type combination call)) + (binding* ((type (lvar-type (combination-fun call))) + (nil (fun-type-p type) :exit-if-null) + (args (combination-args call))) + (dolist (req (fun-type-required type)) + (when (null args) (return-from map-combination-args-and-types)) + (let ((arg (pop args))) + (funcall fun arg req))) + (dolist (opt (fun-type-optional type)) + (when (null args) (return-from map-combination-args-and-types)) + (let ((arg (pop args))) + (funcall fun arg opt))) + + (let ((rest (fun-type-rest type))) + (when rest + (dolist (arg args) + (funcall fun arg rest)))) + + (dolist (key (fun-type-keywords type)) + (let ((name (key-info-name key))) + (do ((arg args (cddr arg))) + ((null arg)) + (let ((keyname (first arg))) + (when (and (constant-lvar-p keyname) + (eq (lvar-value keyname) name)) + (funcall fun (second arg) (key-info-type key))))))))) + +;;; Assert that CALL is to a function of the specified TYPE. It is +;;; assumed that the call is legal and has only constants in the +;;; keyword positions. +(defun assert-call-type (call type &optional (trusted t)) + (declare (type combination call) (type fun-type type)) + (let ((policy (lexenv-policy (node-lexenv call))) + (returns (fun-type-returns type))) + (if trusted + (derive-node-type call returns) + (let ((lvar (node-lvar call))) + ;; If the value is used in a non-tail position, and the lvar + ;; is a single-use, assert the type. Multiple use sites need + ;; to be elided because the assertion has to apply to all + ;; uses. Tail positions are elided because the assertion + ;; would cause us not the be in a tail-position anymore. MV + ;; calls are elided because not only are the assertions of + ;; less use there, but they can cause the MV call conversion + ;; to cause astray. + (when (and lvar + (not (return-p (lvar-dest lvar))) + (not (mv-combination-p (lvar-dest lvar))) + (lvar-has-single-use-p lvar)) + (when (assert-lvar-type lvar returns policy) + (reoptimize-lvar lvar))))) + (map-combination-args-and-types + (lambda (arg type) + (when (assert-lvar-type arg type policy) + (unless trusted (reoptimize-lvar arg)))) + call)) + (values)) + +;;;; FIXME: Move to some other file. +(defun check-catch-tag-type (tag) + (declare (type lvar tag)) + (let ((ctype (lvar-type tag))) + (when (csubtypep ctype (specifier-type '(or number character))) + (let ((sources (lvar-all-sources tag))) + (if (singleton-p sources) + (compiler-style-warn + "~@" + (first sources) + (type-specifier (lvar-type tag))) + (compiler-style-warn + "~@" + (rest sources) (first sources) + (type-specifier (lvar-type tag)))))))) + +(defun %compile-time-type-error (values atype dtype context) + (declare (ignore dtype)) + (destructuring-bind (form . detail) context + (if (and (consp atype) (eq (car atype) 'values)) + (if (singleton-p detail) + (error 'simple-type-error + :datum (car values) + :expected-type atype + :format-control + "~@" + :format-arguments (list values + (first detail) form + atype)) + (error 'simple-type-error + :datum (car values) + :expected-type atype + :format-control + "~@" + :format-arguments (list values + (rest detail) (first detail) + form + atype))) + (if (singleton-p detail) + (error 'simple-type-error + :datum (car values) + :expected-type atype + :format-control "~@" + :format-arguments (list (car detail) form + (car values) + atype)) + (error 'simple-type-error + :datum (car values) + :expected-type atype + :format-control "~@" + :format-arguments (list (rest detail) (first detail) form + (car values) + atype)))))) + +(defoptimizer (%compile-time-type-error ir2-convert) + ((objects atype dtype context) node block) + (let ((*compiler-error-context* node)) + (setf (node-source-path node) + (cdr (node-source-path node))) + (destructuring-bind (values atype dtype context) + (basic-combination-args node) + (declare (ignore values)) + (let ((atype (lvar-value atype)) + (dtype (lvar-value dtype)) + (detail (cdr (lvar-value context)))) + (unless (eq atype nil) + (if (singleton-p detail) + (let ((detail (first detail))) + (if (constantp detail) + (warn 'type-warning + :format-control + "~@" + :format-arguments (list (eval detail) atype)) + (warn 'type-warning + :format-control + "~@" + :format-arguments (list detail dtype atype)))) + (warn 'type-warning + :format-control + "~@" + :format-arguments (list (rest detail) (first detail) dtype atype)))))) + (ir2-convert-full-call node block)))