Changeset 12757

Timestamp:

06/18/10 22:48:30 (13 years ago)

Author:

astalla

Message:

User-defined slot definition support: fixed slot-definition initialization.

File:

• trunk/abcl/src/org/armedbear/lisp/clos.lisp (modified) (22 diffs)

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

@@ -164 +164 @@
             (readers ())
             (writers ())
-            (other-options ()))
+            (other-options ())
+      (non-std-options ()))
         (do ((olist (cdr spec) (cddr olist)))
             ((null olist))
@@ -209 +210 @@
              (push-on-end `(setf ,(cadr olist)) writers))
             (t
-             (error 'program-error
-                    "invalid initialization argument ~S for slot named ~S"
-                    (car olist) name))))
+       (push-on-end (car olist) non-std-options)
+             (push-on-end (cadr olist) non-std-options))))
+;     (error 'program-error
+;                    "invalid initialization argument ~S for slot named ~S"
+;                    (car olist) name))
         `(list
           :name ',name
@@ -220 +223 @@
           ,@(when readers `(:readers ',readers))
           ,@(when writers `(:writers ',writers))
-          ,@other-options))))
+          ,@other-options
+    ,@non-std-options))))
 
 (defun maybe-note-name-defined (name)
@@ -267 +271 @@
   (%slot-definition-allocation slot-definition))
 
+(declaim (notinline (setf slot-definition-allocation)))
 (defun (setf slot-definition-allocation) (value slot-definition)
   (set-slot-definition-allocation slot-definition value))
@@ -273 +278 @@
   (%slot-definition-initargs slot-definition))
 
+(declaim (notinline (setf slot-definition-initargs)))
 (defun (setf slot-definition-initargs) (value slot-definition)
   (set-slot-definition-initargs slot-definition value))
@@ -279 +285 @@
   (%slot-definition-initform slot-definition))
 
+(declaim (notinline (setf slot-definition-initform)))
 (defun (setf slot-definition-initform) (value slot-definition)
   (set-slot-definition-initform slot-definition value))
@@ -285 +292 @@
   (%slot-definition-initfunction slot-definition))
 
+(declaim (notinline (setf slot-definition-initfunction)))
 (defun (setf slot-definition-initfunction) (value slot-definition)
   (set-slot-definition-initfunction slot-definition value))
@@ -291 +299 @@
   (%slot-definition-name slot-definition))
 
+(declaim (notinline (setf slot-definition-name)))
 (defun (setf slot-definition-name) (value slot-definition)
   (set-slot-definition-name slot-definition value))
@@ -297 +306 @@
   (%slot-definition-readers slot-definition))
 
+(declaim (notinline (setf slot-definition-readers)))
 (defun (setf slot-definition-readers) (value slot-definition)
   (set-slot-definition-readers slot-definition value))
@@ -303 +313 @@
   (%slot-definition-writers slot-definition))
 
+(declaim (notinline (setf slot-definition-writers)))
 (defun (setf slot-definition-writers) (value slot-definition)
   (set-slot-definition-writers slot-definition value))
@@ -309 +320 @@
   (%slot-definition-allocation-class slot-definition))
 
+(declaim (notinline (setf slot-definition-allocation-class)))
 (defun (setf slot-definition-allocation-class) (value slot-definition)
   (set-slot-definition-allocation-class slot-definition value))
@@ -385 +397 @@
         (:class
          (unless (%slot-definition-location slot)
-           (let ((allocation-class (%slot-definition-allocation-class slot)))
+           (let ((allocation-class (slot-definition-allocation-class slot)))
              (set-slot-definition-location slot
                                            (if (eq allocation-class class)
@@ -397 +409 @@
                (old-location (layout-slot-location old-layout slot-name)))
           (unless old-location
-            (let* ((slot-definition (find slot-name (class-slots class) :key #'slot-definition-name))
+            (let* ((slot-definition (find slot-name (class-slots class) :key 'slot-definition-name))
                    (initfunction (slot-definition-initfunction slot-definition)))
               (when initfunction
@@ -500 +512 @@
                                (class-precedence-list class)))
          (all-names (remove-duplicates
-                     (mapcar #'slot-definition-name all-slots))))
+                     (mapcar 'slot-definition-name all-slots))))
     (mapcar #'(lambda (name)
                (funcall
@@ -508 +520 @@
                 class
                 (remove name all-slots
-                        :key #'slot-definition-name
+                        :key 'slot-definition-name
                         :test-not #'eq)))
             all-names)))
@@ -514 +526 @@
 (defun std-compute-effective-slot-definition (class direct-slots)
   (let ((initer (find-if-not #'null direct-slots
-                             :key #'slot-definition-initfunction)))
+                             :key 'slot-definition-initfunction)))
     (make-effective-slot-definition
      class
@@ -525 +537 @@
                        nil)
      :initargs (remove-duplicates
-                (mapappend #'slot-definition-initargs
+                (mapappend 'slot-definition-initargs
                            direct-slots))
      :allocation (slot-definition-allocation (car direct-slots))
-     :allocation-class (%slot-definition-allocation-class (car direct-slots)))))
+     :allocation-class (when (slot-boundp (car direct-slots)
+            'sys::allocation-class)
+       ;;for some classes created in Java
+       ;;(e.g. SimpleCondition) this slot is unbound
+       (slot-definition-allocation-class (car direct-slots))))))
 
 ;;; Standard instance slot access
@@ -590 +606 @@
 (defun std-slot-exists-p (instance slot-name)
   (not (null (find slot-name (class-slots (class-of instance))
-                   :key #'slot-definition-name))))
+                   :key 'slot-definition-name))))
 
 (defun slot-exists-p (object slot-name)
@@ -639 +655 @@
     (setf (class-direct-slots class) slots)
     (dolist (direct-slot slots)
-      (dolist (reader (%slot-definition-readers direct-slot))
+      (dolist (reader (slot-definition-readers direct-slot))
         (add-reader-method class reader (slot-definition-name direct-slot)))
-      (dolist (writer (%slot-definition-writers direct-slot))
+      (dolist (writer (slot-definition-writers direct-slot))
         (add-writer-method class writer (slot-definition-name direct-slot)))))
   (setf (class-direct-default-initargs class) direct-default-initargs)
@@ -2316 +2332 @@
   (declare (ignore slot-names)) ;;TODO?
   (declare (ignore name initargs initform initfunction readers writers allocation))
-  (apply #'init-slot-definition slot args))
+  ;;For built-in slots
+  (apply #'init-slot-definition slot args)
+  ;;For user-defined slots
+  (call-next-method))
 
 ;;; change-class
@@ -2333 +2352 @@
       (when (instance-slot-p new-slot)
         (let* ((slot-name (slot-definition-name new-slot))
-               (old-slot (find slot-name old-slots :key #'slot-definition-name)))
+               (old-slot (find slot-name old-slots :key 'slot-definition-name)))
           ;; "The values of slots specified as shared in the class CFROM and as
           ;; local in the class CTO are retained."
@@ -2356 +2375 @@
          (remove-if #'(lambda (slot-name)
                        (slot-exists-p old slot-name))
-                    (mapcar #'slot-definition-name
+                    (mapcar 'slot-definition-name
                             (class-slots (class-of new))))))
     (check-initargs new added-slots initargs)