0.9.15.3:

[sbcl.git] / src / pcl / braid.lisp

diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp
index 6bed8f4..008eb02 100644 (file)
--- a/src/pcl/braid.lisp
+++ b/src/pcl/braid.lisp
@@ -266,16 +266,16 @@
     (set-slot 'name name)
     (set-slot 'finalized-p t)
     (set-slot 'source source)
-    (set-slot 'type (if (eq class (find-class t))
-                        t
-                        ;; FIXME: Could this just be CLASS instead
-                        ;; of `(CLASS ,CLASS)? If not, why not?
-                        ;; (See also similar expression in
-                        ;; SHARED-INITIALIZE :BEFORE (CLASS).)
-                        `(class ,class)))
+    (set-slot '%type (if (eq class (find-class t))
+                         t
+                         ;; FIXME: Could this just be CLASS instead
+                         ;; of `(CLASS ,CLASS)? If not, why not?
+                         ;; (See also similar expression in
+                         ;; SHARED-INITIALIZE :BEFORE (CLASS).)
+                         `(class ,class)))
     (set-slot 'class-eq-specializer
               (let ((spec (allocate-standard-instance class-eq-wrapper)))
-                (!bootstrap-set-slot 'class-eq-specializer spec 'type
+                (!bootstrap-set-slot 'class-eq-specializer spec '%type
                                      `(class-eq ,class))
                 (!bootstrap-set-slot 'class-eq-specializer spec 'object
                                      class)
@@ -370,11 +370,7 @@
                                      fsc-p nil slot-name index))
           (set-val 'boundp-function (make-optimized-std-boundp-method-function
                                      fsc-p nil slot-name index)))
-        (set-val 'accessor-flags 7)
-        (let ((table (or (gethash slot-name *name->class->slotd-table*)
-                         (setf (gethash slot-name *name->class->slotd-table*)
-                               (make-hash-table :test 'eq :size 5)))))
-          (setf (gethash class table) slotd)))
+        (set-val 'accessor-flags 7))
       (when (and (eq name 'standard-class)
                  (eq slot-name 'slots) effective-p)
         (setq *the-eslotd-standard-class-slots* slotd))
@@ -434,7 +430,9 @@
                                      (funcall make-method-function
                                               class-name slot-name)
                                      doc
-                                     slot-name))))))
+                                     :slot-name slot-name
+                                     :object-class class-name
+                                     :method-class-function (constantly (find-class accessor-class))))))))
 
 (defun !bootstrap-accessor-definitions1 (class-name
                                         slot-name
@@ -617,38 +615,43 @@
 ;;; Set the inherits from CPL, and register the layout. This actually
 ;;; installs the class in the Lisp type system.
 (defun update-lisp-class-layout (class layout)
-  (let ((lclass (layout-classoid layout)))
-    (unless (eq (classoid-layout lclass) layout)
+  (let ((classoid (layout-classoid layout))
+        (olayout (class-wrapper class)))
+    (unless (eq (classoid-layout classoid) layout)
       (setf (layout-inherits layout)
-              (order-layout-inherits
-               (map 'simple-vector #'class-wrapper
-                    (reverse (rest (class-precedence-list class))))))
+            (order-layout-inherits
+             (map 'simple-vector #'class-wrapper
+                  (reverse (rest (class-precedence-list class))))))
       (register-layout layout :invalidate t)
 
-      ;; Subclasses of formerly forward-referenced-class may be
-      ;; unknown to CL:FIND-CLASS and also anonymous. This
-      ;; functionality moved here from (SETF FIND-CLASS).
+      ;; FIXME: I don't think this should be necessary, but without it
+      ;; we are unable to compile (TYPEP foo '<class-name>) in the
+      ;; same file as the class is defined.  If we had environments,
+      ;; then I think the classsoid whould only be associated with the
+      ;; name in that environment...  Alternatively, fix the compiler
+      ;; so that TYPEP foo '<class-name> is slow but compileable.
       (let ((name (class-name class)))
-        (setf (find-classoid name) lclass
-              (classoid-name lclass) name)))))
-
-(defun set-class-type-translation (class name)
-  (let ((classoid (find-classoid name nil)))
-    (etypecase classoid
-      (null)
-      (built-in-classoid
-       (let ((translation (built-in-classoid-translation classoid)))
-         (cond
-           (translation
-            (aver (ctype-p translation))
-            (setf (info :type :translator class)
-                  (lambda (spec) (declare (ignore spec)) translation)))
-           (t
-            (setf (info :type :translator class)
-                  (lambda (spec) (declare (ignore spec)) classoid))))))
-      (classoid
-       (setf (info :type :translator class)
-             (lambda (spec) (declare (ignore spec)) classoid))))))
+        (when (and name (symbolp name) (eq name (classoid-name classoid)))
+          (setf (find-classoid name) classoid))))))
+
+(defun set-class-type-translation (class classoid)
+  (when (not (typep classoid 'classoid))
+    (setq classoid (find-classoid classoid nil)))
+  (etypecase classoid
+    (null)
+    (built-in-classoid
+     (let ((translation (built-in-classoid-translation classoid)))
+       (cond
+         (translation
+          (aver (ctype-p translation))
+          (setf (info :type :translator class)
+                (lambda (spec) (declare (ignore spec)) translation)))
+         (t
+          (setf (info :type :translator class)
+                (lambda (spec) (declare (ignore spec)) classoid))))))
+    (classoid
+     (setf (info :type :translator class)
+           (lambda (spec) (declare (ignore spec)) classoid)))))
 
 (clrhash *find-class*)
 (!bootstrap-meta-braid)