X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fbraid.lisp;h=b0e3f3c00122db47b7ea5d915e2735a000ae177f;hb=f2db6743b1fadeea9e72cb583d857851c87efcd4;hp=518abf7724e161bde91901f3683f67c93c630c5c;hpb=4f7161165647d655392713a0d95c951e4e1749ea;p=sbcl.git

diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp
index 518abf7..b0e3f3c 100644
--- a/src/pcl/braid.lisp
+++ b/src/pcl/braid.lisp
@@ -85,20 +85,6 @@
           (allocate-standard-funcallable-instance-slots
            wrapper slots-init-p slots-init))
     fin))
-
-(defun allocate-structure-instance (wrapper &optional
-                                            (slots-init nil slots-init-p))
-  (let* ((class (wrapper-class wrapper))
-         (constructor (class-defstruct-constructor class)))
-    (if constructor
-        (let ((instance (funcall constructor))
-              (slots (class-slots class)))
-          (when slots-init-p
-            (dolist (slot slots)
-              (setf (slot-value-using-class class instance slot)
-                    (pop slots-init))))
-          instance)
-        (error "can't allocate an instance of class ~S" (class-name class)))))
 
 ;;;; BOOTSTRAP-META-BRAID
 ;;;;
@@ -249,6 +235,11 @@
                   class name class-eq-specializer-wrapper source
                   direct-supers direct-subclasses cpl wrapper))))))))
 
+    (setq **standard-method-classes**
+          (mapcar (lambda (name)
+                    (symbol-value (make-class-symbol name)))
+                  *standard-method-class-names*))
+
     (let* ((smc-class (find-class 'standard-method-combination))
            (smc-wrapper (!bootstrap-get-slot 'standard-class
                                              smc-class
@@ -590,7 +581,7 @@
   (let ((class (classoid-pcl-class classoid)))
     (cond (class
            (ensure-non-standard-class (class-name class) classoid class))
-          ((eq 'complete *boot-state*)
+          ((eq 'complete **boot-state**)
            (ensure-non-standard-class (classoid-name classoid) classoid)))))
 
 (pushnew 'ensure-deffoo-class sb-kernel::*defstruct-hooks*)
@@ -599,7 +590,7 @@
 ;;; FIXME: only needed during bootstrap
 (defun make-class-predicate (class name)
   (let* ((gf (ensure-generic-function name :lambda-list '(object)))
-         (mlist (if (eq *boot-state* 'complete)
+         (mlist (if (eq **boot-state** 'complete)
                     (early-gf-methods gf)
                     (generic-function-methods gf))))
     (unless mlist
@@ -629,7 +620,8 @@
 
 ;;; 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)
+(defun %update-lisp-class-layout (class layout)
+  ;; Protected by *world-lock* in callers.
   (let ((classoid (layout-classoid layout))
         (olayout (class-wrapper class)))
     (unless (eq (classoid-layout classoid) layout)
@@ -649,7 +641,7 @@
         (when (and name (symbolp name) (eq name (classoid-name classoid)))
           (setf (find-classoid name) classoid))))))
 
-(defun set-class-type-translation (class classoid)
+(defun %set-class-type-translation (class classoid)
   (when (not (typep classoid 'classoid))
     (setq classoid (find-classoid classoid nil)))
   (etypecase classoid
@@ -686,16 +678,16 @@
           (aver (eq class lclass-pcl-class))
           (setf (classoid-pcl-class lclass) class))
 
-      (update-lisp-class-layout class layout)
+      (%update-lisp-class-layout class layout)
 
       (cond (olclass
              (aver (eq lclass olclass)))
             (t
              (setf (find-classoid name) lclass)))
 
-      (set-class-type-translation class name))))
+      (%set-class-type-translation class name))))
 
-(setq *boot-state* 'braid)
+(setq **boot-state** 'braid)
 
 (defmethod no-applicable-method (generic-function &rest args)
   (error "~@<There is no applicable method for the generic function ~2I~_~S~