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) |
34 | (when errorp (error "No attribute named ~A found in ~A" attribute-name 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))))) |
6de8d300 |
54 | (if attributes |
55 | (mapcar (lambda (spec) |
56 | (find-attribute |
57 | description |
58 | (if (listp spec) |
59 | (car spec) |
60 | spec))) |
61 | attributes) |
62 | (remove-if-not |
63 | (lambda (attribute) |
64 | (and (attribute-active-p attribute) |
65 | (some #'layer-active-p |
66 | (mapcar #'find-layer |
67 | (slot-definition-layers |
68 | (attribute-effective-attribute-definition attribute)))))) |
69 | (description-attributes description)))))) |
70 | |
71 | |
b1c8f43b |
72 | (defun funcall-with-described-object (function object description &rest args) |
73 | (setf description (or description (description-of object))) |
74 | (let ((*description* description) |
75 | (*object* object)) |
76 | (dletf (((described-object *description*) object)) |
77 | (funcall-with-layer-context |
78 | (modify-layer-context |
79 | (if (standard-description-p *description*) |
80 | (adjoin-layer *description* (current-layer-context)) |
81 | (current-layer-context)) |
82 | :activate (description-active-descriptions *description*) |
83 | :deactivate (description-inactive-descriptions *description*)) |
84 | (lambda () (contextl::funcall-with-special-initargs |
85 | (loop |
86 | :for (key val) :on args :by #'cddr |
87 | :collect (list (find key (description-attributes *description*) |
88 | :key #'attribute-keyword) |
89 | :value val)) |
90 | (lambda () |
91 | (contextl::funcall-with-special-initargs |
92 | (let ((attribute (ignore-errors (find-attribute *description* 'active-attributes)))) |
93 | (when attribute |
94 | (loop for spec in (attribute-value attribute) |
95 | if (listp spec) |
96 | collect (cons (or |
97 | (find-attribute *description* (car spec)) |
98 | (error "No attribute matching ~A" (car spec))) |
99 | (cdr spec))))) |
100 | function)))))))) |
6de8d300 |
101 | |
e7c5f95a |
102 | |
b1c8f43b |
103 | (defmacro with-described-object ((object description &rest args) |
104 | &body body) |
105 | `(funcall-with-described-object |
106 | (lambda () ,@body) |
107 | ,object |
108 | ,description |
109 | ,@args)) |
110 | |
4358148e |
111 | (defmacro define-description (name &optional superdescriptions &body options) |
112 | (let ((description-name (defining-description name))) |
113 | (destructuring-bind (&optional slots &rest options) options |
114 | (let ((description-layers (cdr (assoc :in-description options)))) |
115 | (if description-layers |
4271ab0b |
116 | `(progn ;eval-when (:compile-toplevel :load-toplevel :execute) |
4358148e |
117 | ,@(loop |
118 | :for layer |
119 | :in description-layers |
120 | :collect `(define-description |
121 | ,name ,superdescriptions ,slots |
122 | ,@(acons |
123 | :in-layer (defining-description layer) |
124 | (remove :in-description options :key #'car))))) |
4271ab0b |
125 | `(progn ;eval-when (:compile-toplevel :load-toplevel :execute) |
4358148e |
126 | ; `(progn |
127 | (defclass ,description-name |
128 | ,(append (mapcar #'defining-description |
129 | superdescriptions) |
130 | (unless (or (eq t name) |
131 | (assoc :mixinp options)) |
132 | (list (defining-description t)))) |
133 | ,(if slots slots '()) |
134 | ,@options |
135 | ,@(unless (assoc :metaclass options) |
136 | '((:metaclass standard-description-class)))) |
f2ff8a16 |
137 | (initialize-descriptions) |
4358148e |
138 | (find-description ',name))))))) |
139 | |
140 | |
141 | |
142 | |
143 | |
144 | |
145 | |
146 | |
e7c5f95a |
147 | |
e7c5f95a |
148 | |
149 | |
150 | |
151 | |
152 | |
153 | |
154 | |
155 | |
156 | |
157 | |
158 | |