diff --git a/compiler/ctype.lisp b/compiler/ctype.lisp
index 722b75f89de6c647aae5efaf9f51ab39262c1a3b..2f8bfdb71789e3239c716ad256cced9e48d4baf2 100644
--- a/compiler/ctype.lisp
+++ b/compiler/ctype.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ctype.lisp,v 1.18 1991/05/08 17:52:01 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ctype.lisp,v 1.19 1991/05/16 16:37:27 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -749,6 +749,7 @@
 (defun assert-definition-type
        (functional type &key (really-assert t)
 		   ((:error-function *error-function*) #'compiler-warning)
+		   warning-function
 		   (where "declaration"))
   (declare (type functional functional) (type function *error-function*)
 	   (string where))
@@ -779,8 +780,15 @@
 	  (when atype
 	    (assert-continuation-type (return-result return) atype))
 	  (loop for var in vars and type in types do
-	    (unless (basic-var-sets var)
-	      (setf (leaf-type var) type)
-	      (dolist (ref (leaf-refs var))
-		(derive-node-type ref type))))
+	    (cond ((basic-var-sets var)
+		   (when warning-function
+		     (funcall warning-function
+			      "Assignment to argument: ~S~%  ~
+			       prevents use of assertion from function ~
+			       type ~A:~%  ~S~%"
+			      (leaf-name var) where (type-specifier type))))
+		  (t
+		   (setf (leaf-type var) type)
+		   (dolist (ref (leaf-refs var))
+		     (derive-node-type ref type)))))
 	  t))))))