[armedbear-cvs] r13897 - trunk/abcl/src/org/armedbear/lisp
rschlatte at common-lisp.net
rschlatte at common-lisp.net
Wed Mar 28 21:14:29 UTC 2012
Author: rschlatte
Date: Wed Mar 28 14:14:28 2012
New Revision: 13897
Log:
Add type, documentation slots to slot-definition class.
Modified:
trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java
trunk/abcl/src/org/armedbear/lisp/SlotDefinitionClass.java
trunk/abcl/src/org/armedbear/lisp/clos.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java Wed Mar 28 12:23:05 2012 (r13896)
+++ trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java Wed Mar 28 14:14:28 2012 (r13897)
@@ -42,6 +42,8 @@
super(StandardClass.STANDARD_SLOT_DEFINITION,
StandardClass.STANDARD_SLOT_DEFINITION.getClassLayout().getLength());
slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = NIL;
+ slots[SlotDefinitionClass.SLOT_INDEX_TYPE] = T;
+ slots[SlotDefinitionClass.SLOT_INDEX_DOCUMENTATION] = NIL;
}
public SlotDefinition(StandardClass clazz) {
@@ -58,6 +60,8 @@
slots[SlotDefinitionClass.SLOT_INDEX_READERS] = NIL;
slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION] = Keyword.INSTANCE;
slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = NIL;
+ slots[SlotDefinitionClass.SLOT_INDEX_TYPE] = T;
+ slots[SlotDefinitionClass.SLOT_INDEX_DOCUMENTATION] = NIL;
}
public SlotDefinition(LispObject name, LispObject readers)
@@ -474,4 +478,75 @@
return second;
}
};
+
+ private static final Primitive _SLOT_DEFINITION_TYPE
+ = new pf__slot_definition_type();
+ @DocString(name="%slot-definition-type")
+ private static final class pf__slot_definition_type extends Primitive
+ {
+ pf__slot_definition_type()
+ {
+ super("%slot-definition-type", PACKAGE_SYS, true, "slot-definition");
+ }
+ @Override
+ public LispObject execute(LispObject arg)
+ {
+ return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_TYPE];
+ }
+ };
+
+ private static final Primitive SET_SLOT_DEFINITION_TYPE
+ = new pf_set_slot_definition_type();
+ @DocString(name="set-slot-definition-type",
+ args="slot-definition type")
+ private static final class pf_set_slot_definition_type extends Primitive
+ {
+ pf_set_slot_definition_type()
+ {
+ super("set-slot-definition-type", PACKAGE_SYS, true,
+ "slot-definition type");
+ }
+ @Override
+ public LispObject execute(LispObject first, LispObject second)
+ {
+ checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_TYPE] = second;
+ return second;
+ }
+ };
+
+ private static final Primitive _SLOT_DEFINITION_DOCUMENTATION
+ = new pf__slot_definition_documentation();
+ @DocString(name="%slot-definition-documentation")
+ private static final class pf__slot_definition_documentation extends Primitive
+ {
+ pf__slot_definition_documentation()
+ {
+ super("%slot-definition-documentation", PACKAGE_SYS, true, "slot-definition");
+ }
+ @Override
+ public LispObject execute(LispObject arg)
+ {
+ return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_DOCUMENTATION];
+ }
+ };
+
+ private static final Primitive SET_SLOT_DEFINITION_DOCUMENTATION
+ = new pf_set_slot_definition_documentation();
+ @DocString(name="set-slot-definition-documentation",
+ args="slot-definition documentation")
+ private static final class pf_set_slot_definition_documentation extends Primitive
+ {
+ pf_set_slot_definition_documentation()
+ {
+ super("set-slot-definition-documentation", PACKAGE_SYS, true,
+ "slot-definition documentation");
+ }
+ @Override
+ public LispObject execute(LispObject first, LispObject second)
+ {
+ checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_DOCUMENTATION] = second;
+ return second;
+ }
+ };
+
}
Modified: trunk/abcl/src/org/armedbear/lisp/SlotDefinitionClass.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/SlotDefinitionClass.java Wed Mar 28 12:23:05 2012 (r13896)
+++ trunk/abcl/src/org/armedbear/lisp/SlotDefinitionClass.java Wed Mar 28 14:14:28 2012 (r13897)
@@ -46,6 +46,8 @@
public static final int SLOT_INDEX_ALLOCATION = 6;
public static final int SLOT_INDEX_ALLOCATION_CLASS = 7;
public static final int SLOT_INDEX_LOCATION = 8;
+ public static final int SLOT_INDEX_TYPE = 9;
+ public static final int SLOT_INDEX_DOCUMENTATION = 10;
/**
* For internal use only. This constructor hardcodes the layout of the class, and can't be used
@@ -63,7 +65,9 @@
pkg.intern("WRITERS"),
pkg.intern("ALLOCATION"),
pkg.intern("ALLOCATION-CLASS"),
- pkg.intern("LOCATION")
+ pkg.intern("LOCATION"),
+ Symbol.TYPE,
+ Symbol.DOCUMENTATION
};
setClassLayout(new Layout(this, instanceSlotNames, NIL));
//Set up slot definitions so that this class can be extended by users
Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp Wed Mar 28 12:23:05 2012 (r13896)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Wed Mar 28 14:14:28 2012 (r13897)
@@ -302,13 +302,13 @@
(error 'program-error
"duplicate slot option :TYPE for slot named ~S"
name))
- (setf type (cadr olist))) ;; FIXME type is ignored
+ (setf type (cadr olist)))
(:documentation
(when documentation
(error 'program-error
"duplicate slot option :DOCUMENTATION for slot named ~S"
name))
- (setf documentation (cadr olist))) ;; FIXME documentation is ignored
+ (setf documentation (cadr olist)))
(:reader
(maybe-note-name-defined (cadr olist))
(push-on-end (cadr olist) readers))
@@ -338,6 +338,8 @@
,@(when initargs `(:initargs ',initargs))
,@(when readers `(:readers ',readers))
,@(when writers `(:writers ',writers))
+ ,@(when type `(:type ',type))
+ ,@(when documentation `(:documentation ',documentation))
, at other-options
, at non-std-options))))
@@ -432,14 +434,30 @@
(defun (setf slot-definition-location) (value slot-definition)
(set-slot-definition-location slot-definition value))
+(defun slot-definition-type (slot-definition)
+ (%slot-definition-type slot-definition))
+
+(declaim (notinline (setf slot-definition-type)))
+(defun (setf slot-definition-type) (value slot-definition)
+ (set-slot-definition-type slot-definition value))
+
+(defun slot-definition-documentation (slot-definition)
+ (%slot-definition-documentation slot-definition))
+
+(declaim (notinline (setf slot-definition-documentation)))
+(defun (setf slot-definition-documentation) (value slot-definition)
+ (set-slot-definition-documentation slot-definition value))
+
(defun init-slot-definition (slot &key name
- (initargs ())
- (initform nil)
- (initfunction nil)
- (readers ())
- (writers ())
- (allocation :instance)
- (allocation-class nil))
+ (initargs ())
+ (initform nil)
+ (initfunction nil)
+ (readers ())
+ (writers ())
+ (allocation :instance)
+ (allocation-class nil)
+ (type t)
+ (documentation nil))
(setf (slot-definition-name slot) name)
(setf (slot-definition-initargs slot) initargs)
(setf (slot-definition-initform slot) initform)
@@ -448,6 +466,8 @@
(setf (slot-definition-writers slot) writers)
(setf (slot-definition-allocation slot) allocation)
(setf (slot-definition-allocation-class slot) allocation-class)
+ (setf (slot-definition-type slot) type)
+ (setf (slot-definition-documentation slot) documentation)
slot)
(defun make-direct-slot-definition (class &rest args)
@@ -752,10 +772,10 @@
instance))
(defun make-instance-standard-class (metaclass
- &rest initargs
+ &rest initargs
&key name direct-superclasses direct-slots
- direct-default-initargs
- documentation)
+ direct-default-initargs
+ documentation)
(declare (ignore metaclass))
(let ((class (std-allocate-instance +the-standard-class+)))
(check-initargs (list #'allocate-instance #'initialize-instance)
@@ -2976,6 +2996,12 @@
(defmethod (setf documentation) (new-value (x standard-method) (doc-type (eql 't)))
(setf (method-documentation x) new-value))
+(defmethod documentation ((x standard-slot-definition) (doc-type (eql 't)))
+ (slot-definition-documentation x))
+
+(defmethod (setf documentation) (new-value (x standard-slot-definition) (doc-type (eql 't)))
+ (setf (slot-definition-documentation x) new-value))
+
(defmethod documentation ((x package) (doc-type (eql 't)))
(%documentation x doc-type))
@@ -3626,7 +3652,29 @@
(set-slot-definition-location slot-definition value)
(setf (slot-value slot-definition 'sys::location) value))))
-;;; No %slot-definition-type.
+(atomic-defgeneric slot-definition-type (slot-definition)
+ (:method ((slot-definition slot-definition))
+ (slot-definition-dispatch slot-definition
+ (%slot-definition-type slot-definition)
+ (slot-value slot-definition 'cl:type))))
+
+(atomic-defgeneric (setf slot-definition-type) (value slot-definition)
+ (:method (value (slot-definition slot-definition))
+ (slot-definition-dispatch slot-definition
+ (set-slot-definition-type slot-definition value)
+ (setf (slot-value slot-definition 'cl:type) value))))
+
+(atomic-defgeneric slot-definition-documentation (slot-definition)
+ (:method ((slot-definition slot-definition))
+ (slot-definition-dispatch slot-definition
+ (%slot-definition-documentation slot-definition)
+ (slot-value slot-definition 'cl:documentation))))
+
+(atomic-defgeneric (setf slot-definition-documentation) (value slot-definition)
+ (:method (value (slot-definition slot-definition))
+ (slot-definition-dispatch slot-definition
+ (set-slot-definition-documentation slot-definition value)
+ (setf (slot-value slot-definition 'cl:documentation) value))))
;;; Conditions.
More information about the armedbear-cvs
mailing list