ammend last patch

darcs-hash:20060202065508-5417e-162bea8d86565d6c7ecbfdaa0a97a1f18ea0e82f.gz

diff --git a/lisp-on-lines.asd b/lisp-on-lines.asd
index 5ce02ab..cee71e9 100644 (file)
--- 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 (file)
--- 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