Commit | Line | Data |
---|---|---|
6d0aa5eb | 1 | (in-package :lisp-on-lines) |
2 | ||
3 | (defdynamic described-object nil) | |
4 | (defdynamic description nil) | |
5 | ||
6 | ;;backwards-compat hacks | |
7 | (define-symbol-macro *object* (dynamic described-object)) | |
8 | (define-symbol-macro *description* (dynamic description)) | |
9 | ||
10 | ;; forward compat hacks | |
11 | ||
12 | (defun current-description () | |
13 | (dynamic description)) | |
14 | ||
15 | (define-layered-function description-of (thing) | |
16 | (:method (thing) | |
17 | (find-description 't))) | |
18 | ||
19 | (defun description-print-name (description) | |
20 | (description-class-name (class-of description))) | |
21 | ||
22 | (defun description-attributes (description) | |
23 | (alexandria:hash-table-values (description-class-attributes (class-of description)))) | |
24 | ||
25 | (defun description-current-attributes (description) | |
26 | (remove-if-not | |
27 | (lambda (attribute) | |
28 | (and | |
29 | (some #'layer-active-p | |
30 | (mapcar #'find-layer | |
31 | (slot-definition-layers | |
32 | (attribute-effective-attribute-definition attribute)))))) | |
33 | (description-attributes description))) | |
34 | ||
35 | (defun description-active-attributes (description) | |
36 | (remove-if-not | |
37 | #'attribute-active-p | |
38 | (description-attributes description))) | |
39 | ||
40 | ||
41 | ||
42 | (define-layered-function description-active-descriptions (description) | |
43 | (:method ((description t)) | |
44 | (attribute-value (find-attribute description 'active-descriptions))) | |
45 | (:method ((description attribute)) | |
46 | (attribute-active-descriptions description))) | |
47 | ||
48 | (define-layered-function description-inactive-descriptions (description) | |
49 | (:method ((description t)) | |
50 | (attribute-value (find-attribute description 'inactive-descriptions))) | |
51 | (:method ((description attribute)) | |
52 | (attribute-inactive-descriptions description))) | |
53 | ||
54 | (define-layered-function attributes (description) | |
55 | (:method (description) | |
56 | (let* ((active-attributes | |
57 | (find-attribute description 'active-attributes)) | |
58 | (attributes (when active-attributes | |
59 | (ignore-errors (attribute-value active-attributes))))) | |
60 | (remove-if-not | |
61 | (lambda (attribute) | |
62 | (and attribute | |
63 | (attribute-active-p attribute) | |
64 | (some #'layer-active-p | |
65 | (attribute-layers attribute)))) | |
66 | (if attributes | |
67 | (mapcar (lambda (spec) | |
68 | (find-attribute | |
69 | description | |
70 | (if (listp spec) | |
71 | (car spec) | |
72 | spec))) | |
73 | attributes) | |
74 | (description-attributes description)))))) | |
75 | ||
76 | (defun funcall-with-described-object (function object description &rest args) | |
77 | (setf description (or description (description-of object))) | |
78 | (dynamic-let ((description description) | |
79 | (object object)) | |
80 | (dletf (((described-object description) object)) | |
81 | (funcall-with-layer-context | |
82 | (modify-layer-context (adjoin-layer description (current-layer-context)) | |
83 | :activate (description-active-descriptions description) | |
84 | :deactivate (description-inactive-descriptions description)) | |
85 | (lambda () | |
86 | (with-special-symbol-access | |
87 | (contextl::funcall-with-special-initargs | |
88 | (without-special-symbol-access | |
89 | (loop | |
90 | :for (key val) :on args :by #'cddr | |
91 | :collect (list (find key (description-attributes description) | |
92 | :key #'attribute-keyword) | |
93 | :value val))) | |
94 | (lambda () | |
95 | (contextl::funcall-with-special-initargs | |
96 | (without-special-symbol-access | |
97 | (let ((attribute (ignore-errors (find-attribute description 'active-attributes)))) | |
98 | (when attribute | |
99 | (loop for spec in (attribute-value attribute) | |
100 | if (listp spec) | |
101 | collect (cons (or | |
102 | (find-attribute description (car spec)) | |
103 | (error "No attribute matching ~A" (car spec))) | |
104 | (cdr spec)))))) | |
105 | (lambda () | |
106 | (without-special-symbol-access | |
107 | (funcall function)))))))))))) | |
108 | ||
8f1d4c14 | 109 | (defmacro with-described-object ((object &optional description) |
6d0aa5eb | 110 | &body body) |
8f1d4c14 CE |
111 | (once-only (object) |
112 | `(funcall-with-described-object (lambda (),@body) ,object ,(or description | |
113 | `(description-of ,object))))) | |
6d0aa5eb | 114 | |
115 | ||
116 | ||
117 | ||
118 | ||
119 | ||
120 | ||
121 | ||
122 | ||
123 | ||
124 | ||
125 | ||
126 | ||
127 | ||
128 | ||
129 | ||
130 | ||
131 | ||
132 | ||
133 | ||
134 |