Changeset 12756


Ignore:
Timestamp:
06/17/10 20:14:10 (12 years ago)
Author:
astalla
Message:

Simple slot-* support for structures.

Location:
trunk/abcl/src/org/armedbear/lisp
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/StructureObject.java

    r12513 r12756  
    152152  {
    153153    return structureClass;
     154  }
     155
     156    protected int getSlotIndex(LispObject slotName) {
     157  LispObject effectiveSlots = structureClass.getSlotDefinitions();
     158  LispObject[] effectiveSlotsArray = effectiveSlots.copyToArray();
     159  for (int i = 0; i < slots.length; i++) {
     160      SimpleVector slotDefinition = (SimpleVector) effectiveSlotsArray[i];
     161      LispObject candidateSlotName = slotDefinition.AREF(1);
     162      if(slotName == candidateSlotName) {
     163    return i;
     164      }
     165  }
     166  return -1;
     167    }
     168
     169  @Override
     170  public LispObject SLOT_VALUE(LispObject slotName)
     171  {
     172    LispObject value;
     173    final int index = getSlotIndex(slotName);
     174    if (index >= 0) {
     175        value = slots[index];
     176    } else {
     177  value = UNBOUND_VALUE;
     178        value = Symbol.SLOT_UNBOUND.execute(structureClass, this, slotName);
     179        LispThread.currentThread()._values = null;
     180    }
     181    return value;
     182  }
     183
     184  public void setSlotValue(LispObject slotName, LispObject newValue) {
     185      final int index = getSlotIndex(slotName);
     186      if (index >= 0) {
     187    slots[index] = newValue;
     188      } else {
     189    LispObject[] args = new LispObject[5];
     190    args[0] = structureClass;
     191    args[1] = this;
     192    args[2] = slotName;
     193    args[3] = Symbol.SETF;
     194    args[4] = newValue;
     195    Symbol.SLOT_MISSING.execute(args);
     196      }
    154197  }
    155198
  • trunk/abcl/src/org/armedbear/lisp/autoloads.lisp

    r12682 r12756  
    124124            define-method-combination
    125125            %defgeneric
    126             canonicalize-direct-superclasses)
     126            canonicalize-direct-superclasses
     127      slot-value slot-makunbound slot-boundp)
    127128          "clos")
    128129(export '(ensure-class subclassp %defgeneric canonicalize-direct-superclasses)
  • trunk/abcl/src/org/armedbear/lisp/clos.lisp

    r12753 r12756  
    5454(export '(class-precedence-list class-slots))
    5555(defconstant +the-standard-class+ (find-class 'standard-class))
     56(defconstant +the-structure-class+ (find-class 'structure-class))
    5657(defconstant +the-standard-object-class+ (find-class 'standard-object))
    5758(defconstant +the-standard-method-class+ (find-class 'standard-method))
     
    293294  (set-slot-definition-name slot-definition value))
    294295
     296(defun slot-definition-readers (slot-definition)
     297  (%slot-definition-readers slot-definition))
     298
     299(defun (setf slot-definition-readers) (value slot-definition)
     300  (set-slot-definition-readers slot-definition value))
     301
     302(defun slot-definition-writers (slot-definition)
     303  (%slot-definition-writers slot-definition))
     304
     305(defun (setf slot-definition-writers) (value slot-definition)
     306  (set-slot-definition-writers slot-definition value))
     307
     308(defun slot-definition-allocation-class (slot-definition)
     309  (%slot-definition-allocation-class slot-definition))
     310
     311(defun (setf slot-definition-allocation-class) (value slot-definition)
     312  (set-slot-definition-allocation-class slot-definition value))
     313
    295314(defun init-slot-definition (slot &key name
    296315           (initargs ())
     
    306325  (setf (slot-definition-initform slot) initform)
    307326  (setf (slot-definition-initfunction slot) initfunction)
    308   (set-slot-definition-readers slot readers)
    309   (set-slot-definition-writers slot writers)
     327  (setf (slot-definition-readers slot) readers)
     328  (setf (slot-definition-writers slot) writers)
    310329  (setf (slot-definition-allocation slot) allocation)
    311   (set-slot-definition-allocation-class slot allocation-class)
     330  (setf (slot-definition-allocation-class slot) allocation-class)
    312331  slot)
    313332
     
    533552
    534553(defun slot-value (object slot-name)
    535   (if (eq (class-of (class-of object)) +the-standard-class+)
     554  (if (or (eq (class-of (class-of object)) +the-standard-class+)
     555    (eq (class-of (class-of object)) +the-structure-class+))
    536556      (std-slot-value object slot-name)
    537557      (slot-value-using-class (class-of object) object slot-name)))
     
    540560
    541561(defun %set-slot-value (object slot-name new-value)
    542   (if (eq (class-of (class-of object)) +the-standard-class+)
     562  (if (or (eq (class-of (class-of object)) +the-standard-class+)
     563    (eq (class-of (class-of object)) +the-structure-class+))
    543564      (setf (std-slot-value object slot-name) new-value)
    544565      (set-slot-value-using-class new-value (class-of object)
     
    21212142(defmethod slot-boundp-using-class ((class standard-class) instance slot-name)
    21222143  (std-slot-boundp instance slot-name))
     2144(defmethod slot-boundp-using-class ((class structure-class) instance slot-name)
     2145  "Structure slots can't be unbound, so this method always returns T."
     2146  (declare (ignore class instance slot-name))
     2147  t)
    21232148
    21242149(defgeneric slot-makunbound-using-class (class instance slot-name))
     
    21272152                                        slot-name)
    21282153  (std-slot-makunbound instance slot-name))
     2154(defmethod slot-makunbound-using-class ((class structure-class)
     2155                                        instance
     2156                                        slot-name)
     2157  (declare (ignore class instance slot-name))
     2158  (error "Structure slots can't be unbound"))
    21292159
    21302160(defgeneric slot-missing (class instance slot-name operation &optional new-value))
     
    24252455    slot-definition-initform
    24262456    slot-definition-initfunction
    2427     slot-definition-name))
     2457    slot-definition-name
     2458    slot-definition-readers
     2459    slot-definition-writers
     2460    slot-definition-allocation-class))
    24282461
    24292462(defmacro slot-definition-dispatch (slot-definition std-form generic-form)
     
    24952528      (set-slot-definition-name slot-definition value)
    24962529      (setf (slot-value slot-definition 'sys::name) value))))
     2530
     2531(defgeneric slot-definition-readers (slot-definition)
     2532  (:method ((slot-definition slot-definition))
     2533    (slot-definition-dispatch slot-definition
     2534      (%slot-definition-readers slot-definition)
     2535      (slot-value slot-definition 'sys::readers))))
     2536
     2537(defgeneric (setf slot-definition-readers) (value slot-definition)
     2538  (:method (value (slot-definition slot-definition))
     2539    (slot-definition-dispatch slot-definition
     2540      (set-slot-definition-readers slot-definition value)
     2541      (setf (slot-value slot-definition 'sys::readers) value))))
     2542
     2543(defgeneric slot-definition-writers (slot-definition)
     2544  (:method ((slot-definition slot-definition))
     2545    (slot-definition-dispatch slot-definition
     2546      (%slot-definition-writers slot-definition)
     2547      (slot-value slot-definition 'sys::writers))))
     2548
     2549(defgeneric (setf slot-definition-writers) (value slot-definition)
     2550  (:method (value (slot-definition slot-definition))
     2551    (slot-definition-dispatch slot-definition
     2552      (set-slot-definition-writers slot-definition value)
     2553      (setf (slot-value slot-definition 'sys::writers) value))))
     2554
     2555(defgeneric slot-definition-allocation-class (slot-definition)
     2556  (:method ((slot-definition slot-definition))
     2557    (slot-definition-dispatch slot-definition
     2558      (%slot-definition-allocation-class slot-definition)
     2559      (slot-value slot-definition 'sys::allocation-class))))
     2560
     2561(defgeneric (setf slot-definition-allocation-class) (value slot-definition)
     2562  (:method (value (slot-definition slot-definition))
     2563    (slot-definition-dispatch slot-definition
     2564      (set-slot-definition-allocation-class slot-definition value)
     2565      (setf (slot-value slot-definition 'sys::allocation-class) value))))
    24972566
    24982567;;; No %slot-definition-type.
Note: See TracChangeset for help on using the changeset viewer.