1 (in-package :lisp-on-lines
)
6 (define-layered-function description-of
(thing)
8 (find-description 't
)))
10 (defun description-print-name (description)
11 (description-class-name (class-of description
)))
13 (defun description-attributes (description)
14 (description-class-attributes (class-of description
)))
16 (defun description-current-attributes (description)
20 (some #'layer-active-p
22 (slot-definition-layers
23 (attribute-effective-attribute-definition attribute
))))))
24 (description-attributes description
)))
26 (defun description-active-attributes (description)
29 (description-attributes description
)))
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 describing ~A" attribute-name description
(described-object description
)))))
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
)))
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
)))
48 (define-layered-function attributes
(description)
49 (:method
(description)
50 (let* ((active-attributes
51 (find-attribute description
'active-attributes
))
52 (attributes (when active-attributes
53 (ignore-errors (attribute-value active-attributes
)))))
57 (attribute-active-p attribute
)
58 (some #'layer-active-p
60 (slot-definition-layers
61 (attribute-effective-attribute-definition attribute
))))))
63 (mapcar (lambda (spec)
70 (description-attributes description
))))))
73 (defun funcall-with-described-object (function object description
&rest args
)
74 (setf description
(or description
(description-of object
)))
75 (let ((*description
* description
)
77 (dletf (((described-object *description
*) object
))
78 (funcall-with-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
87 :for
(key val
) :on args
:by
#'cddr
88 :collect
(list (find key
(description-attributes *description
*)
89 :key
#'attribute-keyword
)
92 (contextl::funcall-with-special-initargs
93 (let ((attribute (ignore-errors (find-attribute *description
* 'active-attributes
))))
95 (loop for spec in
(attribute-value attribute
)
98 (find-attribute *description
* (car spec
))
99 (error "No attribute matching ~A" (car spec
)))
104 (defmacro with-described-object
((object description
&rest args
)
106 `(funcall-with-described-object
112 (defmacro define-description
(name &optional superdescriptions
&body options
)
113 (let ((description-name (defining-description name
)))
114 (destructuring-bind (&optional slots
&rest options
) options
115 (let ((description-layers (cdr (assoc :in-description options
))))
116 (if description-layers
117 `(progn ;eval-when (:compile-toplevel :load-toplevel :execute)
120 :in description-layers
121 :collect
`(define-description
122 ,name
,superdescriptions
,slots
124 :in-layer
(defining-description layer
)
125 (remove :in-description options
:key
#'car
)))))
126 `(progn ;eval-when (:compile-toplevel :load-toplevel :execute)
128 (defclass ,description-name
129 ,(append (mapcar #'defining-description
131 (unless (or (eq t name
)
132 (assoc :mixinp options
))
133 (list (defining-description t
))))
134 ,(if slots slots
'())
136 ,@(unless (assoc :metaclass options
)
137 '((:metaclass standard-description-class
))))
138 (initialize-descriptions)
139 (find-description ',name
)))))))