1.0.16.29: workaround for bug 419

[sbcl.git] / src / code / defstruct.lisp

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index e4f6fb2..97dc74e 100644 (file)
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -58,10 +58,6 @@
                   (error "Class is not a structure class: ~S" ',name))
                 ,layout))))))
 
-;;; Get layout right away.
-(sb!xc:defmacro compile-time-find-layout (name)
-  (find-layout name))
-
 ;;; re. %DELAYED-GET-COMPILER-LAYOUT and COMPILE-TIME-FIND-LAYOUT, above..
 ;;;
 ;;; FIXME: Perhaps both should be defined with DEFMACRO-MUNDANELY?
@@ -479,7 +475,8 @@
           (let ((inherited (accessor-inherited-data name defstruct)))
             (cond
               ((not inherited)
-               (stuff `(declaim (inline ,name (setf ,name))))
+               (stuff `(declaim (inline ,name ,@(unless (dsd-read-only slot)
+                                                        `((setf ,name))))))
                ;; FIXME: The arguments in the next two DEFUNs should
                ;; be gensyms. (Otherwise e.g. if NEW-VALUE happened to
                ;; be the name of a special variable, things could get
@@ -933,9 +930,14 @@
 
 ;;; Return a LAMBDA form which can be used to set a slot.
 (defun slot-setter-lambda-form (dd dsd)
-  `(lambda (new-value instance)
-     ,(funcall (nth-value 1 (slot-accessor-transforms dd dsd))
-               '(dummy new-value instance))))
+  ;; KLUDGE: Evaluating the results of SLOT-ACCESSOR-TRANSFORMS needs
+  ;; a lexenv.
+  (let ((sb!c:*lexenv* (if (boundp 'sb!c:*lexenv*)
+                           sb!c:*lexenv*
+                           (sb!c::make-null-lexenv))))
+    `(lambda (new-value instance)
+       ,(funcall (nth-value 1 (slot-accessor-transforms dd dsd))
+                 '(dummy new-value instance)))))
 
 ;;; core compile-time setup of any class with a LAYOUT, used even by
 ;;; !DEFSTRUCT-WITH-ALTERNATE-METACLASS weirdosities
@@ -966,14 +968,15 @@
            (when (and (classoid-subclasses classoid)
                       (not (eq layout old-layout)))
              (collect ((subs))
-                      (dohash (classoid layout (classoid-subclasses classoid))
-                        (declare (ignore layout))
-                        (undefine-structure classoid)
-                        (subs (classoid-proper-name classoid)))
-                      (when (subs)
-                        (warn "removing old subclasses of ~S:~%  ~S"
-                              (classoid-name classoid)
-                              (subs))))))
+               (dohash ((classoid layout) (classoid-subclasses classoid)
+                        :locked t)
+                 (declare (ignore layout))
+                 (undefine-structure classoid)
+                 (subs (classoid-proper-name classoid)))
+               (when (subs)
+                 (warn "removing old subclasses of ~S:~%  ~S"
+                       (classoid-name classoid)
+                       (subs))))))
           (t
            (unless (eq (classoid-layout classoid) layout)
              (register-layout layout :invalidate nil))
@@ -1029,6 +1032,7 @@
       (let* ((accessor-name (dsd-accessor-name dsd))
              (dsd-type (dsd-type dsd)))
         (when accessor-name
+          (setf (info :function :structure-accessor accessor-name) dd)
           (let ((inherited (accessor-inherited-data accessor-name dd)))
             (cond
               ((not inherited)
@@ -1733,49 +1737,4 @@
         (when errorp
           (error "No DEFSTRUCT-DESCRIPTION for ~S." name)))))
 
-(defun structure-slot-index (type slot-name &optional (errorp t))
-  (let ((slotd (find slot-name
-                     (dd-slots (find-defstruct-description type))
-                     :key #'dsd-name)))
-    (if slotd
-        (dsd-index slotd)
-        (when errorp
-          (error "No slot named ~S in ~S." slot-name type)))))
-
-;;; Used internally, but it would be nice to provide something
-;;; like this for users as well.
-#!+sb-thread
-(defmacro define-structure-slot-compare-and-exchange
-    (name &key structure slot)
-  (let* ((dd (find-defstruct-description structure t))
-         (slotd (when dd (find slot (dd-slots dd) :key #'dsd-name)))
-         (type (when slotd (dsd-type slotd)))
-         (index (when slotd (dsd-index slotd))))
-    (unless index
-      (error "Slot ~S not found in ~S." slot structure))
-    `(progn
-       (declaim (inline ,name))
-       (defun ,name (instance old new)
-         (declare (type ,structure instance)
-                  (type ,type new))
-         (sb!vm::%instance-set-conditional instance ,index old new)))))
-
-;;; Ditto
-#!+sb-thread
-(defmacro define-structure-slot-addressor (name &key structure slot)
-  (let* ((dd (find-defstruct-description structure t))
-         (slotd (when dd (find slot (dd-slots dd) :key #'dsd-name)))
-         (index (when slotd (dsd-index slotd))))
-    (unless index
-      (error "Slot ~S not found in ~S." slot structure))
-    `(progn
-       (declaim (inline ,name))
-       (defun ,name (instance)
-         (declare (type ,structure instance) (optimize speed))
-         (sb!ext:truly-the
-          sb!vm:word
-          (+ (sb!kernel:get-lisp-obj-address instance)
-             (- (* ,(+ sb!vm:instance-slots-offset index) sb!vm:n-word-bytes)
-                sb!vm:instance-pointer-lowtag)))))))
-
 (/show0 "code/defstruct.lisp end of file")