change PLIST to PROPERTIES, abstract is good.
[clinton/lisp-on-lines.git] / src / defdisplay.lisp
1 (in-package :lisp-on-lines)
2
3 (defmethod find-properties (object)
4 (list))
5
6 (defmethod find-properties ((attribute standard-attribute))
7 (warn "atttributre properties ~A" (attribute.properties attribute))
8 (attribute.properties attribute))
9
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))
16 (flet ((,get (p)
17 (getf ,p p))
18 (,set (p v)
19 (setf (getf ,p p) v))
20 (,props ()
21 ,p))
22 (declare (ignorable #',get #',set #',props))
23 ,@body)))))
24
25
26 ;;;;; Macros
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))
33 (,var (if ,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)
37 ,@body)))))
38
39
40
41
42 (defmacro defdisplay (object (&key in-layer combination
43 (description t
44 description-supplied-p)
45 (component 'component
46 component-supplied-p))
47 &body body)
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))
53 (,(cond
54 (description-supplied-p
55 (setf d description))
56 ((null description)
57 d)
58 (t
59 `(,d standard-occurence)))
60 ,(cond
61 (component-supplied-p
62 (setf c component))
63 ((null component)
64 c)
65 (t
66 `(,c component)))
67 ,object ,p)
68 (with-component (,c)
69 (with-properties ((plist-union ,p (find-properties ,(car (ensure-list d) ))))
70 ,(if (not description-supplied-p)
71 `(progn
72
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)))
76
77 (flet ((display-current-attribute ()
78 (display-using-description* ,var ,',obj (,(intern (strcat var "-PROPERTIES"))))))
79 ,@body))))
80 ,@body))
81 `(progn ,@body))))))))