0.pre7.34:

	merged MNA "small defstruct patch" sbcl-devel 2001-09-03

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index dd97a6d..621520e 100644 (file)
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -571,7 +571,7 @@
 ;;; Parse a slot description for DEFSTRUCT, add it to the description
 ;;; and return it. If supplied, ISLOT is a pre-initialized DSD that we
 ;;; modify to get the new slot. This is supplied when handling
-;;; included slots. 
+;;; included slots.
 (defun parse-1-dsd (defstruct spec &optional
                     (islot (make-defstruct-slot-description :%name ""
                                                             :index 0
@@ -590,10 +590,9 @@
                  read-only ro-p)))
        (t
        (when (keywordp spec)
-         ;; FIXME: should be style warning
-         (warn "Keyword slot name indicates probable syntax ~
-                error in DEFSTRUCT: ~S."
-               spec))
+         (style-warn "Keyword slot name indicates probable syntax ~
+                      error in DEFSTRUCT: ~S."
+                     spec))
        spec))
 
     (when (find name (dd-slots defstruct) :test #'string= :key #'dsd-%name)
@@ -602,8 +601,25 @@
             :format-arguments (list name)))
     (setf (dsd-%name islot) (string name))
     (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list islot)))
-    (setf (dsd-accessor islot)
-         (symbolicate (or (dd-conc-name defstruct) "") name))
+
+    (let ((accessor-name (symbolicate (or (dd-conc-name defstruct) "") name))
+         (predicate-name (dd-predicate defstruct)))
+      (setf (dsd-accessor islot) accessor-name)
+      (when (eql accessor-name predicate-name)
+       ;; Some adventurous soul has named a slot so that its accessor
+       ;; collides with the structure type predicate. ANSI doesn't
+       ;; specify what to do in this case. As of 2001-09-04, Martin
+       ;; Atzmueller reports that CLISP and Lispworks both give
+       ;; priority to the slot accessor, so that the predicate is
+       ;; overwritten. We might as well do the same (as well as
+       ;; signalling a warning).
+       (style-warn
+        "~@<The structure accessor name ~S is the same as the name of the ~
+          structure type predicate. ANSI doesn't specify what to do in ~
+          this case; this implementation chooses to overwrite the type ~
+          predicate with the slot accessor.~@:>"
+        accessor-name)
+       (setf (dd-predicate defstruct) nil)))
 
     (when default-p
       (setf (dsd-default islot) default))

diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp
index 91a361b..4df8479 100644 (file)
--- a/src/code/target-defstruct.lisp
+++ b/src/code/target-defstruct.lisp
@@ -250,10 +250,7 @@
   ;; FIXME: CMU CL used (%INSTANCEP OBJ) here. Check that
   ;; (TYPEP OBJ 'INSTANCE) is optimized to equally efficient code.
   (and (typep obj 'instance)
-       (let (;; FIXME: Mightn't there be a slight efficiency improvement
-            ;; by delaying the binding of DEPTHOID 'til it's needed?
-            (depthoid (layout-depthoid layout))
-            (obj-layout (%instance-layout obj)))
+       (let ((obj-layout (%instance-layout obj)))
         (cond ((eq obj-layout layout)
                t)
               ;; FIXME: Does the test for LAYOUT-INVALID really belong
@@ -264,9 +261,10 @@
                       :expected-type (layout-class obj-layout)
                       :datum obj))
               (t
-               (and (> (layout-depthoid obj-layout) depthoid)
-                    (eq (svref (layout-inherits obj-layout) depthoid)
-                        layout)))))))
+                 (let ((depthoid (layout-depthoid layout)))
+                   (and (> (layout-depthoid obj-layout) depthoid)
+                        (eq (svref (layout-inherits obj-layout) depthoid)
+                            layout))))))))
 \f
 ;;;; implementing structure slot accessors as closures
 
@@ -305,12 +303,7 @@
              (unless (structure-test structure)
                (error 'simple-type-error
                       :datum structure
-                      ;; FIXME: :EXPECTED-TYPE should be something
-                      ;; comprehensible to the user, not this. Perhaps we
-                      ;; could work backwards from the LAYOUT-CLASS slot to
-                      ;; find something. (Note that all four SIMPLE-TYPE-ERROR
-                      ;; calls in this section have the same disease.)
-                      :expected-type '(satisfies structure-test)
+                      :expected-type (class-name (layout-class layout))
                       :format-control
                       "Structure for accessor ~S is not a ~S:~% ~S"
                       :format-arguments
@@ -342,7 +335,7 @@
              (unless (structure-test structure)
                (error 'simple-type-error
                       :datum structure
-                      :expected-type '(satisfies structure-test)
+                      :expected-type (class-name (layout-class layout))
                       :format-control
                       "The structure for setter ~S is not a ~S:~% ~S"
                       :format-arguments
@@ -352,7 +345,7 @@
              (unless  (typep-test new-value)
                (error 'simple-type-error
                       :datum new-value
-                      :expected-type '(satisfies typep-test)
+                      :expected-type (class-name (layout-class layout))
                       :format-control
                       "The new value for setter ~S is not a ~S:~% ~S"
                       :format-arguments
@@ -369,7 +362,7 @@
              (unless (structure-test structure)
                (error 'simple-type-error
                       :datum structure
-                      :expected-type '(satisfies structure-test)
+                      :expected-type (class-name (layout-class layout))
                       :format-control
                       "The structure for setter ~S is not a ~S:~% ~S"
                       :format-arguments
@@ -379,7 +372,7 @@
              (unless  (typep-test new-value)
                (error 'simple-type-error
                       :datum new-value
-                      :expected-type '(satisfies typep-test)
+                      :expected-type (class-name (layout-class layout))
                       :format-control
                       "The new value for setter ~S is not a ~S:~% ~S"
                       :format-arguments

diff --git a/version.lisp-expr b/version.lisp-expr
index 64e2199..ea6734b 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; for internal versions, especially for internal versions off the
 ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.pre7.33"
+"0.pre7.34"