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