| 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)))))))) |