a3006fa0 |
1 | (in-package :lisp-on-lines) |
2 | |
3 | (defclass display-description-class (standard-description-class) |
4 | ()) |
5 | |
6 | (defmethod description-class-attribute-class ((class display-description-class)) |
7 | 'display-attribute) |
8 | |
9 | (defun label-for-object (object) |
10 | (format nil "~@(~A~)" |
11 | (substitute #\Space #\- |
12 | (symbol-name |
13 | (class-name (class-of |
14 | object)))))) |
15 | #+nil(defdescription t () |
16 | ((label :label nil |
17 | :function label-for-object) |
18 | (identity :label nil :function identity) |
19 | (type :label "Type" :function type-of) |
20 | (class :label "Class" :function class-of) |
21 | (attribute-delimiter :label "Attribute Delimiter" |
22 | :value "~%" |
23 | :activep nil |
24 | :keyword :delimter) |
25 | |
26 | (label-formatter :value princ-to-string |
27 | :activep nil) |
28 | (value-formatter :value princ-to-string |
29 | :activep nil)) |
30 | (:metaclass standard-description-class)) |
31 | |
32 | #+nil(defmethod initialize-instance :around ((class display-description-class) &rest initargs &key (direct-superclasses '())) |
33 | (declare (dynamic-extent initargs)) |
34 | (prog1 |
35 | (if (loop for direct-superclass in direct-superclasses |
36 | thereis (ignore-errors (subtypep direct-superclass (class-of (find-description t))))) |
37 | (call-next-method) |
38 | (apply #'call-next-method |
39 | class |
40 | :direct-superclasses |
41 | (append direct-superclasses |
42 | (list (class-of (find-description 't)))) |
43 | initargs)))) |
44 | |
45 | |
46 | #+nil(defmethod reinitialize-instance :around ((class display-description-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p)) |
47 | (declare (dynamic-extent initargs)) |
48 | ; (warn "CLASS ~A ARGS ~A:" class initargs) |
49 | (prog1 |
50 | (if (or (not direct-superclasses-p) |
51 | (loop for direct-superclass in direct-superclasses |
52 | thereis (ignore-errors (subtypep direct-superclass (class-of (find-description t)))))) |
53 | (call-next-method) |
54 | (apply #'call-next-method |
55 | class |
56 | :direct-superclasses |
57 | (append direct-superclasses |
58 | (list (class-of (find-description 't)))) |
59 | initargs)))) |