X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=b5d0e585c43aa0d574e60c03a06394ab997d490f;hb=f2db6743b1fadeea9e72cb583d857851c87efcd4;hp=84fcda4efb72004f9a86b1441294bb285c0d3709;hpb=95f17ca63742f8c164309716b35bc25545a849a6;p=sbcl.git

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index 84fcda4..b5d0e58 100644
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -103,7 +103,7 @@
                       (find-slot-definition class name)))
          (old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all))))
     (multiple-value-bind (function std-p)
-        (if (eq *boot-state* 'complete)
+        (if (eq **boot-state** 'complete)
             (get-accessor-method-function gf type class slotd)
             (get-optimized-std-accessor-method-function class slotd type))
       (setf (slot-accessor-std-p slotd type) std-p)
@@ -181,13 +181,13 @@
 (defmethod add-direct-method :around ((specializer specializer) method)
   ;; All the actions done under this lock are done in an order
   ;; that is safe to unwind at any point.
-  (sb-thread::with-recursive-spinlock (*specializer-lock*)
+  (sb-thread::with-recursive-system-spinlock (*specializer-lock*)
     (call-next-method)))
 
 (defmethod remove-direct-method :around ((specializer specializer) method)
   ;; All the actions done under this lock are done in an order
   ;; that is safe to unwind at any point.
-  (sb-thread::with-recursive-spinlock (*specializer-lock*)
+  (sb-thread::with-recursive-system-spinlock (*specializer-lock*)
     (call-next-method)))
 
 (defmethod add-direct-method ((specializer class) (method method))
@@ -353,7 +353,7 @@
       (without-package-locks
         (setf (find-class name) class))))
   ;; After boot (SETF FIND-CLASS) does this.
-  (unless (eq *boot-state* 'complete)
+  (unless (eq **boot-state** 'complete)
     (%set-class-type-translation class name))
   class)
 
@@ -367,7 +367,7 @@
       (without-package-locks
         (setf (find-class name) class))))
   ;; After boot (SETF FIND-CLASS) does this.
-  (unless (eq *boot-state* 'complete)
+  (unless (eq **boot-state** 'complete)
     (%set-class-type-translation class name))
   class)
 
@@ -628,51 +628,59 @@
 (defun make-structure-class-defstruct-form (name direct-slots include)
   (let* ((conc-name (format-symbol *package* "~S structure class " name))
          (constructor (format-symbol *package* "~Aconstructor" conc-name))
-         (defstruct `(defstruct (,name
-                                 ,@(when include
-                                         `((:include ,(class-name include))))
-                                 (:predicate nil)
-                                 (:conc-name ,conc-name)
-                                 (:constructor ,constructor ())
-                                 (:copier nil))
-                      ,@(mapcar (lambda (slot)
-                                  `(,(slot-definition-name slot)
-                                    +slot-unbound+))
-                                direct-slots)))
-         (reader-names (mapcar (lambda (slotd)
-                                 (list 'slot-accessor name
-                                       (slot-definition-name slotd)
-                                       'reader))
-                               direct-slots))
-         (writer-names (mapcar (lambda (slotd)
-                                 (list 'slot-accessor name
-                                       (slot-definition-name slotd)
-                                       'writer))
-                               direct-slots))
-         (readers-init
-           (mapcar (lambda (slotd reader-name)
-                     (let ((accessor
+         (included-name (class-name include))
+         (included-slots
+          (when include
+            (mapcar #'dsd-name (dd-slots (find-defstruct-description included-name)))))
+         (old-slots nil)
+         (new-slots nil)
+         (reader-names nil)
+         (writer-names nil))
+    (dolist (slotd (reverse direct-slots))
+      (let* ((slot-name (slot-definition-name slotd))
+             (initform (slot-definition-initform slotd))
+             (type (slot-definition-type slotd))
+             (desc `(,slot-name ,initform :type ,type)))
+        (push `(slot-accessor ,name ,slot-name reader)
+              reader-names)
+        (push `(slot-accessor ,name ,slot-name writer)
+              writer-names)
+        (if (member slot-name included-slots :test #'eq)
+            (push desc old-slots)
+            (push desc new-slots))))
+    (let* ((defstruct `(defstruct (,name
+                                    ,@(when include
+                                            `((:include ,included-name
+                                                        ,@old-slots)))
+                                    (:constructor ,constructor ())
+                                    (:predicate nil)
+                                    (:conc-name ,conc-name)
+                                    (:copier nil))
+                         ,@new-slots))
+           (readers-init
+            (mapcar (lambda (slotd reader-name)
+                      (let ((accessor
                              (slot-definition-defstruct-accessor-symbol
                               slotd)))
-                       `(defun ,reader-name (obj)
-                         (declare (type ,name obj))
-                         (,accessor obj))))
-                   direct-slots reader-names))
-         (writers-init
-           (mapcar (lambda (slotd writer-name)
-                     (let ((accessor
+                        `(defun ,reader-name (obj)
+                           (declare (type ,name obj))
+                           (,accessor obj))))
+                    direct-slots reader-names))
+           (writers-init
+            (mapcar (lambda (slotd writer-name)
+                      (let ((accessor
                              (slot-definition-defstruct-accessor-symbol
                               slotd)))
-                       `(defun ,writer-name (nv obj)
-                         (declare (type ,name obj))
-                         (setf (,accessor obj) nv))))
-                   direct-slots writer-names))
-         (defstruct-form
-             `(progn
+                        `(defun ,writer-name (nv obj)
+                           (declare (type ,name obj))
+                           (setf (,accessor obj) nv))))
+                    direct-slots writer-names))
+           (defstruct-form
+            `(progn
                ,defstruct
                ,@readers-init ,@writers-init
                (cons nil nil))))
-    (values defstruct-form constructor reader-names writer-names)))
+      (values defstruct-form constructor reader-names writer-names))))
 
 (defun make-defstruct-allocation-function (name)
   ;; FIXME: Why don't we go class->layout->info == dd