Changeset 12758 for trunk/abcl/src/org/armedbear/lisp/clos.lisp

Timestamp:

06/18/10 23:15:52 (13 years ago)

Author:

astalla

Message:

Custom slot definition: slot-location managed like the other slot properties.

File:

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

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

@@ -324 +324 @@
   (set-slot-definition-allocation-class slot-definition value))
 
+(defun slot-definition-location (slot-definition)
+  (%slot-definition-location slot-definition))
+
+(declaim (notinline (setf slot-definition-location-class)))
+(defun (setf slot-definition-location) (value slot-definition)
+  (set-slot-definition-location slot-definition value))
+
 (defun init-slot-definition (slot &key name
            (initargs ())
@@ -392 +399 @@
       (case (slot-definition-allocation slot)
         (:instance
-         (set-slot-definition-location slot length)
+         (setf (slot-definition-location slot) length)
          (incf length)
          (push (slot-definition-name slot) instance-slots))
         (:class
-         (unless (%slot-definition-location slot)
+         (unless (slot-definition-location slot)
            (let ((allocation-class (slot-definition-allocation-class slot)))
-             (set-slot-definition-location slot
-                                           (if (eq allocation-class class)
-                                               (cons (slot-definition-name slot) +slot-unbound+)
-                                               (slot-location allocation-class (slot-definition-name slot))))))
-         (push (%slot-definition-location slot) shared-slots))))
+             (setf (slot-definition-location slot)
+       (if (eq allocation-class class)
+           (cons (slot-definition-name slot) +slot-unbound+)
+           (slot-location allocation-class (slot-definition-name slot))))))
+         (push (slot-definition-location slot) shared-slots))))
     (when old-layout
       ;; Redefined class: initialize added shared slots.
@@ -560 +567 @@
   (let ((slot (find-slot-definition class slot-name)))
     (if slot
-        (%slot-definition-location slot)
+        (slot-definition-location slot)
         nil)))
 
@@ -2584 +2591 @@
       (setf (slot-value slot-definition 'sys::allocation-class) value))))
 
+(defgeneric slot-definition-location (slot-definition)
+  (:method ((slot-definition slot-definition))
+    (slot-definition-dispatch slot-definition
+      (%slot-definition-location slot-definition)
+      (slot-value slot-definition 'sys::location))))
+
+(defgeneric (setf slot-definition-location) (value slot-definition)
+  (:method (value (slot-definition slot-definition))
+    (slot-definition-dispatch slot-definition
+      (set-slot-definition-location slot-definition value)
+      (setf (slot-value slot-definition 'sys::location) value))))
+
 ;;; No %slot-definition-type.