HCoop
/
clinton
/
lisp-on-lines.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Expanded support for Configurable editing.
[clinton/lisp-on-lines.git]
/
src
/
standard-descriptions
/
clos.lisp
diff --git
a/src/standard-descriptions/clos.lisp
b/src/standard-descriptions/clos.lisp
index
0fc53af
..
f9e661c
100644
(file)
--- a/
src/standard-descriptions/clos.lisp
+++ b/
src/standard-descriptions/clos.lisp
@@
-14,7
+14,9
@@
:function (compose 'class-slots 'class-of))))
(define-layered-class slot-definition-attribute (standard-attribute)
:function (compose 'class-slots 'class-of))))
(define-layered-class slot-definition-attribute (standard-attribute)
- ((slot-name :initarg :slot-name :accessor attribute-slot-name)))
+ ((slot-name :initarg :slot-name
+ :accessor attribute-slot-name
+ :layered t)))
(defmethod shared-initialize :around ((object slot-definition-attribute)
slots &rest args)
(defmethod shared-initialize :around ((object slot-definition-attribute)
slots &rest args)
@@
-29,7
+31,7
@@
(if (slot-boundp object (attribute-slot-name attribute))
(slot-value object (attribute-slot-name attribute))
(if (slot-boundp object (attribute-slot-name attribute))
(slot-value object (attribute-slot-name attribute))
-
(gensym "UNBOUND-SLOT-")
))
+
+unbound-slot+
))
(defun ensure-description-for-class (class &optional (name (intern (format nil "DESCRIPTION-FOR-~A" (class-name class)))))
(let ((desc-class
(defun ensure-description-for-class (class &optional (name (intern (format nil "DESCRIPTION-FOR-~A" (class-name class)))))
(let ((desc-class
@@
-39,11
+41,12
@@
:collect `(:name ,(slot-definition-name slot)
:attribute-class slot-definition-attribute
:slot-name ,(slot-definition-name slot)
:collect `(:name ,(slot-definition-name slot)
:attribute-class slot-definition-attribute
:slot-name ,(slot-definition-name slot)
- :label ,(slot-definition-name slot))
+ :label ,(format nil
+ "~@(~A~)" (substitute #\Space #\- (symbol-name (slot-definition-name slot)))))
:into slots
:collect (slot-definition-name slot) :into names
:finally (return (cons `(:name active-attributes
:into slots
:collect (slot-definition-name slot) :into names
:finally (return (cons `(:name active-attributes
- :value ,names)
+ :value
'
,names)
slots)))
:metaclass 'standard-description-class)))
slots)))
:metaclass 'standard-description-class)))
@@
-73,10
+76,18
@@
(finalize-inheritance class)
(ensure-description-for-class class))
(finalize-inheritance class)
(ensure-description-for-class class))
+(defclass described-standard-class (standard-class described-class) ())
+
+(defmethod validate-superclass
+ ((class described-standard-class)
+ (superclass standard-class))
+ t)
(define-layered-method description-of ((object standard-object))
(or (ignore-errors (find-description (class-name (class-of object))))
(find-description 'standard-object)))
(define-layered-method description-of ((object standard-object))
(or (ignore-errors (find-description (class-name (class-of object))))
(find-description 'standard-object)))
+
+