Changeset 5377

Timestamp:

Oct 18, 2006, 6:38:57 AM (18 years ago)

Author:

Gary Byers

Message:

The post-bootstrapping version of (SETF FIND-CLASS) only introduces (or removes) a type
name if the class becomes (or ceases to be) a properly named class.

The pre-bootstrapping version handles simpler cases of that; use ALIAS-CLASS to
register some early class names as type names.

File:

• trunk/ccl/level-1/l1-clos-boot.lisp (modified) (7 diffs)

trunk/ccl/level-1/l1-clos-boot.lisp

@@ -1140 +1140 @@
 
 (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 +1218 @@
   (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 +1256 @@
 
 (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 +1515 @@
 (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 +1665 @@
   (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 +1684 @@
   (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 +1710 @@
     (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))
     )