1 (in-package :lisp-on-lines
)
3 (defstruct unbound-slot-value
(s))
5 (defvar +unbound-slot
+ (make-unbound-slot-value))
7 (defmethod print-object ((object unbound-slot-value
) stream
)
8 (print-unreadable-object (object stream
)
9 (format stream
"UNBOUND")))
11 (define-description standard-object
()
13 (class-slots :label
"Slots"
14 :function
(compose 'class-slots
'class-of
))))
16 (define-layered-class slot-definition-attribute
(standard-attribute)
17 ((slot-name :initarg
:slot-name
18 :accessor attribute-slot-name
21 (defmethod shared-initialize :around
((object slot-definition-attribute
)
23 (prog1 (call-next-method)
24 (unless (attribute-setter object
)
25 (setf (attribute-setter object
)
27 (setf (slot-value o
(attribute-slot-name object
)) v
))))))
30 (define-layered-method attribute-value-using-object
(object (attribute slot-definition-attribute
))
31 (if (slot-boundp object
(attribute-slot-name attribute
))
33 (slot-value object
(attribute-slot-name attribute
))
36 (defun ensure-description-for-class (class &optional
(name (intern (format nil
"DESCRIPTION-FOR-~A" (class-name class
)))))
38 (ensure-class (defining-description name
)
39 :direct-superclasses
(list (class-of (find-description 'standard-object
)))
40 :direct-slots
(loop :for slot in
(class-slots class
)
41 :collect
`(:name
,(slot-definition-name slot
)
42 :attribute-class slot-definition-attribute
43 :slot-name
,(slot-definition-name slot
)
45 "~@(~A~)" (substitute #\Space
#\-
(symbol-name (slot-definition-name slot
)))))
47 :collect
(slot-definition-name slot
) :into names
48 :finally
(return (cons `(:name active-attributes
51 :metaclass
'standard-description-class
)))
53 (unless (ignore-errors (find-description (class-name class
)))
54 (ensure-class (defining-description (class-name class
))
55 :direct-superclasses
(list desc-class
)
56 :metaclass
'standard-description-class
))
57 (find-description name
)))
60 (defclass described-class
()
63 (defmethod validate-superclass
64 ((class described-class
)
65 (superclass standard-class
))
68 (defmethod initialize-instance :after
((class described-class
) &rest initargs
&key
(direct-superclasses '()))
69 (declare (dynamic-extent initargs
))
70 (finalize-inheritance class
)
71 (ensure-description-for-class class
))
74 (defmethod reinitialize-instance :after
((class described-class
) &rest initargs
&key
(direct-superclasses '() direct-superclasses-p
))
75 (declare (dynamic-extent initargs
))
76 (finalize-inheritance class
)
77 (ensure-description-for-class class
))
80 (define-layered-method description-of
((object standard-object
))
81 (or (ignore-errors (find-description (class-name (class-of object
))))
82 (find-description 'standard-object
)))