d1a7fc5a |
1 | (in-package :lisp-on-lines) |
2 | |
eeed4326 |
3 | ;;;; A simpler implementation of descriptions based on plists |
4 | |
d1a7fc5a |
5 | (setf (find-class 'simple-attribute nil) nil) |
6 | |
7 | (define-layered-class simple-attribute () |
8 | ((%property-access-function |
eeed4326 |
9 | :initarg property-access-function) |
10 | (%initial-slot-values-plist))) |
d1a7fc5a |
11 | |
12 | (defun ensure-property-access-function (attribute) |
13 | (if (slot-boundp attribute '%property-access-function) |
14 | (slot-value attribute '%property-access-function) |
15 | (let ((fn-name (gensym))) |
16 | (ensure-layered-function fn-name :lambda-list '() :method-combination '(append)) |
17 | (setf (slot-value attribute '%property-access-function) fn-name)))) |
18 | |
19 | (defconstant +property-not-found+ '=lisp-on-lines-property-not-found-indicator=) |
20 | |
21 | (define-layered-method |
22 | contextl:slot-value-using-layer (class (attribute simple-attribute) slotd reader) |
eeed4326 |
23 | (if (or contextl:*symbol-access* |
d1a7fc5a |
24 | (not (slot-definition-layeredp slotd))) |
25 | (call-next-method) |
26 | (let ((value (getf (funcall (ensure-property-access-function attribute)) |
27 | (slot-definition-name slotd) |
28 | +property-not-found+))) |
29 | (if (eq value +property-not-found+) |
30 | (call-next-method) |
31 | value)))) |
32 | |
eeed4326 |
33 | (define-layered-method |
34 | contextl:slot-value-using-layer (class (attribute simple-attribute) slotd reader) |
35 | (if (or contextl:*symbol-access* |
36 | (not (slot-definition-layeredp slotd)) |
37 | (dynamic-symbol-boundp (with-symbol-access (call-next-method)))) |
38 | (call-next-method) |
39 | (let ((value (getf (ignore-errors (funcall (ensure-property-access-function attribute))) |
40 | (slot-definition-name slotd) |
41 | +property-not-found+))) |
42 | (if (eq value +property-not-found+) |
43 | (let ((value (get (ensure-property-access-function attribute) |
44 | (slot-definition-name slotd) |
45 | +property-not-found+))) |
46 | (if (eq value +property-not-found+) |
47 | (call-next-method) |
48 | value)) |
49 | value)))) |
50 | |
51 | (define-layered-method |
52 | (setf contextl:slot-value-using-layer) (value class (attribute simple-attribute) slotd reader) |
53 | (if (and (not contextl:*symbol-access*) |
54 | (slot-definition-layeredp slotd)) |
55 | (setf (get (ensure-property-access-function attribute) (slot-definition-name slotd)) |
56 | value) |
57 | (call-next-method))) |
d1a7fc5a |
58 | |
59 | (defmethod initialize-attribute-for-layer (attribute layer-name &rest args) |
60 | (let* ((class (class-of attribute)) |
eeed4326 |
61 | (slotds (class-slots class))) |
d1a7fc5a |
62 | (ensure-layered-method |
63 | (ensure-property-access-function attribute) |
64 | `(lambda () |
65 | ',(loop |
eeed4326 |
66 | :for (key val) :on args :by #'cddr |
67 | :nconc (list |
68 | (loop |
69 | :for slotd :in slotds |
70 | :do (when (find key (slot-definition-initargs slotd)) |
71 | (return (slot-definition-name slotd)))) |
72 | val))) |
d1a7fc5a |
73 | :qualifiers '(append) |
74 | :in-layer layer-name))) |
75 | |
76 | |
d1a7fc5a |
77 | (define-layered-class direct-attribute-slot-definition-class |
78 | (special-layered-direct-slot-definition |
79 | contextl::singleton-direct-slot-definition) |
80 | ((attribuite-properties |
81 | :accessor slot-definition-attribute-properties |
82 | :documentation "Holds the initargs passed to the slotd"))) |
83 | |
84 | (defmethod initialize-instance |
85 | :after ((slotd direct-attribute-slot-definition-class) |
86 | &rest initargs) |
87 | (setf (slot-definition-attribute-properties slotd) initargs)) |
88 | |
89 | (defmethod reinitialize-instance |
90 | :after ((slotd direct-attribute-slot-definition-class) |
91 | &rest initargs) |
92 | (setf (slot-definition-attribute-properties slotd) initargs)) |
93 | |
94 | (define-layered-class effective-attribute-slot-definition-class |
95 | (special-layered-effective-slot-definition) |
96 | ((attribute-object |
97 | :accessor slot-definition-attribute-object))) |
98 | |
99 | (define-layered-class description-access-class (standard-layer-class contextl::special-layered-access-class) |
100 | ((defined-in-descriptions :initarg :in-description) |
101 | (class-active-attributes-definition :initarg :attributes) |
102 | (mixin-class-p :initarg :mixinp))) |
103 | |
104 | (defmethod direct-slot-definition-class |
105 | ((class description-access-class) &key &allow-other-keys) |
106 | (find-class 'direct-attribute-slot-definition-class)) |
107 | |
108 | (defmethod effective-slot-definition-class |
109 | ((class description-access-class) &key &allow-other-keys) |
110 | (find-class 'effective-attribute-slot-definition-class)) |
111 | (fmakunbound 'initialize-slot-definition-attribute) |
eeed4326 |
112 | |
d1a7fc5a |
113 | (defmethod initialize-slot-definition-attribute ((slotd effective-attribute-slot-definition-class) name direct-slot-definitions) |
114 | (let ((tbl (make-hash-table)) |
115 | (attribute (make-instance 'simple-standard-attribute :name name))) |
eeed4326 |
116 | (loop for ds in direct-slot-definitions |
117 | :when (typep ds 'direct-attribute-slot-definition-class) |
d1a7fc5a |
118 | :do (setf (gethash (slot-definition-layer ds) tbl) |
119 | (append (gethash (slot-definition-layer ds) tbl '()) |
120 | (slot-definition-attribute-properties ds)))) |
121 | (maphash (lambda (layer properties) |
122 | (apply #'initialize-attribute-for-layer attribute layer properties)) |
123 | tbl) |
124 | (setf (slot-definition-attribute-object slotd) attribute))) |
125 | |
126 | (defmethod compute-effective-slot-definition |
127 | ((class description-access-class) name direct-slot-definitions) |
128 | (declare (ignore name)) |
129 | (let ((slotd (call-next-method))) |
eeed4326 |
130 | (initialize-slot-definition-attribute slotd name direct-slot-definitions) |
d1a7fc5a |
131 | slotd)) |
132 | |
133 | (defclass standard-description-class (description-access-class layered-class) |
134 | ((attributes :accessor description-class-attributes :initform (list))) |
135 | (:default-initargs :defining-metaclass 'description-access-class)) |
136 | |
137 | (defmethod validate-superclass |
138 | ((class standard-description-class) |
139 | (superclass standard-class)) |
140 | t) |
141 | |
142 | (define-layered-class standard-description-object (standard-layer-object) |
143 | ((described-object :accessor described-object |
144 | :special t))) |
145 | |
d1a7fc5a |
146 | (defmethod initialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '())) |
147 | (declare (dynamic-extent initargs)) |
148 | (prog1 |
149 | (if (loop for direct-superclass in direct-superclasses |
150 | thereis (ignore-errors (subtypep direct-superclass 'standard-description-object))) |
151 | (call-next-method) |
152 | (apply #'call-next-method |
153 | class |
154 | :direct-superclasses |
155 | (append direct-superclasses |
156 | (list (find-class 'standard-description-object))) |
eeed4326 |
157 | initargs)))) |
d1a7fc5a |
158 | |
159 | |
160 | (defmethod reinitialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p)) |
161 | (declare (dynamic-extent initargs)) |
162 | ; (warn "CLASS ~A ARGS ~A:" class initargs) |
163 | (prog1 |
164 | (if (or (not direct-superclasses-p) |
165 | (loop for direct-superclass in direct-superclasses |
166 | thereis (ignore-errors (subtypep direct-superclass 'standard-description-object)))) |
167 | (call-next-method) |
168 | (apply #'call-next-method |
169 | class |
170 | :direct-superclasses |
171 | (append direct-superclasses |
172 | (list (find-class 'standard-description-object))) |
eeed4326 |
173 | initargs)))) |
174 | |
175 | |
d1a7fc5a |
176 | |
d1a7fc5a |
177 | |
d1a7fc5a |
178 | |
179 | |
180 | |