X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fbraid.lisp;h=f9c9b7830992d9d5b6f1ddd8974a82a8eaff6471;hb=f17e3d27d7ff599f9443d011d17017a2a858c81a;hp=68daf7f75cb8f3d3eab4724a9017c04924392865;hpb=95f17ca63742f8c164309716b35bc25545a849a6;p=sbcl.git

diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp
index 68daf7f..f9c9b78 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
 ;;;;
@@ -202,7 +188,10 @@
 
               (when (typep wrapper 'wrapper)
                 (setf (wrapper-instance-slots-layout wrapper)
-                      (mapcar #'canonical-slot-name slots))
+                      (mapcar (lambda (slotd)
+                                ;; T is the slot-definition-type.
+                                (cons (canonical-slot-name slotd) t))
+                              slots))
                 (setf (wrapper-class-slots wrapper)
                       ()))
 
@@ -249,6 +238,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
@@ -376,19 +370,20 @@
       (set-val 'writers      (get-val :writers))
       (set-val 'allocation   :instance)
       (set-val '%type        (or (get-val :type) t))
-      (set-val '%type-check-function (get-val 'type-check-function))
       (set-val '%documentation (or (get-val :documentation) ""))
       (set-val '%class   class)
       (when effective-p
         (set-val 'location index)
-        (let ((fsc-p nil))
-          (set-val 'reader-function (make-optimized-std-reader-method-function
-                                     fsc-p nil slot-name index))
-          (set-val 'writer-function (make-optimized-std-writer-method-function
-                                     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))
+        (set-val 'accessor-flags 7)
+        (set-val
+         'info
+         (make-slot-info
+          :reader
+          (make-optimized-std-reader-method-function nil nil slot-name index)
+          :writer
+          (make-optimized-std-writer-method-function nil nil slot-name index)
+          :boundp
+          (make-optimized-std-boundp-method-function nil nil slot-name index))))
       (when (and (eq name 'standard-class)
                  (eq slot-name 'slots) effective-p)
         (setq *the-eslotd-standard-class-slots* slotd))
@@ -554,11 +549,8 @@
          (let ((accessor (structure-slotd-accessor-symbol slotd)))
            `(:name ,(structure-slotd-name slotd)
              :defstruct-accessor-symbol ,accessor
-             ,@(when (fboundp accessor)
-                 `(:internal-reader-function
-                   ,(structure-slotd-reader-function slotd)
-                   :internal-writer-function
-                   ,(structure-slotd-writer-function name slotd)))
+             :internal-reader-function ,(structure-slotd-reader-function slotd)
+             :internal-writer-function ,(structure-slotd-writer-function name slotd)
              :type ,(or (structure-slotd-type slotd) t)
              :initform ,(structure-slotd-init-form slotd)
              :initfunction ,(eval-form (structure-slotd-init-form slotd)))))
@@ -590,7 +582,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 +591,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
@@ -696,7 +688,7 @@
 
       (%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~