X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/38a016c7ea89d37ea32cfeb8d1e30033c9e3d614..fc3e754fa505c6f725ebe962917eabc1dc8f8ce2:/src/mewa/mewa.lisp

diff --git a/src/mewa/mewa.lisp b/src/mewa/mewa.lisp
index af4ecbb..e620130 100644
--- a/src/mewa/mewa.lisp
+++ b/src/mewa/mewa.lisp
@@ -8,7 +8,8 @@
     string    mewa-string
     number    mewa-currency
     integer   mewa-integer
-    currency  mewa-currency))
+    currency  mewa-currency
+    clsql:generalized-boolean mewa-boolean))
 
 ;;; an alist of model-class-name . attributes
 ;;; should really be a hash-table.
@@ -89,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)
@@ -104,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))
@@ -136,8 +154,6 @@ attributes is an alist keyed on the attribute name."
 	  
 ;;;presentations 
 
-
-
 (defcomponent mewa ()
   ((instance :accessor instance :initarg :instance) 
    (attributes
@@ -239,7 +255,7 @@ attributes is an alist keyed on the attribute name."
 			  (car (second attribute))
 			  (second attribute))
 		      *presentation-slot-type-mapping*) 
-	     (error  "Can't find slot type for ~A in ~A but ~A" attribute *presentation-slot-type-mapping* (gethash 'mewa:has-very-many *presentation-slot-type-mapping*)))))
+	     (error  "Can't find slot type for ~A in ~A" attribute *presentation-slot-type-mapping* ))))
 		
     (cons (first attribute) (apply #'make-instance 
 				   class-name