From fdeed55df38cdfc1d202f425ef6be3e2af2c1f96 Mon Sep 17 00:00:00 2001
From: Drew Crampsie <drewc@tech.coop>
Date: Wed, 1 Feb 2006 22:55:08 -0800
Subject: [PATCH] ammend last patch

darcs-hash:20060202065508-5417e-162bea8d86565d6c7ecbfdaa0a97a1f18ea0e82f.gz
---
 lisp-on-lines.asd   |  4 ++-
 src/defdisplay.lisp | 81 +++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 84 insertions(+), 1 deletion(-)

diff --git a/lisp-on-lines.asd b/lisp-on-lines.asd
index 5ce02ab..cee71e9 100644
--- a/lisp-on-lines.asd
+++ b/lisp-on-lines.asd
@@ -24,7 +24,9 @@
 				       (:file "standard-display")
 				       (:file "standard-attributes")
 				       (:file "standard-wrappers")
-				       (:file "relational-attributes"))
+				       (:file "relational-attributes")
+
+				       (:file "backwards-compat"))
 			  :serial t)
 		 (:module :components
 			  :pathname "src/components/"
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
-- 
2.20.1