X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/e8d4fa4537a1655714ad8bbbf9b7ba2d85ead959..f4efa7fff2efa6a3144fc664683137df92c42f91:/src/standard-descriptions/clos.lisp

diff --git a/src/standard-descriptions/clos.lisp b/src/standard-descriptions/clos.lisp
index 0fc53af..f9e661c 100644
--- 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)
- ((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)
@@ -29,7 +31,7 @@
   (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 
@@ -39,11 +41,12 @@
 				 :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
-							  :value ,names)
+							  :value ',names)
 							slots)))	
 		:metaclass 'standard-description-class)))
     
@@ -73,10 +76,18 @@
   (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)))
+
+