- (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)))))
+ (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)))))
- (let* ((name (lvar-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* ((name (lvar-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)))))))))
- (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))))))))
- (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)))
+ (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)))
- (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))))))))))))
+ (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))))))))))))
- (*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)))
+ (*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)
(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)
(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 *ctype-test-fun* ctype decl-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 *ctype-test-fun* ctype decl-type)
- (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))))
- (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)))))))
- (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 (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))))
(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))
(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))
(unless (fun-type-p type)
(return-from assert-definition-type t))
(let ((*lossage-detected* nil))
(multiple-value-bind (vars types)
(unless (fun-type-p type)
(return-from assert-definition-type t))
(let ((*lossage-detected* nil))
(multiple-value-bind (vars types)