X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/a310ff0da8c12588814d39348481309d30eca0e6..d0301620ac9aa7d8170ba628df493c1ff1e1d2fa:/src/defdisplay.lisp

diff --git a/src/defdisplay.lisp b/src/defdisplay.lisp
index e69de29..4363a0f 100644
--- a/src/defdisplay.lisp
+++ b/src/defdisplay.lisp
@@ -0,0 +1,81 @@
+(in-package :lisp-on-lines)
+
+(defmethod find-properties (object)
+  (list))
+
+(defmethod find-properties ((attribute standard-attribute))
+  (warn "atttributre properties ~A" (attribute.properties attribute))
+  (attribute.properties attribute))
+
+(defmacro with-properties ((properties &optional prefix)  &body body)
+  (with-unique-names (p)
+    (let ((get (intern (string-upcase (if prefix (strcat prefix '-getp) "GETP"))))
+	  (set (intern (string-upcase (if prefix (strcat prefix '-setp) "SETP"))))
+	  (props (intern (string-upcase (if prefix (strcat prefix '-properties) "PROPERTIES")))))
+      `(let ((,p ,properties))
+	(flet ((,get  (p)
+		 (getf ,p p))
+	       (,set (p v)
+		 (setf (getf ,p p) v))
+	       (,props ()
+		 ,p))
+	  (declare (ignorable #',get #',set #',props))
+	  ,@body)))))
+
+
+;;;;; Macros
+(defmacro do-attributes ((var occurence attributes) &body body)
+  (with-unique-names (att properties type)
+    `(loop for ,att in ,attributes
+      do (let* ((,att (ensure-list ,att))
+                (,properties (rest ,att))
+                (,type (getf ,properties :type))
+                (,var (if ,type
+                          (make-attribute :name (first ,att) :type ,type :properties ,properties)
+                          (find-attribute ,occurence (first ,att)))))
+           (with-properties ((plist-union (rest ,att) (find-properties ,var)) ,var)
+             ,@body)))))
+
+
+
+
+(defmacro defdisplay (object (&key in-layer combination
+				   (description t
+						description-supplied-p)
+				   (component 'component
+					      component-supplied-p))
+		      &body body)
+  (with-unique-names (d c p)
+    (let ((obj (car (ensure-list object))))
+      `(define-layered-method display-using-description
+	,@(when in-layer `(:in-layer ,in-layer))
+	,@(when combination`(,combination))
+	(,(cond
+	   (description-supplied-p
+	    (setf d description))
+	   ((null description)
+	    d)
+	   (t
+	    `(,d standard-occurence)))
+	 ,(cond
+	   (component-supplied-p
+	    (setf c component))
+	   ((null component)
+	    c)
+	   (t
+	    `(,c component)))
+	 ,object ,p)
+	(with-component (,c) 
+	  (with-properties ((plist-union ,p (find-properties ,(car (ensure-list d) ))))
+	    ,(if (not description-supplied-p)
+		 `(progn
+		   
+		   (setp :attributes (or (getp :attributes) (list-slots ,obj)))		   
+		   (macrolet ((do-attributes* ((var &optional attributes) &body body)
+				`(do-attributes (,var ,',d (or ,attributes (getp :attributes)))
+				  
+				  (flet ((display-current-attribute ()
+					   (display-using-description* ,var ,',obj (,(intern (strcat var "-PROPERTIES"))))))
+				  ,@body))))
+		     ,@body))
+		 `(progn ,@body))))))))
\ No newline at end of file