e7c5f95a |
1 | (in-package :lisp-on-lines) |
2 | |
4358148e |
3 | (define-layered-function description-of (thing) |
4 | (:method (thing) |
5 | (find-description 't))) |
e7c5f95a |
6 | |
4358148e |
7 | (defun description-print-name (description) |
8 | (description-class-name (class-of description))) |
e7c5f95a |
9 | |
10 | (defun description-attributes (description) |
b7657b86 |
11 | (description-class-attributes (class-of description))) |
6de8d300 |
12 | |
b7657b86 |
13 | (defun find-attribute (description attribute-name) |
14 | (find attribute-name (description-attributes description) |
15 | :key #'attribute-name)) |
16 | |
17 | (define-layered-function description-active-descriptions (description) |
18 | (:method ((description standard-description-object)) |
19 | (attribute-value (find-attribute description 'active-descriptions))) |
20 | (:method ((description attribute)) |
21 | (attribute-active-descriptions description))) |
22 | |
23 | (define-layered-function description-inactive-descriptions (description) |
24 | (:method ((description standard-description-object)) |
25 | (attribute-value (find-attribute description 'inactive-descriptions))) |
26 | (:method ((description attribute)) |
27 | (attribute-inactive-descriptions description))) |
4358148e |
28 | |
29 | (define-layered-function attributes (description) |
30 | (:method (description) |
6de8d300 |
31 | (let* ((active-attributes |
32 | (find-attribute description 'active-attributes)) |
33 | (attributes (when active-attributes |
e8d4fa45 |
34 | (attribute-value active-attributes)))) |
6de8d300 |
35 | (if attributes |
36 | (mapcar (lambda (spec) |
37 | (find-attribute |
38 | description |
39 | (if (listp spec) |
40 | (car spec) |
41 | spec))) |
42 | attributes) |
43 | (remove-if-not |
44 | (lambda (attribute) |
45 | (and (attribute-active-p attribute) |
46 | (some #'layer-active-p |
47 | (mapcar #'find-layer |
48 | (slot-definition-layers |
49 | (attribute-effective-attribute-definition attribute)))))) |
50 | (description-attributes description)))))) |
51 | |
52 | |
53 | |
54 | |
e7c5f95a |
55 | |
4358148e |
56 | |
57 | ;;; A handy macro. |
58 | (defmacro define-description (name &optional superdescriptions &body options) |
59 | (let ((description-name (defining-description name))) |
60 | (destructuring-bind (&optional slots &rest options) options |
61 | (let ((description-layers (cdr (assoc :in-description options)))) |
62 | (if description-layers |
4271ab0b |
63 | `(progn ;eval-when (:compile-toplevel :load-toplevel :execute) |
4358148e |
64 | ,@(loop |
65 | :for layer |
66 | :in description-layers |
67 | :collect `(define-description |
68 | ,name ,superdescriptions ,slots |
69 | ,@(acons |
70 | :in-layer (defining-description layer) |
71 | (remove :in-description options :key #'car))))) |
4271ab0b |
72 | `(progn ;eval-when (:compile-toplevel :load-toplevel :execute) |
4358148e |
73 | ; `(progn |
74 | (defclass ,description-name |
75 | ,(append (mapcar #'defining-description |
76 | superdescriptions) |
77 | (unless (or (eq t name) |
78 | (assoc :mixinp options)) |
79 | (list (defining-description t)))) |
80 | ,(if slots slots '()) |
81 | ,@options |
82 | ,@(unless (assoc :metaclass options) |
83 | '((:metaclass standard-description-class)))) |
f2ff8a16 |
84 | (initialize-descriptions) |
4358148e |
85 | (find-description ',name))))))) |
86 | |
87 | |
88 | |
89 | |
90 | |
91 | |
92 | |
93 | |
e7c5f95a |
94 | |
e7c5f95a |
95 | |
96 | |
97 | |
98 | |
99 | |
100 | |
101 | |
102 | |
103 | |
104 | |
105 | |