tons of small changes to bring this up to date with maxclaims 2.0
[clinton/lisp-on-lines.git] / src / description.lisp
CommitLineData
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