Commit | Line | Data |
---|---|---|
fdeed55d DC |
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)))))))) |