Fix multiple evaluation of `object' form in `with-described-object'
[clinton/lisp-on-lines.git] / src / mao / description.lisp
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
109 (defmacro with-described-object ((object &optional description)
110 &body body)
111 (once-only (object)
112 `(funcall-with-described-object (lambda (),@body) ,object ,(or description
113 `(description-of ,object)))))
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134