Changeset 12933

Timestamp:

10/01/10 21:22:10 (13 years ago)

Author:

ehuelsmann

Message:

Fix #106: DEFSTRUCT :include with :conc-name.

File:

• trunk/abcl/src/org/armedbear/lisp/defstruct.lisp (modified) (12 diffs)

trunk/abcl/src/org/armedbear/lisp/defstruct.lisp

@@ -50 +50 @@
 (defmacro dd-direct-slots (x)        `(aref ,x 12))
 (defmacro dd-slots (x)               `(aref ,x 13))
+(defmacro dd-inherited-accessors (x) `(aref ,x 14))
 
 (defun make-defstruct-description (&key name
@@ -64 +65 @@
                                         print-object
                                         direct-slots
-                                        slots)
-  (let ((dd (make-array 14)))
+                                        slots
+                                        inherited-accessors)
+  (let ((dd (make-array 15)))
     (setf (dd-name dd) name
           (dd-conc-name dd) conc-name
@@ -79 +81 @@
           (dd-print-object dd) print-object
           (dd-direct-slots dd) direct-slots
-          (dd-slots dd) slots)
+          (dd-slots dd) slots
+          (dd-inherited-accessors dd) inherited-accessors)
     dd))
 
@@ -122 +125 @@
 (defvar *dd-direct-slots*)
 (defvar *dd-slots*)
+(defvar *dd-inherited-accessors*)
 
 (defun keywordify (symbol)
@@ -327 +331 @@
 
 (defun define-reader (slot)
-  (let ((accessor-name (if *dd-conc-name*
-                           (intern (concatenate 'string
-                                                (symbol-name *dd-conc-name*)
-                                                (symbol-name (dsd-name slot))))
-                           (dsd-name slot)))
+  (let ((accessor-name (dsd-reader slot))
         (index (dsd-index slot))
         (type (dsd-type slot)))
@@ -354 +354 @@
 
 (defun define-writer (slot)
-  (let ((accessor-name (if *dd-conc-name*
-                           (intern (concatenate 'string
-                                                (symbol-name *dd-conc-name*)
-                                                (symbol-name (dsd-name slot))))
-                           (dsd-name slot)))
+  (let ((accessor-name (dsd-reader slot))
         (index (dsd-index slot)))
     (cond ((eq *dd-type* 'list)
@@ -379 +375 @@
   (let ((result ()))
     (dolist (slot *dd-slots*)
-      (setf result (nconc result (define-reader slot)))
-      (unless (dsd-read-only slot)
-        (setf result (nconc result (define-writer slot)))))
+      (let ((accessor-name (dsd-reader slot)))
+        (unless (assoc accessor-name *dd-inherited-accessors*)
+          (setf result (nconc result (define-reader slot)))
+          (unless (dsd-read-only slot)
+            (setf result (nconc result (define-writer slot)))))))
     result))
 
@@ -477 +475 @@
                                 print-object
                                 direct-slots
-                                slots)
+                                slots
+                                inherited-accessors)
   (setf (get name 'structure-definition)
         (make-defstruct-description :name name
@@ -492 +491 @@
                                     :print-object print-object
                                     :direct-slots direct-slots
-                                    :slots slots))
+                                    :slots slots
+                                    :inherited-accessors inherited-accessors))
   (when (or (null type) named)
     (make-structure-class name direct-slots slots (car include)))
@@ -513 +513 @@
         (*dd-print-object* nil)
         (*dd-direct-slots* ())
-        (*dd-slots* ()))
+        (*dd-slots* ())
+        (*dd-inherited-accessors* ()))
     (parse-name-and-options (if (atom name-and-options)
                                 (list name-and-options)
@@ -557 +558 @@
             ;; MUST COPY SLOT DESCRIPTION!
             (setf dsd (copy-seq dsd))
-            (setf (dsd-index dsd) index)
+            (setf (dsd-index dsd) index
+                  (dsd-reader dsd)
+                  (if *dd-conc-name*
+                      (intern (concatenate 'string
+                                           (symbol-name *dd-conc-name*)
+                                           (symbol-name (dsd-name dsd))))
+                      (dsd-name dsd)))
             (push dsd *dd-slots*)
-            (incf index)))
+            (incf index))
+          (setf *dd-inherited-accessors* (dd-inherited-accessors dd))
+          (dolist (dsd (dd-direct-slots dd))
+            (push (cons (dsd-reader dsd) (dsd-name dsd))
+                  *dd-inherited-accessors*)))
         (when (cdr *dd-include*)
           (dolist (slot (cdr *dd-include*))
@@ -606 +617 @@
                              ,@(if *dd-print-object* `(:print-object ',*dd-print-object*))
                              :direct-slots ',*dd-direct-slots*
-                             :slots ',*dd-slots*))
+                             :slots ',*dd-slots*
+                             :inherited-accessors ',*dd-inherited-accessors*))
        ,@(define-constructors)
        ,@(define-predicate)