Use CLOSER-COMMON-LISP package to resolve conflicts between CL and C2MOP
[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
eeed4326 16(define-description standard-object ()
17 ((editp :value t)
18 (class-slots :label "Slots"
19 :function (compose 'class-slots 'class-of)))
20 (:in-description editable))
21
22(define-layered-class slot-definition-attribute (define-description-attribute)
b7657b86 23 ((slot-name :initarg :slot-name
24 :accessor attribute-slot-name
25 :layered t)))
81d70610 26
e8fd1a9a 27
28(define-layered-method attribute-active-p :around ((attribute slot-definition-attribute))
29 (let ((active? (slot-value attribute 'activep)))
30 (if (and (eq :when active?)
31 (unbound-slot-value-p (attribute-value attribute)))
32 NIL
33
34 (call-next-method))))
35
36(define-layered-method attribute-active-p
37 :in-layer #.(defining-description 'editable)
38 :around ((attribute slot-definition-attribute))
39 (let ((active? (slot-value attribute 'activep)))
40 (if (and (eq :when active?)
41 (unbound-slot-value-p (attribute-value attribute)))
42 t
43 (call-next-method))))
44
6de8d300 45(defmethod shared-initialize :around ((object slot-definition-attribute)
46 slots &rest args)
eeed4326 47 (with-active-descriptions (editable)
48 (prog1 (call-next-method)
49 (unless (attribute-setter object)
50 (setf (attribute-setter object)
51 (lambda (v o)
52 (setf (slot-value o (attribute-slot-name object)) v)))))))
6de8d300 53
54
e8d4fa45 55(define-layered-method attribute-value-using-object (object (attribute slot-definition-attribute))
4271ab0b 56 (if (slot-boundp object (attribute-slot-name attribute))
57
58 (slot-value object (attribute-slot-name attribute))
b7657b86 59 +unbound-slot+))
4271ab0b 60
2548f054 61(defun attribute-slot-makunbound (attribute)
62 (slot-makunbound (attribute-object attribute) (attribute-slot-name attribute)))
63
64(defun ensure-description-for-class (class &key attributes (name (intern (format nil "DESCRIPTION-FOR-~A" (class-name class))))
65 direct-superclasses direct-slot-specs)
66
67 (let* ((super-descriptions
68 (mapcar #'class-of
69 (delete nil (mapcar (rcurry #'find-description nil)
70 (mapcar #'class-name direct-superclasses)))))
71 (desc-class
eeed4326 72 (ensure-layer (defining-description name)
2548f054 73 :direct-superclasses (or super-descriptions (list (class-of (find-description 'standard-object))))
74 :direct-slots
75 (loop
76 :for slot in (class-slots class)
77 :collect
78 (let ((direct-spec
79 (find (slot-definition-name slot)
80 direct-slot-specs
81 :key (rcurry 'getf :name))))
82 (if direct-spec
83 (append (alexandria:remove-from-plist direct-spec
84 :initfunction
85 :initform
86 :initargs
87 :readers
88 :writers)
89 (unless
90 (getf direct-spec :attribute-class)
91 (list :attribute-class 'slot-definition-attribute))
92 (unless
93 (getf direct-spec :label)
94 (list :label (format nil
95 "~@(~A~)" (substitute #\Space #\- (symbol-name (slot-definition-name slot))))))
96 (list :slot-name (slot-definition-name slot)))
97 `(:name ,(slot-definition-name slot)
98 :attribute-class slot-definition-attribute
99 :slot-name ,(slot-definition-name slot)
100 :label ,(format nil
101 "~@(~A~)" (substitute #\Space #\- (symbol-name (slot-definition-name slot)))))))
102 :into slots
6de8d300 103 :collect (slot-definition-name slot) :into names
104 :finally (return (cons `(:name active-attributes
2548f054 105 :value ',(or attributes names))
6de8d300 106 slots)))
eeed4326 107 :metaclass 'define-description-class)))
6de8d300 108 (unless (ignore-errors (find-description (class-name class)))
eeed4326 109 (find-layer (ensure-layer (defining-description (class-name class))
110 :direct-superclasses (list desc-class)
111 :metaclass 'define-description-class)))))
6de8d300 112
e8d4fa45 113
6de8d300 114(defclass described-class ()
2548f054 115 ((direct-slot-specs :accessor class-direct-slot-specs)
116 (attributes :initarg :attributes :initform nil)))
117
118(defmethod ensure-class-using-class :around ((class described-class) name &rest args)
119
120 (call-next-method))
121
122(defmethod direct-slot-definition-class ((class described-class) &rest initargs)
123 (let ((slot-class (call-next-method)))
124 (make-instance (class-of slot-class) :direct-superclasses (list slot-class (find-class 'described-class-direct-slot-definition)))))
125
126(defclass described-class-direct-slot-definition ()
6de8d300 127 ())
128
2548f054 129(defmethod shared-initialize :around ((class described-class-direct-slot-definition) slot-names &key &allow-other-keys)
130 (call-next-method))
131
6de8d300 132(defmethod validate-superclass
133 ((class described-class)
134 (superclass standard-class))
135 t)
136
2548f054 137(defmethod initialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '()) direct-slots)
6de8d300 138 (declare (dynamic-extent initargs))
139 (finalize-inheritance class)
2548f054 140 (ensure-description-for-class class :direct-slot-specs direct-slots
141 :direct-superclasses direct-superclasses
142 :attributes (slot-value class 'attributes)))
6de8d300 143
2548f054 144(defmethod reinitialize-instance :after ((class described-class) &rest initargs &key (direct-superclasses '()) direct-slots)
6de8d300 145 (declare (dynamic-extent initargs))
146 (finalize-inheritance class)
2548f054 147 (ensure-description-for-class class :direct-slot-specs direct-slots
148 :direct-superclasses direct-superclasses
149 :attributes (slot-value class 'attributes)))
6de8d300 150
2548f054 151(defclass described-standard-class (described-class standard-class ) ())
f4efa7ff 152
153(defmethod validate-superclass
154 ((class described-standard-class)
155 (superclass standard-class))
156 t)
6de8d300 157
4358148e 158(define-layered-method description-of ((object standard-object))
4271ab0b 159 (or (ignore-errors (find-description (class-name (class-of object))))
160 (find-description 'standard-object)))
f4efa7ff 161
162
4358148e 163