0.8.6.28:

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

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index e4f0119..391aae1 100644 (file)
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -49,7 +49,7 @@
           ;; slow, so if anyone cares about performance of
           ;; non-toplevel DEFSTRUCTs, it should be rewritten to be
           ;; cleverer. -- WHN 2002-10-23
-          (sb!c::compiler-note
+          (sb!c:compiler-notify
            "implementation limitation: ~
              Non-toplevel DEFSTRUCT constructors are slow.")
           (with-unique-names (layout)
@@ -455,7 +455,7 @@
          (let ((inherited (accessor-inherited-data name defstruct)))
            (cond
              ((not inherited)
-              (stuff `(proclaim '(inline ,name (setf ,name))))
+              (stuff `(declaim (inline ,name (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
@@ -805,9 +805,16 @@
                           (dsd-index included-slot))
                     (dd-inherited-accessor-alist dd)
                     :test #'eq :key #'car))
-         (parse-1-dsd dd
-                      modified
-                      (copy-structure included-slot)))))))
+         (let ((new-slot (parse-1-dsd dd
+                                       modified
+                                       (copy-structure included-slot))))
+            (when (and (neq (dsd-type new-slot) (dsd-type included-slot))
+                       (not (subtypep (dsd-type included-slot)
+                                      (dsd-type new-slot)))
+                       (dsd-safe-p included-slot))
+              (setf (dsd-safe-p new-slot) nil)
+              ;; XXX: notify?
+              )))))))
 \f
 ;;;; various helper functions for setting up DEFSTRUCTs
 
@@ -986,7 +993,7 @@
 
     (let ((predicate-name (dd-predicate-name dd)))
       (when predicate-name
-       (sb!xc:proclaim `(ftype (sfunction (t) t) ,predicate-name))
+       (sb!xc:proclaim `(ftype (sfunction (t) boolean) ,predicate-name))
        ;; Provide inline expansion (or not).
        (ecase (dd-type dd)
          ((structure funcallable-structure)
@@ -1442,17 +1449,26 @@
     (unless (or defaults boas)
       (push (symbolicate "MAKE-" (dd-name defstruct)) defaults))
 
-    (collect ((res))
+    (collect ((res) (names))
       (when defaults
-       (let ((cname (first defaults)))
-         (setf (dd-default-constructor defstruct) cname)
-         (res (create-keyword-constructor defstruct creator))
-         (dolist (other-name (rest defaults))
-           (res `(setf (fdefinition ',other-name) (fdefinition ',cname)))
-           (res `(declaim (ftype function ',other-name))))))
+        (let ((cname (first defaults)))
+          (setf (dd-default-constructor defstruct) cname)
+          (res (create-keyword-constructor defstruct creator))
+          (names cname)
+          (dolist (other-name (rest defaults))
+            (res `(setf (fdefinition ',other-name) (fdefinition ',cname)))
+            (names other-name))))
 
       (dolist (boa boas)
-       (res (create-boa-constructor defstruct boa creator)))
+        (res (create-boa-constructor defstruct boa creator))
+        (names (first boa)))
+
+      (res `(declaim (ftype
+                      (sfunction *
+                                 ,(if (eq (dd-type defstruct) 'structure)
+                                      (dd-name defstruct)
+                                      '*))
+                      ,@(names))))
 
       (res))))
 \f