e7c5f95a |
1 | (in-package :lisp-on-lines) |
2 | |
b1c8f43b |
3 | (defvar *object* nil) |
4 | (defvar *description*) |
5 | |
4358148e |
6 | (define-layered-function description-of (thing) |
7 | (:method (thing) |
8 | (find-description 't))) |
e7c5f95a |
9 | |
4358148e |
10 | (defun description-print-name (description) |
11 | (description-class-name (class-of description))) |
e7c5f95a |
12 | |
13 | (defun description-attributes (description) |
b7657b86 |
14 | (description-class-attributes (class-of description))) |
6de8d300 |
15 | |
b1c8f43b |
16 | (defun description-current-attributes (description) |
17 | (remove-if-not |
18 | (lambda (attribute) |
19 | (and |
20 | (some #'layer-active-p |
21 | (mapcar #'find-layer |
22 | (slot-definition-layers |
23 | (attribute-effective-attribute-definition attribute)))))) |
24 | (description-attributes description))) |
25 | |
26 | (defun description-active-attributes (description) |
27 | (remove-if-not |
28 | #'attribute-active-p |
29 | (description-attributes description))) |
30 | |
3d5707d5 |
31 | (defun find-attribute (description attribute-name &optional (errorp t)) |
32 | (or (find attribute-name (description-attributes description) |
33 | :key #'attribute-name) |
e8fd1a9a |
34 | (when errorp (error "No attribute named ~A found in ~A describing ~A" attribute-name description (described-object description))))) |
b7657b86 |
35 | |
36 | (define-layered-function description-active-descriptions (description) |
37 | (:method ((description standard-description-object)) |
38 | (attribute-value (find-attribute description 'active-descriptions))) |
39 | (:method ((description attribute)) |
40 | (attribute-active-descriptions description))) |
41 | |
42 | (define-layered-function description-inactive-descriptions (description) |
43 | (:method ((description standard-description-object)) |
44 | (attribute-value (find-attribute description 'inactive-descriptions))) |
45 | (:method ((description attribute)) |
46 | (attribute-inactive-descriptions description))) |
4358148e |
47 | |
48 | (define-layered-function attributes (description) |
49 | (:method (description) |
6de8d300 |
50 | (let* ((active-attributes |
51 | (find-attribute description 'active-attributes)) |
52 | (attributes (when active-attributes |
b1c8f43b |
53 | (ignore-errors (attribute-value active-attributes))))) |
2548f054 |
54 | (remove-if-not |
55 | (lambda (attribute) |
56 | (and attribute |
57 | (attribute-active-p attribute) |
58 | (some #'layer-active-p |
59 | (mapcar #'find-layer |
60 | (slot-definition-layers |
61 | (attribute-effective-attribute-definition attribute)))))) |
62 | (if attributes |
63 | (mapcar (lambda (spec) |
64 | (find-attribute |
65 | description |
66 | (if (listp spec) |
67 | (car spec) |
68 | spec))) |
69 | attributes) |
6de8d300 |
70 | (description-attributes description)))))) |
71 | |
72 | |
b1c8f43b |
73 | (defun funcall-with-described-object (function object description &rest args) |
74 | (setf description (or description (description-of object))) |
75 | (let ((*description* description) |
76 | (*object* object)) |
77 | (dletf (((described-object *description*) object)) |
78 | (funcall-with-layer-context |
79 | (modify-layer-context |
80 | (if (standard-description-p *description*) |
81 | (adjoin-layer *description* (current-layer-context)) |
82 | (current-layer-context)) |
83 | :activate (description-active-descriptions *description*) |
84 | :deactivate (description-inactive-descriptions *description*)) |
85 | (lambda () (contextl::funcall-with-special-initargs |
86 | (loop |
87 | :for (key val) :on args :by #'cddr |
88 | :collect (list (find key (description-attributes *description*) |
89 | :key #'attribute-keyword) |
90 | :value val)) |
91 | (lambda () |
92 | (contextl::funcall-with-special-initargs |
93 | (let ((attribute (ignore-errors (find-attribute *description* 'active-attributes)))) |
94 | (when attribute |
95 | (loop for spec in (attribute-value attribute) |
96 | if (listp spec) |
97 | collect (cons (or |
98 | (find-attribute *description* (car spec)) |
99 | (error "No attribute matching ~A" (car spec))) |
100 | (cdr spec))))) |
101 | function)))))))) |
6de8d300 |
102 | |
e7c5f95a |
103 | |
f56d6e7e |
104 | |
b1c8f43b |
105 | |
4358148e |
106 | (defmacro define-description (name &optional superdescriptions &body options) |
107 | (let ((description-name (defining-description name))) |
108 | (destructuring-bind (&optional slots &rest options) options |
109 | (let ((description-layers (cdr (assoc :in-description options)))) |
110 | (if description-layers |
4271ab0b |
111 | `(progn ;eval-when (:compile-toplevel :load-toplevel :execute) |
4358148e |
112 | ,@(loop |
113 | :for layer |
114 | :in description-layers |
115 | :collect `(define-description |
116 | ,name ,superdescriptions ,slots |
117 | ,@(acons |
118 | :in-layer (defining-description layer) |
119 | (remove :in-description options :key #'car))))) |
4271ab0b |
120 | `(progn ;eval-when (:compile-toplevel :load-toplevel :execute) |
4358148e |
121 | ; `(progn |
122 | (defclass ,description-name |
123 | ,(append (mapcar #'defining-description |
124 | superdescriptions) |
125 | (unless (or (eq t name) |
126 | (assoc :mixinp options)) |
127 | (list (defining-description t)))) |
128 | ,(if slots slots '()) |
129 | ,@options |
130 | ,@(unless (assoc :metaclass options) |
131 | '((:metaclass standard-description-class)))) |
f2ff8a16 |
132 | (initialize-descriptions) |
4358148e |
133 | (find-description ',name))))))) |
134 | |
135 | |
136 | |
137 | |
138 | |
139 | |
140 | |
141 | |
e7c5f95a |
142 | |
e7c5f95a |
143 | |
144 | |
145 | |
146 | |
147 | |
148 | |
149 | |
150 | |
151 | |
152 | |
153 | |