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