1 (in-package :lisp-on-lines
)
3 (define-layered-function description-of
(thing)
5 (find-description 't
)))
7 (defun description-print-name (description)
8 (description-class-name (class-of description
)))
10 (defun find-attribute (description attribute-name
)
11 (when (slot-exists-p description attribute-name
)
12 (slot-value description attribute-name
)))
15 (defun description-attributes (description)
16 (let ((class (class-of description
)))
17 (loop :for slot
:in
(class-slots class
)
19 (not (eq 'described-object
20 (slot-definition-name slot
))))
21 :collect
(slot-definition-attribute-object slot
))))
25 (define-layered-function attributes
(description)
26 (:method
(description)
27 (let* ((active-attributes
28 (find-attribute description
'active-attributes
))
29 (attributes (when active-attributes
30 (attribute-value active-attributes
))))
32 (mapcar (lambda (spec)
41 (and (attribute-active-p attribute
)
42 (some #'layer-active-p
44 (slot-definition-layers
45 (attribute-effective-attribute-definition attribute
))))))
46 (description-attributes description
))))))
54 (defmacro define-description
(name &optional superdescriptions
&body options
)
55 (let ((description-name (defining-description name
)))
56 (destructuring-bind (&optional slots
&rest options
) options
57 (let ((description-layers (cdr (assoc :in-description options
))))
58 (if description-layers
59 `(progn ;eval-when (:compile-toplevel :load-toplevel :execute)
62 :in description-layers
63 :collect
`(define-description
64 ,name
,superdescriptions
,slots
66 :in-layer
(defining-description layer
)
67 (remove :in-description options
:key
#'car
)))))
68 `(progn ;eval-when (:compile-toplevel :load-toplevel :execute)
70 (defclass ,description-name
71 ,(append (mapcar #'defining-description
73 (unless (or (eq t name
)
74 (assoc :mixinp options
))
75 (list (defining-description t
))))
78 ,@(unless (assoc :metaclass options
)
79 '((:metaclass standard-description-class
))))
80 (initialize-descriptions)
81 (find-description ',name
)))))))