From fc3e754fa505c6f725ebe962917eabc1dc8f8ce2 Mon Sep 17 00:00:00 2001
From: Drew Crampsie <drewc@tech.coop>
Date: Thu, 22 Sep 2005 15:38:08 -0700
Subject: [PATCH] added define-attributes macro

darcs-hash:20050922223808-5417e-7bd17a4e5293ac147e4bb731fbd8317378488e8f.gz
---
 src/mewa/mewa.lisp     | 23 +++++++++++++++++++----
 src/mewa/packages.lisp |  1 +
 src/packages.lisp      |  6 ++++++
 3 files changed, 26 insertions(+), 4 deletions(-)

diff --git a/src/mewa/mewa.lisp b/src/mewa/mewa.lisp
index 045b7c1..e620130 100644
--- a/src/mewa/mewa.lisp
+++ b/src/mewa/mewa.lisp
@@ -9,7 +9,7 @@
     number    mewa-currency
     integer   mewa-integer
     currency  mewa-currency
-    generalized-boolean mewa-boolean))
+    clsql:generalized-boolean mewa-boolean))
 
 ;;; an alist of model-class-name . attributes
 ;;; should really be a hash-table.
@@ -90,7 +90,7 @@ attributes is an alist keyed on the attribute name."
 	    (cons (car definition) 
 		  (plist-union (cdr definition)
 			 (cddr (find-attribute model name))))
-	    definition)))
+	    definition))) 
 
 (defmethod perform-set-attributes ((model t) definitions)
   (dolist (def definitions)
@@ -105,6 +105,23 @@ attributes is an alist keyed on the attribute name."
 (defmethod perform-set-attribute-properties ((model t) definitions)
   (dolist (def definitions)
     (funcall #'set-attribute-properties model (car def) (cdr def))))
+
+(defmethod perform-define-attributes ((model t) attributes)
+  (loop for attribute in attributes
+	do (destructuring-bind (name type &rest args)
+		  attribute
+		(cond ((eq type t)
+		       ;;use the existing (default) type
+		       (set-attribute-properties model name args))
+		      ((not (null type))
+		       ;;set the type as well
+		       (set-attribute model name (cons type args)))))))
+		       
+(defmacro define-attributes (models &body attribute-definitions)
+  `(progn
+    ,@(loop for model in models
+	    collect `(perform-define-attributes (quote ,model) (quote ,attribute-definitions)))
+  (mapcar #'find-class-attributes (quote ,models ))))
   
 
 (defmethod default-attributes ((model t))
@@ -137,8 +154,6 @@ attributes is an alist keyed on the attribute name."
 	  
 ;;;presentations 
 
-
-
 (defcomponent mewa ()
   ((instance :accessor instance :initarg :instance) 
    (attributes
diff --git a/src/mewa/packages.lisp b/src/mewa/packages.lisp
index 926cf90..76681d4 100644
--- a/src/mewa/packages.lisp
+++ b/src/mewa/packages.lisp
@@ -21,6 +21,7 @@
    :has-very-many-slot-presentation
    :has-very-many
    :slot-name
+   :define-attributes
    :find-attribute 
    :set-default-attributes 
    :make-presentation 
diff --git a/src/packages.lisp b/src/packages.lisp
index 70401a2..0633ae4 100644
--- a/src/packages.lisp
+++ b/src/packages.lisp
@@ -22,12 +22,18 @@
    :perform-set-attributes
    ;;
    :perform-set-attribute-properties
+   :define-attributes
 
    ;; presentation objects
    :mewa-object-presentation
    :mewa-one-line-presentation
    :mewa-list-presentation
 
+   ;; SLOT presentations
+   :defslot-presentation
+   :slot-name
+   :mewa-relation-slot-presentation
+   :has-many-slot-presentation
    ;; CRUD
    :instance-is-stored-p
 
-- 
2.20.1