Skip to content
Snippets Groups Projects
Commit 8c836e2c authored by ram's avatar ram
Browse files

Made VALID-FUNCTION-USE match CONSTANT types when they appear in the arg

types.  Made VALID-FUNCTION-USE note lossage when there is an argument
whose type is NIL (a manifest type error) instead of considering it
to match anything.  Made people recognize the new FUNCTION-TYPE-WILD-ARGS
flag.
Randomly broke some lines that wrapped.
parent af712760
No related branches found
No related tags found
No related merge requests found
...@@ -102,20 +102,29 @@ ...@@ -102,20 +102,29 @@
(rest (function-type-rest type)) (rest (function-type-rest type))
(keyp (function-type-keyp type))) (keyp (function-type-keyp type)))
(cond ((< nargs min-args) (cond
(note-lossage "Function called with ~R argument~:P, but wants at least ~R." ((function-type-wild-args type)
nargs min-args)) (do ((i 1 (1+ i))
((<= nargs max-args) (arg args (cdr arg)))
(check-fixed-and-rest args (append required optional) rest)) ((null arg))
((not (or keyp rest)) (check-arg (car arg) *wild-type* i)))
(note-lossage "Function called with ~R argument~:P, but wants at most ~R." ((< nargs min-args)
nargs max-args)) (note-lossage
((and keyp (oddp (- nargs max-args))) "Function called with ~R argument~:P, but wants at least ~R."
(note-lossage "Function has an odd number of arguments in the keyword portion.")) nargs min-args))
(t ((<= nargs max-args)
(check-fixed-and-rest args (append required optional) rest) (check-fixed-and-rest args (append required optional) rest))
(when keyp ((not (or keyp rest))
(check-keywords args max-args type)))) (note-lossage
"Function called with ~R argument~:P, but wants at most ~R."
nargs max-args))
((and keyp (oddp (- nargs max-args)))
(note-lossage
"Function has an odd number of arguments in the keyword portion."))
(t
(check-fixed-and-rest args (append required optional) rest)
(when keyp
(check-keywords args max-args type))))
(let* ((dtype (node-derived-type call)) (let* ((dtype (node-derived-type call))
(return-type (function-type-returns type)) (return-type (function-type-returns type))
...@@ -144,23 +153,52 @@ ...@@ -144,23 +153,52 @@
;;; ;;;
;;; Check that the derived type of the continuation Cont is compatible with ;;; 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 ;;; Type. N is the arg number, for error message purposes. We return true if
;;; arg is definitely o.k. ;;; 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 manfest type error (DERIVED-TYPE = NIL), then we flame about the asserted
;;; type even when our type is satisfied under the test.
;;; ;;;
(proclaim '(function check-arg-type (continuation type fixnum) void))
(defun check-arg-type (cont type n) (defun check-arg-type (cont type n)
(let ((ctype (continuation-type cont))) (declare (type continuation cont) (type ctype type) (type index n))
(multiple-value-bind (int win) (cond
(funcall *test-function* ctype type) ((not (constant-type-p type))
(cond ((not win) (let ((ctype (continuation-type cont)))
(note-slime "Can't tell whether the ~:R argument is a ~S." n (multiple-value-bind (int win)
(type-specifier type)) (funcall *test-function* ctype type)
nil) (cond ((not win)
((not int) (note-slime "Can't tell whether the ~:R argument is a ~S." n
(note-lossage "The ~:R argument is a ~S, not a ~S." n
(type-specifier ctype)
(type-specifier type)) (type-specifier type))
nil) nil)
(t t))))) ((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-lossage "The ~:R argument is a ~S, not a ~S." n
(type-specifier (continuation-proven-type cont))
(type-specifier
(continuation-asserted-type cont)))
nil)
(t t))))
((not (constant-continuation-p cont))
(note-slime "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)
nil)
((not res)
(note-lossage "The ~:R argument is not a constant ~S:~% ~S"
n (type-specifier type) val)
nil)
(t t))))))))
;;; Check-Fixed-And-Rest -- Internal ;;; Check-Fixed-And-Rest -- Internal
...@@ -200,15 +238,19 @@ ...@@ -200,15 +238,19 @@
(check-arg-type k (specifier-type 'symbol) n) (check-arg-type k (specifier-type 'symbol) n)
(cond ((not (check-arg-type k (specifier-type 'keyword) n))) (cond ((not (check-arg-type k (specifier-type 'keyword) n)))
((not (constant-continuation-p k)) ((not (constant-continuation-p k))
(note-slime "The keyword for the ~:R argument is not a constant." n)) (note-slime "The keyword for the ~:R argument is not a constant."
n))
(t (t
(let* ((name (continuation-value k)) (let* ((name (continuation-value k))
(info (find name (function-type-keywords type) :key #'key-info-name))) (info (find name (function-type-keywords type)
:key #'key-info-name)))
(cond ((not info) (cond ((not info)
(unless (function-type-allowp type) (unless (function-type-allowp type)
(note-lossage "~S is not a known argument keyword." name))) (note-lossage "~S is not a known argument keyword."
name)))
(t (t
(check-arg-type (second key) (key-info-type info) n))))))))) (check-arg-type (second key) (key-info-type info)
n)))))))))
;;; Lambda-Result-Type -- Internal ;;; Lambda-Result-Type -- Internal
...@@ -359,7 +401,8 @@ ...@@ -359,7 +401,8 @@
(let ((old (find-if (let ((old (find-if
#'(lambda (x) #'(lambda (x)
(and (eq (approximate-key-info-name x) name) (and (eq (approximate-key-info-name x) name)
(= (approximate-key-info-position x) pos))) (= (approximate-key-info-position x)
pos)))
(keys))) (keys)))
(val-type (continuation-type val))) (val-type (continuation-type val)))
(cond (old (cond (old
...@@ -384,7 +427,8 @@ ...@@ -384,7 +427,8 @@
(approximate-function-type function-type &optional (approximate-function-type function-type &optional
function function function) function function function)
(values boolean boolean))) (values boolean boolean)))
(defun valid-approximate-type (call-type type &optional (*test-function* #'types-intersect) (defun valid-approximate-type (call-type type &optional
(*test-function* #'types-intersect)
(*error-function* #'compiler-warning) (*error-function* #'compiler-warning)
(*warning-function* #'compiler-note)) (*warning-function* #'compiler-note))
(let* ((*lossage-detected* nil) (let* ((*lossage-detected* nil)
...@@ -396,6 +440,9 @@ ...@@ -396,6 +440,9 @@
(rest (function-type-rest type)) (rest (function-type-rest type))
(keyp (function-type-keyp type))) (keyp (function-type-keyp type)))
(when (function-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-function-type-min-args call-type)))
(when (< call-min min-args) (when (< call-min min-args)
(note-lossage (note-lossage
...@@ -416,7 +463,8 @@ ...@@ -416,7 +463,8 @@
(when (and keyp (> call-max max-args)) (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) (check-approximate-fixed-and-rest call-type (append required optional)
rest)
(cond (*lossage-detected* (values nil t)) (cond (*lossage-detected* (values nil t))
(*slime-detected* (values nil nil)) (*slime-detected* (values nil nil))
...@@ -451,7 +499,7 @@ ...@@ -451,7 +499,7 @@
(let ((losers *empty-type*)) (let ((losers *empty-type*))
(dolist (ctype call-types) (dolist (ctype call-types)
(multiple-value-bind (int win) (multiple-value-bind (int win)
(funcall *test-function* ctype decl-type) (funcall *test-function* ctype decl-type)
(cond (cond
((not win) ((not win)
(note-slime "Can't tell whether previous ~? argument type ~S is a ~S." (note-slime "Can't tell whether previous ~? argument type ~S is a ~S."
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment