X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=0fb2b367861c28b45ca08fd32ea4ebcc9f14b0dc;hb=6a0601ab48635465ad3400c290e5cfbca28e5367;hp=995a12fefe30546a039395e2106879a0f4a098e4;hpb=d1e7b48b17180a417c41ed55eb382ebf6d4e7a2a;p=sbcl.git

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 995a12f..0fb2b36 100644
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -933,9 +933,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 +971,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 +1035,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)
@@ -1579,7 +1586,7 @@
                  metaclass-constructor))
   (declare (type symbol predicate))
   (declare (type (member structure funcallable-structure) dd-type))
-  (declare (ignore boa-constructor predicate runtime-type-checks))
+  (declare (ignore boa-constructor predicate runtime-type-checks-p))
 
   (let* ((dd (make-dd-with-alternate-metaclass
               :class-name class-name
@@ -1725,4 +1732,12 @@
          (inherits (inherits-for-structure dd)))
     (%compiler-defstruct dd inherits)))
 
+;;; finding these beasts
+(defun find-defstruct-description (name &optional (errorp t))
+  (let ((info (layout-info (classoid-layout (find-classoid name errorp)))))
+    (if (defstruct-description-p info)
+        info
+        (when errorp
+          (error "No DEFSTRUCT-DESCRIPTION for ~S." name)))))
+
 (/show0 "code/defstruct.lisp end of file")