1 (in-package :lisp-on-lines
)
3 (defmethod find-properties (object)
6 (defmethod find-properties ((attribute standard-attribute
))
7 (warn "atttributre properties ~A" (attribute.properties attribute
))
8 (attribute.properties attribute
))
10 (defmacro with-properties
((properties &optional prefix
) &body body
)
11 (with-unique-names (p)
12 (let ((get (intern (string-upcase (if prefix
(strcat prefix
'-getp
) "GETP"))))
13 (set (intern (string-upcase (if prefix
(strcat prefix
'-setp
) "SETP"))))
14 (props (intern (string-upcase (if prefix
(strcat prefix
'-properties
) "PROPERTIES")))))
15 `(let ((,p
,properties
))
22 (declare (ignorable #',get
#',set
#',props
))
27 (defmacro do-attributes
((var occurence attributes
) &body body
)
28 (with-unique-names (att properties type
)
29 `(loop for
,att in
,attributes
30 do
(let* ((,att
(ensure-list ,att
))
31 (,properties
(rest ,att
))
32 (,type
(getf ,properties
:type
))
34 (make-attribute :name
(first ,att
) :type
,type
:properties
,properties
)
35 (find-attribute ,occurence
(first ,att
)))))
36 (with-properties ((plist-union (rest ,att
) (find-properties ,var
)) ,var
)
42 (defmacro defdisplay
(object (&key in-layer combination
44 description-supplied-p
)
46 component-supplied-p
))
48 (with-unique-names (d c p
)
49 (let ((obj (car (ensure-list object
))))
50 `(define-layered-method display-using-description
51 ,@(when in-layer
`(:in-layer
,in-layer
))
52 ,@(when combination
`(,combination
))
54 (description-supplied-p
59 `(,d standard-occurence
)))
69 (with-properties ((plist-union ,p
(find-properties ,(car (ensure-list d
) ))))
70 ,(if (not description-supplied-p
)
73 (setp :attributes
(or (getp :attributes
) (list-slots ,obj
)))
74 (macrolet ((do-attributes* ((var &optional attributes
) &body body
)
75 `(do-attributes (,var
,',d
(or ,attributes
(getp :attributes
)))
77 (flet ((display-current-attribute ()
78 (display-using-description* ,var
,',obj
(,(intern (strcat var
"-PROPERTIES"))))))
81 `(progn ,@body
))))))))