Recover full backtraces with generic arithmetic on x86 and x86-64

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

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 0f25b5d..a2ee93a 100644 (file)
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -31,20 +31,20 @@
     (and layout (typep (layout-info layout) 'defstruct-description))))
 
 (sb!xc:defmacro %make-structure-instance-macro (dd slot-specs &rest slot-vars)
-  `(truly-the ,(dd-name dd)
-              ,(if (compiler-layout-ready-p (dd-name dd))
-                   `(%make-structure-instance ,dd ,slot-specs ,@slot-vars)
-                   ;; Non-toplevel defstructs don't have a layout at compile time,
-                   ;; so we need to construct the actual function at runtime -- but
-                   ;; we cache it at the call site, so that we don't perform quite
-                   ;; so horribly.
-                   `(let* ((cell (load-time-value (list nil)))
-                           (fun (car cell)))
-                      (if (functionp fun)
-                          (funcall fun ,@slot-vars)
-                          (funcall (setf (car cell)
-                                         (%make-structure-instance-allocator ,dd ,slot-specs))
-                                   ,@slot-vars))))))
+  (if (compiler-layout-ready-p (dd-name dd))
+      `(truly-the ,(dd-name dd)
+                  (%make-structure-instance ,dd ,slot-specs ,@slot-vars))
+      ;; Non-toplevel defstructs don't have a layout at compile time,
+      ;; so we need to construct the actual function at runtime -- but
+      ;; we cache it at the call site, so that we don't perform quite
+      ;; so horribly.
+      `(let* ((cell (load-time-value (list nil)))
+              (fun (car cell)))
+         (if (functionp fun)
+             (funcall fun ,@slot-vars)
+             (funcall (setf (car cell)
+                            (%make-structure-instance-allocator ,dd ,slot-specs))
+                      ,@slot-vars)))))
 
 (declaim (ftype (sfunction (defstruct-description list) function)
                 %make-structure-instance-allocator))
@@ -527,10 +527,6 @@
               ((not inherited)
                (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
-               ;; weird.)
                (stuff `(defun ,name (structure)
                         (declare (type ,ltype structure))
                         (the ,slot-type (elt structure ,index))))
@@ -1127,10 +1123,10 @@
       (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)
+               (setf (info :function :structure-accessor accessor-name) dd)
                (multiple-value-bind (reader-designator writer-designator)
                    (slot-accessor-transforms dd dsd)
                  (sb!xc:proclaim `(ftype (sfunction (,dtype) ,dsd-type)
@@ -1542,7 +1538,9 @@
                          arg
                        (arglist `(,name ,def ,@(if supplied-test-p `(,supplied-test) nil)))
                        (vars name)
-                       (arg-type (get-slot name))))
+                       (arg-type (get-slot name))
+                       (when supplied-test-p
+                         (vars supplied-test))))
                     (t
                      (do-default arg)))))
 
@@ -1573,7 +1571,9 @@
                         (arglist `(,wot ,(if def-p def slot-def)
                                         ,@(if supplied-test-p `(,supplied-test) nil)))
                         (vars name)
-                        (arg-type type key name))))
+                        (arg-type type key name)
+                        (when supplied-test-p
+                          (vars supplied-test)))))
                   (do-default key t))))
 
           (when allowp