Properties are special now!
[clinton/lisp-on-lines.git] / src / standard-descriptions / clos.lisp
CommitLineData
4358148e 1(in-package :lisp-on-lines)
2
6de8d300 3(defstruct unbound-slot-value (s))
4
5(defvar +unbound-slot+ (make-unbound-slot-value))
6
7(defmethod print-object ((object unbound-slot-value) stream)
8 (print-unreadable-object (object stream)
9 (format stream "UNBOUND")))
10
4358148e 11(define-description standard-object ()
6de8d300 12 ((editp :value t)
13 (class-slots :label "Slots"
4358148e 14 :function (compose 'class-slots 'class-of))))
15
81d70610 16(define-layered-class slot-definition-attribute (standard-attribute)
17 ((slot-name :initarg :slot-name :accessor attribute-slot-name)))
18
6de8d300 19(defmethod shared-initialize :around ((object slot-definition-attribute)
20 slots &rest args)
21 (prog1 (call-next-method)
22 (unless (attribute-setter object)
23 (setf (attribute-setter object)
24 (lambda (v o)
25 (setf (slot-value o (attribute-slot-name object)) v))))))
26
27
81d70610 28(define-layered-method attribute-value (object (attribute slot-definition-attribute))
4271ab0b 29 (if (slot-boundp object (attribute-slot-name attribute))
30
31 (slot-value object (attribute-slot-name attribute))
32 (gensym "UNBOUND-SLOT-")))
33
6de8d300 34(defun ensure-description-for-class (class &optional (name (intern (format nil "DESCRIPTION-FOR-~A" (class-name class)))))
35 (let ((desc-class
36 (ensure-class (defining-description name)
37 :direct-superclasses (list (class-of (find-description 'standard-object)))
38 :direct-slots (loop :for slot in (class-slots class)
39 :collect `(:name ,(slot-definition-name slot)
40 :attribute-class slot-definition-attribute
41 :slot-name ,(slot-definition-name slot)
42 :label ,(slot-definition-name slot))
43 :into slots
44 :collect (slot-definition-name slot) :into names
45 :finally (return (cons `(:name active-attributes
46 :value ,names)
47 slots)))
48 :metaclass 'standard-description-class)))
4271ab0b 49
6de8d300 50 (unless (ignore-errors (find-description (class-name class)))
51 (ensure-class (defining-description (class-name class))
52 :direct-superclasses (list desc-class)
53 :metaclass 'standard-description-class))
54 (find-description name)))
55
56(defclass described-class ()
57 ())
58
59(defmethod validate-superclass
60 ((class described-class)
61 (superclass standard-class))
62 t)
63
64(defmethod initialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '()))
65 (declare (dynamic-extent initargs))
66 (finalize-inheritance class)
67 (ensure-description-for-class class))
68
69
70(defmethod reinitialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p))
71 (declare (dynamic-extent initargs))
72 (finalize-inheritance class)
73 (ensure-description-for-class class))
74
75
76
77
4358148e 78(define-layered-method description-of ((object standard-object))
4271ab0b 79 (or (ignore-errors (find-description (class-name (class-of object))))
80 (find-description 'standard-object)))
81
4358148e 82
83
84