Changeset 12756

Timestamp:

06/17/10 20:14:10 (13 years ago)

Author:

astalla

Message:

Simple slot-* support for structures.

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

• StructureObject.java (modified) (1 diff)
• autoloads.lisp (modified) (1 diff)
• clos.lisp (modified) (9 diffs)

trunk/abcl/src/org/armedbear/lisp/StructureObject.java

@@ -152 +152 @@
   {
     return structureClass;
+  }
+
+    protected int getSlotIndex(LispObject slotName) {
+  LispObject effectiveSlots = structureClass.getSlotDefinitions();
+  LispObject[] effectiveSlotsArray = effectiveSlots.copyToArray();
+  for (int i = 0; i < slots.length; i++) {
+      SimpleVector slotDefinition = (SimpleVector) effectiveSlotsArray[i];
+      LispObject candidateSlotName = slotDefinition.AREF(1);
+      if(slotName == candidateSlotName) {
+    return i;
+      }
+  }
+  return -1;
+    }
+
+  @Override
+  public LispObject SLOT_VALUE(LispObject slotName)
+  {
+    LispObject value;
+    final int index = getSlotIndex(slotName);
+    if (index >= 0) {
+        value = slots[index];
+    } else {
+  value = UNBOUND_VALUE;
+        value = Symbol.SLOT_UNBOUND.execute(structureClass, this, slotName);
+        LispThread.currentThread()._values = null;
+    }
+    return value;
+  }
+
+  public void setSlotValue(LispObject slotName, LispObject newValue) {
+      final int index = getSlotIndex(slotName);
+      if (index >= 0) {
+    slots[index] = newValue;
+      } else {
+    LispObject[] args = new LispObject[5];
+    args[0] = structureClass;
+    args[1] = this;
+    args[2] = slotName;
+    args[3] = Symbol.SETF;
+    args[4] = newValue;
+    Symbol.SLOT_MISSING.execute(args);
+      }
   }
 

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

@@ -124 +124 @@
             define-method-combination
             %defgeneric
-            canonicalize-direct-superclasses)
+            canonicalize-direct-superclasses
+      slot-value slot-makunbound slot-boundp)
           "clos")
 (export '(ensure-class subclassp %defgeneric canonicalize-direct-superclasses)

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

@@ -54 +54 @@
 (export '(class-precedence-list class-slots))
 (defconstant +the-standard-class+ (find-class 'standard-class))
+(defconstant +the-structure-class+ (find-class 'structure-class))
 (defconstant +the-standard-object-class+ (find-class 'standard-object))
 (defconstant +the-standard-method-class+ (find-class 'standard-method))
@@ -293 +294 @@
   (set-slot-definition-name slot-definition value))
 
+(defun slot-definition-readers (slot-definition)
+  (%slot-definition-readers slot-definition))
+
+(defun (setf slot-definition-readers) (value slot-definition)
+  (set-slot-definition-readers slot-definition value))
+
+(defun slot-definition-writers (slot-definition)
+  (%slot-definition-writers slot-definition))
+
+(defun (setf slot-definition-writers) (value slot-definition)
+  (set-slot-definition-writers slot-definition value))
+
+(defun slot-definition-allocation-class (slot-definition)
+  (%slot-definition-allocation-class slot-definition))
+
+(defun (setf slot-definition-allocation-class) (value slot-definition)
+  (set-slot-definition-allocation-class slot-definition value))
+
 (defun init-slot-definition (slot &key name
            (initargs ())
@@ -306 +325 @@
   (setf (slot-definition-initform slot) initform)
   (setf (slot-definition-initfunction slot) initfunction)
-  (set-slot-definition-readers slot readers)
-  (set-slot-definition-writers slot writers)
+  (setf (slot-definition-readers slot) readers)
+  (setf (slot-definition-writers slot) writers)
   (setf (slot-definition-allocation slot) allocation)
-  (set-slot-definition-allocation-class slot allocation-class)
+  (setf (slot-definition-allocation-class slot) allocation-class)
   slot)
 
@@ -533 +552 @@
 
 (defun slot-value (object slot-name)
-  (if (eq (class-of (class-of object)) +the-standard-class+)
+  (if (or (eq (class-of (class-of object)) +the-standard-class+)
+    (eq (class-of (class-of object)) +the-structure-class+))
       (std-slot-value object slot-name)
       (slot-value-using-class (class-of object) object slot-name)))
@@ -540 +560 @@
 
 (defun %set-slot-value (object slot-name new-value)
-  (if (eq (class-of (class-of object)) +the-standard-class+)
+  (if (or (eq (class-of (class-of object)) +the-standard-class+)
+    (eq (class-of (class-of object)) +the-structure-class+))
       (setf (std-slot-value object slot-name) new-value)
       (set-slot-value-using-class new-value (class-of object)
@@ -2121 +2142 @@
 (defmethod slot-boundp-using-class ((class standard-class) instance slot-name)
   (std-slot-boundp instance slot-name))
+(defmethod slot-boundp-using-class ((class structure-class) instance slot-name)
+  "Structure slots can't be unbound, so this method always returns T."
+  (declare (ignore class instance slot-name))
+  t)
 
 (defgeneric slot-makunbound-using-class (class instance slot-name))
@@ -2127 +2152 @@
                                         slot-name)
   (std-slot-makunbound instance slot-name))
+(defmethod slot-makunbound-using-class ((class structure-class)
+                                        instance
+                                        slot-name)
+  (declare (ignore class instance slot-name))
+  (error "Structure slots can't be unbound"))
 
 (defgeneric slot-missing (class instance slot-name operation &optional new-value))
@@ -2425 +2455 @@
     slot-definition-initform
     slot-definition-initfunction
-    slot-definition-name))
+    slot-definition-name
+    slot-definition-readers
+    slot-definition-writers
+    slot-definition-allocation-class))
 
 (defmacro slot-definition-dispatch (slot-definition std-form generic-form)
@@ -2495 +2528 @@
       (set-slot-definition-name slot-definition value)
       (setf (slot-value slot-definition 'sys::name) value))))
+
+(defgeneric slot-definition-readers (slot-definition)
+  (:method ((slot-definition slot-definition))
+    (slot-definition-dispatch slot-definition
+      (%slot-definition-readers slot-definition)
+      (slot-value slot-definition 'sys::readers))))
+
+(defgeneric (setf slot-definition-readers) (value slot-definition)
+  (:method (value (slot-definition slot-definition))
+    (slot-definition-dispatch slot-definition
+      (set-slot-definition-readers slot-definition value)
+      (setf (slot-value slot-definition 'sys::readers) value))))
+
+(defgeneric slot-definition-writers (slot-definition)
+  (:method ((slot-definition slot-definition))
+    (slot-definition-dispatch slot-definition
+      (%slot-definition-writers slot-definition)
+      (slot-value slot-definition 'sys::writers))))
+
+(defgeneric (setf slot-definition-writers) (value slot-definition)
+  (:method (value (slot-definition slot-definition))
+    (slot-definition-dispatch slot-definition
+      (set-slot-definition-writers slot-definition value)
+      (setf (slot-value slot-definition 'sys::writers) value))))
+
+(defgeneric slot-definition-allocation-class (slot-definition)
+  (:method ((slot-definition slot-definition))
+    (slot-definition-dispatch slot-definition
+      (%slot-definition-allocation-class slot-definition)
+      (slot-value slot-definition 'sys::allocation-class))))
+
+(defgeneric (setf slot-definition-allocation-class) (value slot-definition)
+  (:method (value (slot-definition slot-definition))
+    (slot-definition-dispatch slot-definition
+      (set-slot-definition-allocation-class slot-definition value)
+      (setf (slot-value slot-definition 'sys::allocation-class) value))))
 
 ;;; No %slot-definition-type.