X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fctype.lisp;h=043a52a3fe6049d2d9671a38aa8ee5c6954f0cf4;hb=be9eb6c67b5f43a095c3de17bea945c309d662e4;hp=b9bd2c475061b6f70a0b6dfaa46f2ec41ff8e3bf;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git

diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp
index b9bd2c4..043a52a 100644
--- a/src/compiler/ctype.lisp
+++ b/src/compiler/ctype.lisp
@@ -11,6 +11,11 @@
 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
 ;;;; files for more information.
 
+;;;; FIXME: This is a poor name for this file, since CTYPE is the name
+;;;; of the type used internally to represent Lisp types. It'd
+;;;; probably be good to rename this file to "call-type.lisp" or
+;;;; "ir1-type.lisp" or something.
+
 (in-package "SB!C")
 
 ;;; These are the functions that are to be called when a problem is
@@ -18,6 +23,15 @@
 ;;; 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*)
 
@@ -30,12 +44,22 @@
 (declaim (type (or function null) *error-function* *warning-function
 	       *test-function*))
 
-;;; *LOSSAGE-DETECTED* is set when a definite incompatibility is
+;;; *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.
+;;;
+;;; KLUDGE: Common Lisp is a dynamic language, even if CMU CL was not.
+;;; As far as I can see, none of the "definite incompatibilities"
+;;; detected in this file are actually definite under the ANSI spec.
+;;; They would be incompatibilites if the use were within the same
+;;; compilation unit as the contradictory definition (as per the spec
+;;; section "3.2.2.3 Semantic Constraints") but the old Python code
+;;; doesn't keep track of whether that's the case. So until/unless we
+;;; 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
+;;; FIXME: "SLIME" is vivid and concise, but "DEFINITE-CALL-LOSSAGE" and
 ;;; "POSSIBLE-CALL-LOSSAGE" would be more mnemonic.
 
 ;;; Signal a warning if appropriate and set *LOSSAGE-DETECTED*.
@@ -59,7 +83,7 @@
 ;;;; function type inference and declarations.
 
 ;;; A dummy version of SUBTYPEP useful when we want a functional like
-;;; subtypep that always returns true.
+;;; SUBTYPEP that always returns true.
 (defun always-subtypep (type1 type2)
   (declare (ignore type1 type2))
   (values t t))
@@ -70,20 +94,20 @@
 ;;;    NIL, T: the call is definitely invalid.
 ;;;    NIL, NIL: unable to determine whether the call is valid.
 ;;;
-;;; The Argument-Test function is used to determine whether an
+;;; The ARGUMENT-TEST function is used to determine whether an
 ;;; argument type matches the type we are checking against. Similarly,
-;;; the Result-Test is used to determine whether the result type
+;;; the RESULT-TEST is used to determine whether the result type
 ;;; 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. 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.
 ;;;
 ;;; 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
+;;; 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)
@@ -92,21 +116,21 @@
 				((:error-function *error-function*))
 				((:warning-function *warning-function*)))
   (declare (type function result-test) (type combination call)
-	   (type function-type type))
+	   (type fun-type type))
   (let* ((*lossage-detected* nil)
 	 (*slime-detected* nil)
 	 (*compiler-error-context* call)
 	 (args (combination-args call))
 	 (nargs (length args))
-	 (required (function-type-required type))
+	 (required (fun-type-required type))
 	 (min-args (length required))
-	 (optional (function-type-optional type))
+	 (optional (fun-type-optional type))
 	 (max-args (+ min-args (length optional)))
-	 (rest (function-type-rest type))
-	 (keyp (function-type-keyp type)))
+	 (rest (fun-type-rest type))
+	 (keyp (fun-type-keyp type)))
 
     (cond
-     ((function-type-wild-args type)
+     ((fun-type-wild-args type)
       (do ((i 1 (1+ i))
 	   (arg args (cdr arg)))
 	  ((null arg))
@@ -133,10 +157,10 @@
      (t
       (check-fixed-and-rest args (append required optional) rest)
       (when keyp
-	(check-keywords args max-args type))))
+	(check-key-args args max-args type))))
 
     (let* ((dtype (node-derived-type call))
-	   (return-type (function-type-returns type))
+	   (return-type (fun-type-returns type))
 	   (cont (node-cont call))
 	   (out-type
 	    (if (or (not (continuation-type-check cont))
@@ -157,8 +181,8 @@
 	  (*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
+;;; 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
@@ -171,13 +195,12 @@
     (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))
+	       (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))
+	       (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)
@@ -218,12 +241,12 @@
     (check-arg-type (car arg) (car type) n))
   (values))
 
-;;; Check that the keyword args are of the correct type. Each keyword
-;;; should be known and the corresponding argument should be of the
-;;; correct type. If the keyword isn't a constant, then we can't tell,
-;;; so we note slime.
-(declaim (ftype (function (list fixnum function-type) (values)) check-keywords))
-(defun check-keywords (args pre-key type)
+;;; 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.
+(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))
@@ -236,10 +259,10 @@
 		    n))
        (t
 	(let* ((name (continuation-value k))
-	       (info (find name (function-type-keywords type)
+	       (info (find name (fun-type-keywords type)
 			   :key #'key-info-name)))
 	  (cond ((not info)
-		 (unless (function-type-allowp type)
+		 (unless (fun-type-allowp type)
 		   (note-lossage "~S is not a known argument keyword."
 				 name)))
 		(t
@@ -251,10 +274,10 @@
 ;;;
 ;;; Due to the lack of a (LIST X) type specifier, we can't reconstruct
 ;;; the &REST type.
-(declaim (ftype (function (functional) function-type) definition-type))
+(declaim (ftype (function (functional) fun-type) definition-type))
 (defun definition-type (functional)
   (if (lambda-p functional)
-      (make-function-type
+      (make-fun-type
        :required (mapcar #'leaf-type (lambda-vars functional))
        :returns (tail-set-type (lambda-tail-set functional)))
       (let ((rest nil))
@@ -269,14 +292,14 @@
 		    (:required (req type))
 		    (:optional (opt type))
 		    (:keyword
-		     (keys (make-key-info :name (arg-info-keyword info)
+		     (keys (make-key-info :name (arg-info-key info)
 					  :type type)))
 		    ((:rest :more-context)
 		     (setq rest *universal-type*))
 		    (:more-count))
 		  (req type))))
 
-	  (make-function-type
+	  (make-fun-type
 	   :required (req)
 	   :optional (opt)
 	   :rest rest
@@ -299,42 +322,44 @@
 ;;;; proclamation, we can check the actual type for compatibity with the
 ;;;; previous uses.
 
-(defstruct (approximate-function-type)
-  ;; The smallest and largest numbers of arguments that this function has been
-  ;; called with.
-  (min-args call-arguments-limit :type fixnum)
+(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)
-  ;; A list of lists of the all the types that have been used in each argument
-  ;; position.
+  ;; a list of lists of the all the types that have been used in each
+  ;; argument position
   (types () :type list)
-  ;; A list of the Approximate-Key-Info structures describing all the things
-  ;; that looked like keyword arguments. There are distinct structures
-  ;; describing each argument position in which the keyword appeared.
+  ;; A list of APPROXIMATE-KEY-INFO structures describing all the
+  ;; things that looked like &KEY arguments. There are distinct
+  ;; structures describing each argument position in which the keyword
+  ;; appeared.
   (keys () :type list))
 
-(defstruct (approximate-key-info)
-  ;; The keyword name of this argument. Although keyword names don't have to
-  ;; be keywords, we only match on keywords when figuring an approximate type.
+(defstruct (approximate-key-info (:copier nil))
+  ;; The keyword name of this argument. Although keyword names don't
+  ;; have to be keywords, we only match on keywords when figuring an
+  ;; approximate type.
   (name (required-argument) :type keyword)
   ;; The position at which this keyword appeared. 0 if it appeared as the
   ;; first argument, etc.
   (position (required-argument) :type fixnum)
-  ;; A list of all the argument types that have been used with this keyword.
+  ;; 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
-  ;; :allow-other-keys.
+  ;; true if this keyword has appeared only in calls with an obvious
+  ;; :ALLOW-OTHER-KEYS
   (allowp nil :type (member t nil)))
 
-;;; Return an Approximate-Function-Type representing the context of
-;;; Call. If Type is supplied and not null, then we merge the
-;;; information into the information already accumulated in Type.
+;;; Return an APPROXIMATE-FUN-TYPE representing the context of
+;;; 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-function-type null))
-			  approximate-function-type)
+			   &optional (or approximate-fun-type null))
+			  approximate-fun-type)
 		note-function-use))
 (defun note-function-use (call &optional type)
-  (let* ((type (or type (make-approximate-function-type)))
-	 (types (approximate-function-type-types 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)
@@ -342,15 +367,15 @@
 				(eq (continuation-value x) :allow-other-keys)))
 			  args)))
 
-    (setf (approximate-function-type-min-args type)
-	  (min (approximate-function-type-min-args type) nargs))
-    (setf (approximate-function-type-max-args type)
-	  (max (approximate-function-type-max-args type) nargs))
+    (setf (approximate-fun-type-min-args type)
+	  (min (approximate-fun-type-min-args type) nargs))
+    (setf (approximate-fun-type-max-args type)
+	  (max (approximate-fun-type-max-args type) nargs))
 
     (do ((old types (cdr old))
 	 (arg args (cdr arg)))
 	((null old)
-	 (setf (approximate-function-type-types type)
+	 (setf (approximate-fun-type-types type)
 	       (nconc types
 		      (mapcar #'(lambda (x)
 				  (list (continuation-type x)))
@@ -360,11 +385,11 @@
 	       (car old)
 	       :test #'type=))
 
-    (collect ((keys (approximate-function-type-keys type) cons))
+    (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-function-type-keys type) (keys)))
+	   (setf (approximate-fun-type-keys type) (keys)))
 	(let ((key (first arg))
 	      (val (second arg)))
 	  (when (constant-continuation-p key)
@@ -391,44 +416,48 @@
 				:types (list val-type))))))))))))
     type))
 
-;;; Similar to Valid-Function-Use, but checks an
-;;; Approximate-Function-Type against a real function type.
-(declaim (ftype (function (approximate-function-type function-type
+;;; This is similar to VALID-FUNCTION-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* #'types-intersect)
-					 (*error-function* #'compiler-warning)
+					 (*test-function*
+					  #'types-equal-or-intersect)
+					 (*error-function*
+					  #'compiler-style-warning)
 					 (*warning-function* #'compiler-note))
   (let* ((*lossage-detected* nil)
 	 (*slime-detected* nil)
-	 (required (function-type-required type))
+	 (required (fun-type-required type))
 	 (min-args (length required))
-	 (optional (function-type-optional type))
+	 (optional (fun-type-optional type))
 	 (max-args (+ min-args (length optional)))
-	 (rest (function-type-rest type))
-	 (keyp (function-type-keyp type)))
+	 (rest (fun-type-rest type))
+	 (keyp (fun-type-keyp type)))
 
-    (when (function-type-wild-args type)
+    (when (fun-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-fun-type-min-args call-type)))
       (when (< call-min min-args)
 	(note-lossage
-	 "Function previously called with ~R argument~:P, but wants at least ~R."
+	 "~:@<The function was previously called with ~R argument~:P, ~
+          but wants at least ~R.~:>"
 	 call-min min-args)))
 
-    (let ((call-max (approximate-function-type-max-args call-type)))
+    (let ((call-max (approximate-fun-type-max-args call-type)))
       (cond ((<= call-max max-args))
 	    ((not (or keyp rest))
 	     (note-lossage
-	      "Function previously called with ~R argument~:P, but wants at most ~R."
+	      "~:@<The function was previously called with ~R argument~:P, ~
+                but wants at most ~R.~:>"
 	      call-max max-args))
 	    ((and keyp (oddp (- call-max max-args)))
 	     (note-lossage
-	      "Function previously called with an odd number of arguments in ~
-	      the keyword portion.")))
+	      "~:@<The function was previously called with an odd number of ~
+               arguments in the keyword portion.~:>")))
 
       (when (and keyp (> call-max max-args))
 	(check-approximate-keywords call-type max-args type)))
@@ -442,11 +471,11 @@
 
 ;;; Check that each of the types used at each arg position is
 ;;; compatible with the actual type.
-(declaim (ftype (function (approximate-function-type list (or ctype null))
+(declaim (ftype (function (approximate-fun-type list (or ctype null))
 			  (values))
 		check-approximate-fixed-and-rest))
 (defun check-approximate-fixed-and-rest (call-type fixed rest)
-  (do ((types (approximate-function-type-types call-type) (cdr types))
+  (do ((types (approximate-fun-type-types call-type) (cdr types))
        (n 1 (1+ n))
        (arg fixed (cdr arg)))
       ((null types))
@@ -455,7 +484,7 @@
       (check-approximate-arg-type (car types) decl-type "~:R" n)))
   (values))
 
-;;; Check that each of the call-types is compatible with Decl-Type,
+;;; 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))
@@ -479,12 +508,12 @@
 ;;; argument position. Check the validity of all keys that appeared in
 ;;; valid keyword positions.
 ;;;
-;;; ### We could check the Approximate-Function-Type-Types to make
+;;; ### We could check the APPROXIMATE-FUN-TYPE-TYPES to make
 ;;; sure that all arguments in keyword positions were manifest
 ;;; keywords.
 (defun check-approximate-keywords (call-type max-args type)
-  (let ((call-keys (approximate-function-type-keys call-type))
-	(keys (function-type-keywords type)))
+  (let ((call-keys (approximate-fun-type-keys call-type))
+	(keys (fun-type-keywords type)))
     (dolist (key keys)
       (let ((name (key-info-name key)))
 	(collect ((types nil append))
@@ -495,7 +524,7 @@
 		(types (approximate-key-info-types call-key)))))
 	  (check-approximate-arg-type (types) (key-info-type key) "~S" name))))
 
-    (unless (function-type-allowp type)
+    (unless (fun-type-allowp type)
       (collect ((names () adjoin))
 	(dolist (call-key call-keys)
 	  (let ((pos (approximate-key-info-position call-key)))
@@ -510,25 +539,25 @@
 
 ;;;; ASSERT-DEFINITION-TYPE
 
-;;; Intersect Lambda's var types with Types, giving a warning if there
+;;; Intersect LAMBDA's var types with TYPES, giving a warning if there
 ;;; is a mismatch. If all intersections are non-null, we return lists
 ;;; of the variables and intersections, otherwise we return NIL, NIL.
 (defun try-type-intersections (vars types where)
   (declare (list vars types) (string where))
   (collect ((res))
-    (mapc #'(lambda (var type)
-	      (let* ((vtype (leaf-type var))
-		     (int (type-intersection vtype type)))
-		(cond
-		 ((eq int *empty-type*)
-		  (note-lossage
-		   "Definition's declared type for variable ~A:~%  ~S~@
+    (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-name var) (type-specifier vtype)
-		   where (type-specifier type))
-		  (return-from try-type-intersections (values nil nil)))
-		 (t
-		  (res int)))))
+		 (leaf-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))))
 
@@ -539,7 +568,7 @@
 ;;; Note that the variables in the returned list are the actual
 ;;; original variables (extracted from the optional dispatch arglist),
 ;;; rather than the variables that are arguments to the main entry.
-;;; This difference is significant only for keyword args with hairy
+;;; This difference is significant only for &KEY args with hairy
 ;;; defaults. Returning the actual vars allows us to use the right
 ;;; variable name in warnings.
 ;;;
@@ -558,39 +587,40 @@
 ;;; unioning in NULL, and not totally blow off doing any type
 ;;; assertion.
 (defun find-optional-dispatch-types (od type where)
-  (declare (type optional-dispatch od) (type function-type type)
+  (declare (type optional-dispatch od)
+	   (type fun-type type)
 	   (string where))
   (let* ((min (optional-dispatch-min-args od))
-	 (req (function-type-required type))
-	 (opt (function-type-optional type)))
+	 (req (fun-type-required type))
+	 (opt (fun-type-optional type)))
     (flet ((frob (x y what)
 	     (unless (= x y)
 	       (note-lossage
-		"Definition has ~R ~A arg~P, but ~A has ~R."
+		"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
-		"Definition ~:[doesn't have~;has~] ~A, but ~
+		"The definition ~:[doesn't have~;has~] ~A, but ~
 		~A ~:[doesn't~;does~]."
 		x what where y))))
-      (frob (optional-dispatch-keyp od) (function-type-keyp type)
-	    "keyword args")
+      (frob (optional-dispatch-keyp od) (fun-type-keyp type)
+	    "&KEY arguments")
       (unless (optional-dispatch-keyp od)
 	(frob (not (null (optional-dispatch-more-entry od)))
-	      (not (null (function-type-rest type)))
-	      "rest args"))
-      (frob (optional-dispatch-allowp od) (function-type-allowp type)
-	    "&allow-other-keys"))
+	      (not (null (fun-type-rest type)))
+	      "&REST arguments"))
+      (frob (optional-dispatch-allowp od) (fun-type-allowp type)
+	    "&ALLOW-OTHER-KEYS"))
 
     (when *lossage-detected*
       (return-from find-optional-dispatch-types (values nil nil)))
 
     (collect ((res)
 	      (vars))
-      (let ((keys (function-type-keywords type))
+      (let ((keys (fun-type-keywords type))
 	    (arglist (optional-dispatch-arglist od)))
 	(dolist (arg arglist)
 	  (cond
@@ -601,7 +631,7 @@
 			       (ctype-of (eval default)))))
 	      (ecase (arg-info-kind info)
 		(:keyword
-		 (let* ((key (arg-info-keyword info))
+		 (let* ((key (arg-info-key info))
 			(kinfo (find key keys :key #'key-info-name)))
 		   (cond
 		    (kinfo
@@ -616,13 +646,13 @@
 		(:optional
 		 (res (type-union (pop opt) (or def-type *universal-type*))))
 		(:rest
-		 (when (function-type-rest type)
+		 (when (fun-type-rest type)
 		   (res (specifier-type 'list))))
 		(:more-context
-		 (when (function-type-rest type)
+		 (when (fun-type-rest type)
 		   (res *universal-type*)))
 		(:more-count
-		 (when (function-type-rest type)
+		 (when (fun-type-rest type)
 		   (res (specifier-type 'fixnum)))))
 	      (vars arg)
 	      (when (arg-info-supplied-p info)
@@ -637,9 +667,9 @@
 			:key #'(lambda (x)
 				 (let ((info (lambda-var-arg-info x)))
 				   (when info
-				     (arg-info-keyword info)))))
+				     (arg-info-key info)))))
 	    (note-lossage
-	     "Definition lacks the ~S keyword present in ~A."
+	     "The definition lacks the ~S key present in ~A."
 	     (key-info-name key) where))))
 
       (try-type-intersections (vars) (res) where))))
@@ -647,61 +677,64 @@
 ;;; 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 function-type type) (string where))
+  (declare (type clambda lambda) (type fun-type type) (string where))
   (flet ((frob (x what)
 	   (when x
 	     (note-lossage
-	      "Definition has no ~A, but the ~A did."
+	      "The definition has no ~A, but the ~A did."
 	      what where))))
-    (frob (function-type-optional type) "optional args")
-    (frob (function-type-keyp type) "keyword args")
-    (frob (function-type-rest type) "rest arg"))
+    (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 (function-type-required type))
+	 (req (fun-type-required type))
 	 (nreq (length req)))
     (unless (= nvars nreq)
-      (note-lossage "Definition has ~R arg~:P, but the ~A has ~R."
+      (note-lossage "The definition has ~R arg~:P, but the ~A has ~R."
 		    nvars where nreq))
     (if *lossage-detected*
 	(values nil nil)
 	(try-type-intersections vars req where))))
 
 ;;; Check for syntactic and type conformance between the definition
-;;; Functional and the specified Function-Type. If they are compatible
-;;; and Really-Assert is T, then add type assertions to the definition
-;;; from the Function-Type.
+;;; FUNCTIONAL and the specified FUN-TYPE. If they are compatible
+;;; and REALLY-ASSERT is T, then add type assertions to the definition
+;;; 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
-;;; describing where Function-Type came from.
+;;; ERROR-FUNCTION 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
+;;; 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-warning)
+		   ((:error-function *error-function*)
+		    #'compiler-style-warning)
 		   warning-function
 		   (where "previous declaration"))
   (declare (type functional functional)
 	   (type function *error-function*)
 	   (string where))
-  (unless (function-type-p type) (return-from assert-definition-type t))
+  (unless (fun-type-p type)
+    (return-from assert-definition-type t))
   (let ((*lossage-detected* nil))
     (multiple-value-bind (vars types)
-	(if (function-type-wild-args type)
+	(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 (function-type-returns type))
+      (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-intersect atype type-returns)))
+	 ((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"