Move initialization of attribute object
[clinton/lisp-on-lines.git] / src / description.lisp
1 (in-package :lisp-on-lines)
2
3 (define-layered-function description-of (thing)
4 (:method (thing)
5 (find-description 't)))
6
7 (defun description-print-name (description)
8 (description-class-name (class-of description)))
9
10 (defun find-attribute (description attribute-name)
11 (slot-value description attribute-name))
12
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))))
18
19 (define-layered-function attributes (description)
20 (:method (description)
21 (remove-if-not
22 (lambda (attribute)
23 (and (eq (class-of description)
24 (print (slot-value attribute 'description-class)))
25 (some #'layer-active-p
26 (mapcar #'find-layer
27 (slot-definition-layers
28 (attribute-effective-attribute-definition attribute))))))
29 (description-attributes description))))
30
31
32 ;;; A handy macro.
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)
39 ,@(loop
40 :for layer
41 :in description-layers
42 :collect `(define-description
43 ,name ,superdescriptions ,slots
44 ,@(acons
45 :in-layer (defining-description layer)
46 (remove :in-description options :key #'car)))))
47 `(eval-when (:compile-toplevel :load-toplevel :execute)
48 ; `(progn
49 (defclass ,description-name
50 ,(append (mapcar #'defining-description
51 superdescriptions)
52 (unless (or (eq t name)
53 (assoc :mixinp options))
54 (list (defining-description t))))
55 ,(if slots slots '())
56 ,@options
57 ,@(unless (assoc :metaclass options)
58 '((:metaclass standard-description-class))))
59 (initialize-descriptions)
60 (find-description ',name)))))))
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80