diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp
index 89957c7ab..6514cbc4a 100644
--- a/src/pcl/ctor.lisp
+++ b/src/pcl/ctor.lisp
@@ -493,14 +493,14 @@
 		 ((integerp location)
 		  (not (null (aref slot-vector location))))
 		 (t (bug "Weird location in ~S" 'slot-init-forms))))
-	     (class-init (location type val)
+	     (class-init (location kind val type)
 	       (aver (consp location))
 	       (unless (initializedp location)
-		 (push (list location type val) class-inits)))
-	     (instance-init (location type val)
+		 (push (list location kind val type) class-inits)))
+	     (instance-init (location kind val type)
 	       (aver (integerp location))
 	       (unless (initializedp location)
-		 (setf (aref slot-vector location) (list type val))))
+		 (setf (aref slot-vector location) (list kind val type))))
 	     (default-init-var-name (i)
 	       (let ((ps #(.d0. .d1. .d2. .d3. .d4. .d5.)))
 		 (if (array-in-bounds-p ps i)
@@ -509,16 +509,12 @@
       ;; Loop over supplied initargs and values and record which
       ;; instance and class slots they initialize.
       (loop for (key value) on initargs by #'cddr
-	    as locations = (initarg-locations key) do
-	      (if (constantp value)
-		  (dolist (location locations)
-		    (if (consp location)
-			(class-init location 'constant value)
-			(instance-init location 'constant value)))
-		  (dolist (location locations)
-		      (if (consp location)
-			  (class-init location 'param value)
-			  (instance-init location 'param value)))))
+	    as kind = (if (constantp value) 'constant 'param)
+	    as locations = (initarg-locations key)
+	    do (loop for (location . type) in locations
+		     do (if (consp location)
+			    (class-init location kind value type)
+			    (instance-init location kind value type))))
       ;; Loop over default initargs of the class, recording
       ;; initializations of slots that have not been initialized
       ;; above.  Default initargs which are not in the supplied
@@ -527,27 +523,28 @@
       ;; if not actually used for initializing a slot.
       (loop for (key initfn initform) in default-initargs and i from 0
 	    unless (member key initkeys :test #'eq) do
-	    (let* ((type (if (constantp initform) 'constant 'var))
-		   (init (if (eq type 'var) initfn initform)))
-              (ecase type
+	    (let* ((kind (if (constantp initform) 'constant 'var))
+		   (init (if (eq kind 'var) initfn initform)))
+              (ecase kind
                 (constant
                  (push key defaulting-initargs)
                  (push initform defaulting-initargs))
                 (var
                  (push key defaulting-initargs)
                  (push (default-init-var-name i) defaulting-initargs)))
-	      (when (eq type 'var)
+	      (when (eq kind 'var)
 		(let ((init-var (default-init-var-name i)))
 		  (setq init init-var)
 		  (push (cons init-var initfn) default-inits)))
-	      (dolist (location (initarg-locations key))
-		(if (consp location)
-		    (class-init location type init)
-		    (instance-init location type init)))))
+	      (loop for (location . type) in (initarg-locations key)
+		    do (if (consp location)
+			   (class-init location kind init type)
+			   (instance-init location kind init type)))))
       ;; Loop over all slots of the class, filling in the rest from
       ;; slot initforms.
       (loop for slotd in (class-slots class)
 	    as location = (slot-definition-location slotd)
+	    as type = (slot-definition-type slotd)
 	    as allocation = (slot-definition-allocation slotd)
 	    as initfn = (slot-definition-initfunction slotd)
 	    as initform = (slot-definition-initform slotd) do
@@ -555,45 +552,57 @@
 			  (null initfn)
 			  (initializedp location))
 		(if (constantp initform)
-		    (instance-init location 'initform initform)
-		    (instance-init location 'initform/initfn initfn))))
+		    (instance-init location 'initform initform type)
+		    (instance-init location 'initform/initfn initfn type))))
       ;; Generate the forms for initializing instance and class slots.
       (let ((instance-init-forms
 	     (loop for slot-entry across slot-vector and i from 0
-		   as (type value) = slot-entry collect
-		     (ecase type
+		   as (kind value type) = slot-entry collect
+		     (ecase kind
 		       ((nil)
 			(unless before-method-p
 			  `(setf (clos-slots-ref .slots. ,i) +slot-unbound+)))
 		       ((param var)
-			`(setf (clos-slots-ref .slots. ,i) ,value))
+			`(setf (clos-slots-ref .slots. ,i)
+			       (locally (declare (optimize (safety 3)))
+				 (the ,type ,value))))
 		       (initfn
-			`(setf (clos-slots-ref .slots. ,i) (funcall ,value)))
+			`(setf (clos-slots-ref .slots. ,i)
+			       (locally (declare (optimize (safety 3)))
+				 (the ,type (funcall ,value)))))
 		       (initform/initfn
 			(if before-method-p
 			    `(when (eq (clos-slots-ref .slots. ,i)
 				       +slot-unbound+)
 			       (setf (clos-slots-ref .slots. ,i)
-				     (funcall ,value)))
+				     (locally (declare (optimize (safety 3)))
+				       (the ,type (funcall ,value)))))
 			    `(setf (clos-slots-ref .slots. ,i)
-			           (funcall ,value))))
+			           (locally (declare (optimize (safety 3)))
+				     (the ,type (funcall ,value))))))
 		       (initform
 			(if before-method-p
 			    `(when (eq (clos-slots-ref .slots. ,i)
 				       +slot-unbound+)
 			       (setf (clos-slots-ref .slots. ,i)
-				     ',(eval value)))
+				     (locally (declare (optimize (safety 3)))
+				       (the ,type ',(eval value)))))
 			    `(setf (clos-slots-ref .slots. ,i)
-			           ',(eval value))))
+			           (locally (declare (optimize (safety 3)))
+				     (the ,type ',(eval value))))))
 		       (constant
-			`(setf (clos-slots-ref .slots. ,i) ',(eval value))))))
+			`(setf (clos-slots-ref .slots. ,i)
+			       (locally (declare (optimize (safety 3)))
+				 (the ,type ',(eval value))))))))
 	    (class-init-forms
-	     (loop for (location type value) in class-inits collect
+	     (loop for (location kind value type) in class-inits collect
 		     `(setf (cdr ',location)
-			    ,(ecase type
-			       (constant `',(eval value))
-			       ((param var) `,value)
-			       (initfn `(funcall ,value)))))))
+		            (locally (declare (optimize (safety 3)))
+			      (the ,type 
+				,(ecase kind
+				   (constant `',(eval value))
+				   ((param var) `,value)
+				   (initfn `(funcall ,value)))))))))
 	(multiple-value-bind (vars bindings)
 	    (loop for (var . initfn) in (nreverse default-inits)
 		  collect var into vars
@@ -603,15 +612,18 @@
                   `(,@(delete nil instance-init-forms)
                     ,@class-init-forms)))))))
 
-;;; Return an alist of lists (KEY LOCATION ...) telling, for each
-;;; key in INITKEYS, which locations the initarg initializes.
-;;; CLASS is the class of the instance being initialized.
+;;; Return an alist of lists (KEY (LOCATION . TYPE-SPECIFIER) ...)
+;;; telling, for each key in INITKEYS, which locations the initarg
+;;; initializes and the associated type with the location.  CLASS is
+;;; the class of the instance being initialized.
 (defun compute-initarg-locations (class initkeys)
   (loop with slots = (class-slots class)
 	for key in initkeys collect
 	  (loop for slot in slots
 		if (memq key (slot-definition-initargs slot))
-		  collect (slot-definition-location slot) into locations
+		  collect (cons (slot-definition-location slot)
+				(slot-definition-type slot))
+		          into locations
 		else
 		  collect slot into remaining-slots
 		finally
diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp
index 2b84a1856..69e03e8ac 100644
--- a/src/pcl/dfun.lisp
+++ b/src/pcl/dfun.lisp
@@ -906,7 +906,11 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 		    (if (consp method)
 			(eq *the-class-standard-writer-method*
 			    (early-method-class method))
-			(standard-writer-method-p method)))
+			(and
+			 (standard-writer-method-p method)
+			 (eq (slot-definition-type
+			      (accessor-method-slot-definition method))
+			     t))))
 		  methods)
 	   'writer))))
 
@@ -1282,7 +1286,9 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 			 (find-slot-definition accessor-class slot-name)))))
     (when (and slotd
 	       (or early-p
-		   (slot-accessor-std-p slotd accessor-type)))
+		   (slot-accessor-std-p slotd accessor-type))
+	       (or early-p
+		   (eq (slot-definition-type slotd) t)))
       (values (if early-p
 		  (early-slot-definition-location slotd)
 		  (slot-definition-location slotd))
diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp
index dc7b804b2..f165e35e9 100644
--- a/src/pcl/slots-boot.lisp
+++ b/src/pcl/slots-boot.lisp
@@ -236,28 +236,51 @@
 (defun make-optimized-std-writer-method-function
     (fsc-p slotd slot-name location)
   (declare #.*optimize-speed*)
-  (set-fun-name
-   (etypecase location
-     (fixnum (if fsc-p
+  (let ((type (or (not slotd) (slot-definition-type slotd))))
+    (set-fun-name
+     (etypecase location
+       (fixnum (if fsc-p
+		   (if (eq type t)
+		       (lambda (nv instance)
+			 (check-obsolete-instance instance)
+			 (setf (clos-slots-ref (fsc-instance-slots instance)
+					       location)
+			       nv))
+		       (lambda (nv instance)
+			 (check-obsolete-instance instance)
+			 (unless (typep nv type)
+			   (error 'type-error :datum nv :expected-type type))
+			 (setf (clos-slots-ref (fsc-instance-slots instance)
+					       location)
+			       nv)))
+		   (if (eq type t)
+		       (lambda (nv instance)
+			 (check-obsolete-instance instance)
+			 (setf (clos-slots-ref (std-instance-slots instance)
+					       location)
+			       nv))
+		       (lambda (nv instance)
+			 (check-obsolete-instance instance)
+			 (unless (typep nv type)
+			   (error 'type-error :datum nv :expected-type type))
+			 (setf (clos-slots-ref (std-instance-slots instance)
+					       location)
+			       nv)))))
+       (cons (if (eq type t)
 		 (lambda (nv instance)
 		   (check-obsolete-instance instance)
-		   (setf (clos-slots-ref (fsc-instance-slots instance)
-					 location)
-			 nv))
+		   (setf (cdr location) nv))
 		 (lambda (nv instance)
 		   (check-obsolete-instance instance)
-		   (setf (clos-slots-ref (std-instance-slots instance)
-					 location)
-			 nv))))
-     (cons (lambda (nv instance)
-	     (check-obsolete-instance instance)
-	     (setf (cdr location) nv)))
-     (null
-      (lambda (nv instance)
-	(declare (ignore nv))
-	(instance-structure-protocol-error slotd
-					   '(setf slot-value-using-class)))))
-   `(writer ,slot-name)))
+		   (unless (typep nv type)
+		     (error 'type-error :datum nv :expected-type type))
+		   (setf (cdr location) nv))))
+       (null
+	(lambda (nv instance)
+	  (declare (ignore nv))
+	  (instance-structure-protocol-error slotd
+					     '(setf slot-value-using-class)))))
+     `(writer ,slot-name))))
 
 (defun make-optimized-std-boundp-method-function
     (fsc-p slotd slot-name location)
@@ -385,24 +408,51 @@
 (defun make-optimized-std-setf-slot-value-using-class-method-function
     (fsc-p slotd)
   (declare #.*optimize-speed*)
-  (let ((location (slot-definition-location slotd)))
+  (let ((location (slot-definition-location slotd))
+	(type (slot-definition-type slotd)))
     (etypecase location
       (fixnum
        (if fsc-p
-	   (lambda (nv class instance slotd)
-	     (declare (ignore class slotd))
-	     (check-obsolete-instance instance)
-	     (setf (clos-slots-ref (fsc-instance-slots instance) location)
-		   nv))
-	   (lambda (nv class instance slotd)
-	     (declare (ignore class slotd))
-	     (check-obsolete-instance instance)
-	     (setf (clos-slots-ref (std-instance-slots instance) location)
-		   nv))))
-      (cons (lambda (nv class instance slotd)
-	      (declare (ignore class slotd))
-	      (check-obsolete-instance instance)
-	      (setf (cdr location) nv)))
+	   (if (eq type t)
+	       (lambda (nv class instance slotd)
+		 (declare (ignore class slotd))
+		 (check-obsolete-instance instance)
+		 (setf (clos-slots-ref (fsc-instance-slots instance) location)
+		       nv))
+	       (lambda (nv class instance slotd)
+		 (declare (ignore class slotd))
+		 (check-obsolete-instance instance)
+		 ;; FIXME: this is going to make a mockery of the
+		 ;; "optimized" bit.  Full call to typep on every slot
+		 ;; write?  Still, let's see if it works...
+		 (unless (typep nv type)
+		   (error 'type-error :datum nv :expected-type type))
+		 (setf (clos-slots-ref (fsc-instance-slots instance) location)
+		       nv)))
+	   (if (eq type t)
+	       (lambda (nv class instance slotd)
+		 (declare (ignore class slotd))
+		 (check-obsolete-instance instance)
+		 (setf (clos-slots-ref (std-instance-slots instance) location)
+		       nv))
+	       (lambda (nv class instance slotd)
+		 (declare (ignore class slotd))
+		 (check-obsolete-instance instance)
+		 (unless (typep nv type)
+		   (error 'type-error :datum nv :expected-type type))
+		 (setf (clos-slots-ref (std-instance-slots instance) location)
+		       nv)))))
+      (cons (if (eq type t)
+		(lambda (nv class instance slotd)
+		  (declare (ignore class slotd))
+		  (check-obsolete-instance instance)
+		  (setf (cdr location) nv))
+		(lambda (nv class instance slotd)
+		  (declare (ignore class slotd))
+		  (check-obsolete-instance instance)
+		  (unless (typep nv type)
+		    (error 'type-error :datum nv :expected-type type))
+		  (setf (cdr location) nv))))
       (null (lambda (nv class instance slotd)
 	      (declare (ignore nv class instance))
 	      (instance-structure-protocol-error
@@ -499,15 +549,32 @@
 
 (defun make-std-writer-method-function (class-name slot-name)
   (let* ((pv-table-symbol (gensym))
+	 (type (or (not (eq *boot-state* 'complete))
+		   (let ((slotd (find-slot-definition (find-class class-name) slot-name)))
+		     (or (not slotd) (slot-definition-type slotd)))))
+	 ;; FIXME: how expensive is this?
+	 (typecheckfun (lambda (nv) (unless (typep nv type)
+				      (error 'type-error
+					     :datum nv :expected-type type))))
 	 (initargs (copy-tree
-		    (make-method-function
-		     (lambda (nv instance)
-		       (pv-binding1 (.pv. .calls.
-					  (symbol-value pv-table-symbol)
-					  (instance) (instance-slots))
-			 (instance-write-internal
-			  .pv. instance-slots 1 nv
-			  (setf (slot-value instance slot-name) nv))))))))
+		    (if (eq type t)
+			(make-method-function
+			 (lambda (nv instance)
+			   (pv-binding1 (.pv. .calls.
+					      (symbol-value pv-table-symbol)
+					      (instance) (instance-slots))
+					(instance-write-internal
+					 .pv. instance-slots 1 nv
+					 (setf (slot-value instance slot-name) nv)))))
+			(make-method-function
+			 (lambda (nv instance)
+			   (funcall typecheckfun nv)
+			   (pv-binding1 (.pv. .calls.
+					      (symbol-value pv-table-symbol)
+					      (instance) (instance-slots))
+					(instance-write-internal
+					 .pv. instance-slots 1 nv
+					 (setf (slot-value instance slot-name) nv)))))))))
     (setf (getf (getf initargs :plist) :slot-name-lists)
 	  (list nil (list nil slot-name)))
     (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp
index 24de706ea..92e2890fc 100644
--- a/src/pcl/slots.lisp
+++ b/src/pcl/slots.lisp
@@ -179,22 +179,30 @@
 		      (object std-object)
 		      (slotd standard-effective-slot-definition))
   (check-obsolete-instance object)
-  (let ((location (slot-definition-location slotd)))
-    (typecase location
-      (fixnum
-       (cond ((std-instance-p object)
-	      (setf (clos-slots-ref (std-instance-slots object) location)
-		    new-value))
-	     ((fsc-instance-p object)
-	      (setf (clos-slots-ref (fsc-instance-slots object) location)
-		    new-value))
-	     (t (bug "unrecognized instance type in ~S"
-		     '(setf slot-value-using-class)))))
-      (cons
-       (setf (cdr location) new-value))
-      (t
-       (instance-structure-protocol-error slotd
-					  '(setf slot-value-using-class))))))
+  (let ((location (slot-definition-location slotd))
+	(type (slot-definition-type slotd)))
+    (flet ((check (new-value type)
+	     (cond
+	       ((eq type t) new-value)
+	       (t (if (typep new-value type)
+		      new-value
+		      (error 'type-error
+			     :datum new-value :expected-type type))))))
+      (typecase location
+	(fixnum
+	 (cond ((std-instance-p object)
+		(setf (clos-slots-ref (std-instance-slots object) location)
+		      (check new-value type)))
+	       ((fsc-instance-p object)
+		(setf (clos-slots-ref (fsc-instance-slots object) location)
+		      (check new-value type)))
+		(t (bug "unrecognized instance type in ~S"
+			'(setf slot-value-using-class)))))
+	(cons
+	 (setf (cdr location) (check new-value type)))
+	(t
+	 (instance-structure-protocol-error
+	  slotd '(setf slot-value-using-class)))))))
 
 (defmethod slot-boundp-using-class
 	   ((class std-class)
diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index 3a6b3b98f..79a7d9474 100644
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -1184,9 +1184,10 @@
   (let ((method (get-method generic-function () (list class) nil)))
     (when method (remove-method generic-function method))))
 
-;;; MAKE-READER-METHOD-FUNCTION and MAKE-WRITE-METHOD function are NOT
-;;; part of the standard protocol. They are however useful, PCL makes
-;;; use of them internally and documents them for PCL users.
+;;; MAKE-READER-METHOD-FUNCTION and MAKE-WRITER-METHOD-FUNCTION
+;;; function are NOT part of the standard protocol. They are however
+;;; useful; PCL makes use of them internally and documents them for
+;;; PCL users.  (FIXME: but SBCL certainly doesn't)
 ;;;
 ;;; *** This needs work to make type testing by the writer functions which
 ;;; *** do type testing faster. The idea would be to have one constructor
diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp
index 9a8f51d4d..f7810d904 100644
--- a/src/pcl/vector.lisp
+++ b/src/pcl/vector.lisp
@@ -655,10 +655,10 @@
 	 (eq *boot-state* 'complete)
 	 (not (slot-accessor-std-p slotd type)))))
 
-(defmacro instance-read-internal (pv slots pv-offset default &optional type)
-  (unless (member type '(nil :instance :class :default))
-    (error "illegal type argument to ~S: ~S" 'instance-read-internal type))
-  (if (eq type :default)
+(defmacro instance-read-internal (pv slots pv-offset default &optional kind)
+  (unless (member kind '(nil :instance :class :default))
+    (error "illegal kind argument to ~S: ~S" 'instance-read-internal kind))
+  (if (eq kind :default)
       default
       (let* ((index (gensym))
 	     (value index))
@@ -676,11 +676,11 @@
 			   ;; to shut it up.  (see also mail Rudi
 			   ;; Schlatte sbcl-devel 2003-09-21) -- CSR,
 			   ;; 2003-11-30
-			   ,@(when (or (null type) (eq type :instance))
+			   ,@(when (or (null kind) (eq kind :instance))
 			       `((fixnum
 				  (and ,slots ; KLUDGE
 				   (clos-slots-ref ,slots ,index)))))
-			   ,@(when (or (null type) (eq type :class))
+			   ,@(when (or (null kind) (eq kind :class))
 			       `((cons (cdr ,index))))
 			   (t +slot-unbound+)))
 	    (if (eq ,value +slot-unbound+)
@@ -703,21 +703,26 @@
     :instance))
 
 (defmacro instance-write-internal (pv slots pv-offset new-value default
-				      &optional type)
-  (unless (member type '(nil :instance :class :default))
-    (error "illegal type argument to ~S: ~S" 'instance-write-internal type))
-  (if (eq type :default)
+				      &optional kind (type t))
+  (unless (member kind '(nil :instance :class :default))
+    (error "illegal kind argument to ~S: ~S" 'instance-write-internal kind))
+  (if (eq kind :default)
       default
       (let* ((index (gensym)))
 	`(locally (declare #.*optimize-speed*)
 	  (let ((,index (pvref ,pv ,pv-offset)))
 	    (typecase ,index
-	      ,@(when (or (null type) (eq type :instance))
+	      ,@(when (or (null kind) (eq kind :instance))
                   `((fixnum (and ,slots
 			     (setf (clos-slots-ref ,slots ,index)
-				   ,new-value)))))
-	      ,@(when (or (null type) (eq type :class))
-		  `((cons (setf (cdr ,index) ,new-value))))
+				   (locally
+				     (declare (optimize (safety 3)))
+				     (the ,type ,new-value)))))))
+	      ,@(when (or (null kind) (eq kind :class))
+		  `((cons (setf (cdr ,index)
+			   (locally
+			     (declare (optimize (safety 3)))
+			     (the ,type ,new-value))))))
 	      (t ,default)))))))
 
 (defmacro instance-write (pv-offset
@@ -732,7 +737,16 @@
 	,pv-offset ,new-value
 	(accessor-set-slot-value ,parameter ,slot-name ,new-value)
 	,(if (generate-fast-class-slot-access-p class slot-name)
-	     :class :instance))))
+	     :class :instance)
+	,(if (and (eq *boot-state* 'complete)
+		  (constantp class)
+		  (constantp slot-name)
+		  (standard-class-p (eval class))
+		  (not (eq (eval class) *the-class-t*)))
+	     (let ((slotd (find-slot-definition (eval class) (eval slot-name))))
+	       (or (not slotd)
+		   (slot-definition-type slotd)))
+	     t))))
 
 (defmacro instance-writer (pv-offset
 			   parameter
@@ -751,20 +765,20 @@
     :instance))
 
 (defmacro instance-boundp-internal (pv slots pv-offset default
-				       &optional type)
-  (unless (member type '(nil :instance :class :default))
-    (error "illegal type argument to ~S: ~S" 'instance-boundp-internal type))
-  (if (eq type :default)
+				       &optional kind)
+  (unless (member kind '(nil :instance :class :default))
+    (error "illegal kind argument to ~S: ~S" 'instance-boundp-internal kind))
+  (if (eq kind :default)
       default
       (let* ((index (gensym)))
 	`(locally (declare #.*optimize-speed*)
 	  (let ((,index (pvref ,pv ,pv-offset)))
 	    (typecase ,index
-	      ,@(when (or (null type) (eq type :instance))
+	      ,@(when (or (null kind) (eq kind :instance))
 		  `((fixnum (not (and ,slots
                                       (eq (clos-slots-ref ,slots ,index)
                                           +slot-unbound+))))))
-	      ,@(when (or (null type) (eq type :class))
+	      ,@(when (or (null kind) (eq kind :class))
 		  `((cons (not (eq (cdr ,index) +slot-unbound+)))))
 	      (t ,default)))))))
 
diff --git a/tests/clos-typechecking.impure.lisp b/tests/clos-typechecking.impure.lisp
new file mode 100644
index 000000000..9422bd9d4
--- /dev/null
+++ b/tests/clos-typechecking.impure.lisp
@@ -0,0 +1,144 @@
+(load "assertoid.lisp")
+
+(defpackage "FOO"
+  (:use "CL" "ASSERTOID"))
+(in-package "FOO")
+
+(defclass foo ()
+  ((slot :initarg :slot :type fixnum :accessor slot)))
+(defclass foo/gf (sb-mop:standard-generic-function)
+  ((slot/gf :initarg :slot/gf :type fixnum :accessor slot/gf))
+  (:metaclass sb-mop:funcallable-standard-class))
+(defmethod succeed/sv ((x foo))
+  (setf (slot-value x 'slot) 1))
+(defmethod fail/sv ((x foo))
+  (setf (slot-value x 'slot) t))
+(defmethod succeed/acc ((x foo))
+  (setf (slot x) 1))
+(defmethod fail/acc ((x foo))
+  (setf (slot x) t))
+(defmethod succeed/sv/gf ((x foo/gf))
+  (setf (slot-value x 'slot/gf) 1))
+(defmethod fail/sv/gf ((x foo/gf))
+  (setf (slot-value x 'slot/gf) t))
+(defmethod succeed/acc/gf ((x foo/gf))
+  (setf (slot/gf x) 1))
+(defmethod fail/acc/gf ((x foo/gf))
+  (setf (slot/gf x) t))
+(defvar *t* t)
+(defvar *one* 1)
+
+;; evaluator
+(eval '(setf (slot-value (make-instance 'foo) 'slot) 1))
+(assert (raises-error? (eval '(setf (slot-value (make-instance 'foo) 'slot) t))
+		       type-error))
+(eval '(setf (slot (make-instance 'foo)) 1))
+(assert (raises-error? (eval '(setf (slot (make-instance 'foo)) t))
+		       type-error))
+(eval '(succeed/sv (make-instance 'foo)))
+(assert (raises-error? (eval '(fail/sv (make-instance 'foo)))
+		       type-error))
+(eval '(succeed/acc (make-instance 'foo)))
+(assert (raises-error? (eval '(fail/acc (make-instance 'foo)))
+		       type-error))
+(eval '(make-instance 'foo :slot 1))
+(assert (raises-error? (eval '(make-instance 'foo :slot t))
+		       type-error))
+(eval '(make-instance 'foo :slot *one*))
+(assert (raises-error? (eval '(make-instance 'foo :slot *t*))
+		       type-error))
+;; evaluator/gf
+(eval '(setf (slot-value (make-instance 'foo/gf) 'slot/gf) 1))
+(assert (raises-error?
+	 (eval '(setf (slot-value (make-instance 'foo/gf) 'slot/gf) t))
+	 type-error))
+(eval '(setf (slot/gf (make-instance 'foo/gf)) 1))
+(assert (raises-error? (eval '(setf (slot/gf (make-instance 'foo/gf)) t))
+		       type-error))
+(eval '(succeed/sv/gf (make-instance 'foo/gf)))
+#+nil ; funcallable standard instance slot-value access go through
+      ; ACCESSOR-SLOT-VALUE because their classes are not
+      ; STANDARD-CLASS-P.
+(assert (raises-error? (eval '(fail/sv/gf (make-instance 'foo/gf)))
+		       type-error))
+(eval '(succeed/acc/gf (make-instance 'foo/gf)))
+(assert (raises-error? (eval '(fail/acc/gf (make-instance 'foo/gf)))
+		       type-error))
+(eval '(make-instance 'foo/gf :slot/gf 1))
+(assert (raises-error? (eval '(make-instance 'foo/gf :slot/gf t))
+		       type-error))
+(eval '(make-instance 'foo/gf :slot/gf *one*))
+(assert (raises-error? (eval '(make-instance 'foo/gf :slot/gf *t*))
+		       type-error))
+
+;; compiler
+(funcall (compile nil '(lambda ()
+			(setf (slot-value (make-instance 'foo) 'slot) 1))))
+#+nil ; this one still fails goddamit.
+(assert (raises-error?
+	 (funcall
+	  (compile nil '(lambda ()
+			 (setf (slot-value (make-instance 'foo) 'slot) t))))
+	 type-error))
+(funcall (compile nil '(lambda () (setf (slot (make-instance 'foo)) 1))))
+(assert (raises-error?
+	 (funcall
+	  (compile nil '(lambda () (setf (slot (make-instance 'foo)) t))))
+	 type-error))
+(funcall (compile nil '(lambda () (succeed/sv (make-instance 'foo)))))
+(assert (raises-error?
+	 (funcall (compile nil '(lambda () (fail/sv (make-instance 'foo)))))
+	 type-error))
+(funcall (compile nil '(lambda () (succeed/acc (make-instance 'foo)))))
+(assert (raises-error?
+	 (funcall (compile nil '(lambda () (fail/acc (make-instance 'foo)))))
+	 type-error))
+(funcall (compile nil '(lambda () (make-instance 'foo :slot 1))))
+(assert (raises-error?
+	 (funcall (compile nil '(lambda () (make-instance 'foo :slot t))))
+	 type-error))
+(funcall (compile nil '(lambda () (make-instance 'foo :slot *one*))))
+(assert (raises-error?
+	 (funcall (compile nil '(lambda () (make-instance 'foo :slot *t*))))
+	 type-error))
+;; compiler/gf
+(funcall (compile nil
+		  '(lambda ()
+		    (setf (slot-value (make-instance 'foo/gf) 'slot/gf) 1))))
+#+nil ; this one too
+(assert (raises-error?
+	 (funcall
+	  (compile nil
+		   '(lambda ()
+		     (setf (slot-value (make-instance 'foo/gf) 'slot/gf) t))))
+	 type-error))
+(funcall (compile nil '(lambda () (setf (slot/gf (make-instance 'foo/gf)) 1))))
+(assert (raises-error?
+	 (funcall
+	  (compile nil
+		   '(lambda () (setf (slot/gf (make-instance 'foo/gf)) t))))
+	 type-error))
+(funcall (compile nil '(lambda () (succeed/sv/gf (make-instance 'foo/gf)))))
+#+nil ; see above
+(assert (raises-error?
+	 (funcall (compile nil '(lambda ()
+				 (fail/sv/gf (make-instance 'foo/gf)))))
+	 type-error))
+(funcall (compile nil '(lambda () (succeed/acc/gf (make-instance 'foo/gf)))))
+(assert (raises-error?
+	 (funcall (compile nil '(lambda ()
+				 (fail/acc/gf (make-instance 'foo/gf)))))
+	 type-error))
+(funcall (compile nil '(lambda () (make-instance 'foo/gf :slot/gf 1))))
+(assert (raises-error?
+	 (funcall (compile nil '(lambda ()
+				 (make-instance 'foo/gf :slot/gf t))))
+	 type-error))
+(funcall (compile nil '(lambda () (make-instance 'foo/gf :slot/gf *one*))))
+(assert (raises-error?
+	 (funcall (compile nil '(lambda ()
+				 (make-instance 'foo/gf :slot/gf *t*))))
+	 type-error))
+
+;;;; success
+(sb-ext:quit :unix-status 104)
diff --git a/tests/mop.impure-cload.lisp b/tests/mop.impure-cload.lisp
index 56a0ddbbf..0f424304d 100644
--- a/tests/mop.impure-cload.lisp
+++ b/tests/mop.impure-cload.lisp
@@ -23,7 +23,7 @@
 ;;; A distilled test case from cmucl-imp for Kevin Rosenberg's
 ;;; hyperobject.  Fix from Gerd Moellmann.
 (defclass hyperobject-class (standard-class)
-  ((user-name :initarg :user-name :type string :initform nil
+  ((user-name :initarg :user-name :type (or null string) :initform nil
 	      :accessor user-name
 	      :documentation "User name for class")))
 
diff --git a/version.lisp-expr b/version.lisp-expr
index d714bf7ad..d671743c4 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.18.11"
+"0.8.18.11.clos-typechecking.1"