Index: /trunk/ccl/level-1/l1-clos-boot.lisp
===================================================================
--- /trunk/ccl/level-1/l1-clos-boot.lisp	(revision 5376)
+++ /trunk/ccl/level-1/l1-clos-boot.lisp	(revision 5377)
@@ -1140,5 +1140,7 @@
 
 (defun (setf info-type-kind) (val name)
-  (setf (gethash name *type-kind-info*) val))
+  (if val
+    (setf (gethash name *type-kind-info*) val)
+    (remhash name *type-kind-info*)))
 
 (defun missing-type-method (&rest foo)
@@ -1216,5 +1218,6 @@
   (let ((cell (find-class-cell name class)))
     (when cell
-      (setf (info-type-kind name) :instance)
+      (if (eq name (%class.name class))
+        (setf (info-type-kind name) :instance))
       (setf (cdr (the cons cell)) class))
     class))
@@ -1253,30 +1256,32 @@
 
 (queue-fixup
- (without-interrupts 
-  (defun set-find-class (name class)
-    (setq name (require-type name 'symbol))
-    (let ((cell (find-class-cell name class)))
-      (declare (type list cell))
-      (when *warn-if-redefine-kernel*
-        (let ((old-class (cdr cell)))
-	  (when old-class
-	    (check-setf-find-class-protected-class old-class class name))))
-      (when (null class)
-        (when cell
-          (setf (cdr cell) nil))
-        (return-from set-find-class nil))
-      (setq class (require-type class 'class))
-      (when (built-in-type-p name)
-        (unless (eq (cdr cell) class)
-          (error "Cannot redefine built-in type name ~S" name)))
-      (when (%deftype-expander name)
-        (cerror "set ~S anyway, removing the ~*~S definition"
-                "Cannot set ~S because type ~S is already defined by ~S"
-                `(find-class ',name) name 'deftype)
-        (%deftype name nil nil))
-      (setf (info-type-kind name) :instance)
-      (setf (cdr cell) class)))
-  ) ; end of without-interrupts
- ) ; end of queue-fixup
+ (defun set-find-class (name class)
+   (setq name (require-type name 'symbol))
+   (let ((cell (find-class-cell name class)))
+     (declare (type list cell))
+       (let ((old-class (cdr cell)))
+         (when old-class
+           (when (eq (%class.name old-class) name)
+             (setf (info-type-kind name) nil)
+             (clear-type-cache))
+           (when *warn-if-redefine-kernel*
+             (check-setf-find-class-protected-class old-class class name))))
+     (when (null class)
+       (when cell
+         (setf (cdr cell) nil))
+       (return-from set-find-class nil))
+     (setq class (require-type class 'class))
+     (when (built-in-type-p name)
+       (unless (eq (cdr cell) class)
+         (error "Cannot redefine built-in type name ~S" name)))
+     (when (eq (%class.name class) name)
+       (when (%deftype-expander name)
+         (cerror "set ~S anyway, removing the ~*~S definition"
+                 "Cannot set ~S because type ~S is already defined by ~S"
+                 `(find-class ',name) name 'deftype)
+         (%deftype name nil nil))
+       (setf (info-type-kind name) :instance))
+     (setf (cdr cell) class)))
+ )                                      ; end of queue-fixup
 
 
@@ -1510,9 +1515,14 @@
 (defglobal *function-class* (make-built-in-class 'function))
 
+(defun alias-class (name class)
+  (setf (find-class name) class
+        (info-type-kind name) :instance)
+  class)
+
 ;;;Right now, all functions are compiled.
 
 
 (defglobal *compiled-function-class* *function-class*)
-(setf (find-class 'compiled-function) *compiled-function-class*)
+(alias-class 'compiled-function *compiled-function-class*)
 
 (defglobal *compiled-lexical-closure-class* 
@@ -1655,6 +1665,6 @@
   (defglobal *double-float-class* (make-built-in-class 'double-float (find-class 'float)))
   (defglobal *single-float-class*  (make-built-in-class 'single-float (find-class 'float)))
-  (setf (find-class 'short-float) *single-float-class*)
-  (setf (find-class 'long-float) *double-float-class*)
+  (alias-class 'short-float *single-float-class*)
+  (alias-class 'long-float *double-float-class*)
 
   (make-built-in-class 'rational (find-class 'real))
@@ -1674,10 +1684,7 @@
   (make-built-in-class 'logical-pathname (find-class 'pathname))
   
-  (defglobal *base-char-class* (setf (find-class 'base-char) *character-class*))
+  (defglobal *base-char-class* (alias-class 'base-char *character-class*))
   (defglobal *standard-char-class* (make-built-in-class 'standard-char *base-char-class*))
   
-  #+who-needs-extended-char
-  (make-built-in-class 'extended-char *character-class*)
-
   (defglobal *keyword-class* (make-built-in-class 'keyword *symbol-class*))
   
@@ -1703,10 +1710,10 @@
     (make-built-in-class 'double-float-vector *vector-class*)
     (make-built-in-class 'short-float-vector *vector-class*)
-    (setf (find-class 'long-float-vector) (find-class 'double-float-vector))
-    (setf (find-class 'single-float-vector) (find-class 'short-float-vector))
+    (alias-class 'long-float-vector (find-class 'double-float-vector))
+    (alias-class 'single-float-vector (find-class 'short-float-vector))
     (make-built-in-class 'simple-double-float-vector (find-class 'double-float-vector) (find-class 'simple-1d-array))
     (make-built-in-class 'simple-short-float-vector (find-class 'short-float-vector) (find-class 'simple-1d-array))
-    (setf (find-class 'simple-long-float-vector) (find-class 'simple-double-float-vector))
-    (setf (find-class 'simple-single-float-vector) (find-class 'simple-short-float-vector))
+    (alias-class 'simple-long-float-vector (find-class 'simple-double-float-vector))
+    (alias-class 'simple-single-float-vector (find-class 'simple-short-float-vector))
     )