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 (slot-value description attribute-name
))
13 #+nil
(mapcar (lambda (slotd)
14 (slot-value-using-class (class-of description
) description slotd
))
15 (class-slots (class-of description
)))
16 (defun description-attributes (description)
17 (mapcar #'attribute-object
(class-slots (class-of description
))))
19 (define-layered-function attributes
(description)
20 (:method
(description)
23 (and (eq (class-of description
)
24 (print (slot-value attribute
'description-class
)))
25 (some #'layer-active-p
27 (slot-definition-layers
28 (attribute-effective-attribute-definition attribute
))))))
29 (description-attributes description
))))
33 (defmacro define-description
(name &optional superdescriptions
&body options
)
34 (let ((description-name (defining-description name
)))
35 (destructuring-bind (&optional slots
&rest options
) options
36 (let ((description-layers (cdr (assoc :in-description options
))))
37 (if description-layers
38 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
41 :in description-layers
42 :collect
`(define-description
43 ,name
,superdescriptions
,slots
45 :in-layer
(defining-description layer
)
46 (remove :in-description options
:key
#'car
)))))
47 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
49 (defclass ,description-name
50 ,(append (mapcar #'defining-description
52 (unless (or (eq t name
)
53 (assoc :mixinp options
))
54 (list (defining-description t
))))
57 ,@(unless (assoc :metaclass options
)
58 '((:metaclass standard-description-class
))))
59 ; (initialize-description)
60 (find-description ',name
)))))))