X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fctype.lisp;h=288bad7514b7f213216d1d81d6dc0dd5eefa8e4c;hb=df679ed627975948b1cee190f4d79c397588c43e;hp=34d69f0f783985e96dbbbd37b2399c65dcbe2848;hpb=29a9ccc860532b32c566aec095f570e999a9c52c;p=sbcl.git diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp index 34d69f0..288bad7 100644 --- a/src/compiler/ctype.lisp +++ b/src/compiler/ctype.lisp @@ -109,67 +109,72 @@ ((: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) (*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-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)))))) - + (nargs (length args))) + (if (fun-type-p type) + (let* ((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-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)) (*unwinnage-detected* (values nil nil)) (t (values t t))))) @@ -672,7 +677,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)) @@ -742,7 +747,8 @@ ((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 unwinnage-fun @@ -759,3 +765,24 @@ (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))))))