[cells-cvs] CVS cells

[phildebrandt]

Update of /project/cells/cvsroot/cells
In directory clnet:/tmp/cvs-serv12895

Modified Files:
	defmodel.lisp 
Log Message:
added an eval-now! in defmodel to suppress SBCL warnings


--- /project/cells/cvsroot/cells/defmodel.lisp	2008/04/23 03:20:09	1.20
+++ /project/cells/cvsroot/cells/defmodel.lisp	2008/05/21 10:46:52	1.21
@@ -54,73 +54,74 @@
      ; -------  defclass ---------------  (^slot-value ,model ',',slotname)
      ;
      
-     (prog1
-       (defclass ,class ,(or directsupers '(model-object)) ;; now we can def the class
-         ,(mapcar (lambda (s)
-                    (list* (car s)
-                      (let ((ias (cdr s)))
-                        (remf ias :persistable)
-                        (remf ias :ps)
-                        ;; We handle accessor below
-                        (when (getf ias :cell t)
-                          (remf ias :reader)
-                          (remf ias :writer)
-                          (remf ias :accessor))
-                        (remf ias :cell)
-                        (remf ias :owning)
-                        (remf ias :unchanged-if)
-                        ias))) (mapcar #'copy-list slotspecs))
-         (:documentation
-          ,@(or (cdr (find :documentation options :key #'car))
-              '("chya")))
-         (:default-initargs ;; nil ok and needed: acl oddity in re not clearing d-i's sans this
-             ,@(cdr (find :default-initargs options :key #'car)))
-         (:metaclass ,(or (cadr (find :metaclass options :key #'car))
-                        'standard-class)))
+     (eval-now! ;; suppress style warning in SBCL
+       (prog1
+	  (defclass ,class ,(or directsupers '(model-object)) ;; now we can def the class
+	    ,(mapcar (lambda (s)
+		       (list* (car s)
+			      (let ((ias (cdr s)))
+				(remf ias :persistable)
+				(remf ias :ps)
+				;; We handle accessor below
+				(when (getf ias :cell t)
+				  (remf ias :reader)
+				  (remf ias :writer)
+				  (remf ias :accessor))
+				(remf ias :cell)
+				(remf ias :owning)
+				(remf ias :unchanged-if)
+				ias))) (mapcar #'copy-list slotspecs))
+	    (:documentation
+	     ,@(or (cdr (find :documentation options :key #'car))
+		   '("chya")))
+	    (:default-initargs ;; nil ok and needed: acl oddity in re not clearing d-i's sans this
+		,@(cdr (find :default-initargs options :key #'car)))
+	    (:metaclass ,(or (cadr (find :metaclass options :key #'car))
+			     'standard-class)))
        
-       (defmethod shared-initialize :after ((self ,class) slot-names &rest iargs &key)
-         (declare (ignore slot-names iargs))
-         ,(when (and directsupers (not (member 'model-object directsupers)))
-            `(unless (typep self 'model-object)
-               (error "If no superclass of ~a inherits directly
+	(defmethod shared-initialize :after ((self ,class) slot-names &rest iargs &key)
+	  (declare (ignore slot-names iargs))
+	  ,(when (and directsupers (not (member 'model-object directsupers)))
+		 `(unless (typep self 'model-object)
+		    (error "If no superclass of ~a inherits directly
 or indirectly from model-object, model-object must be included as a direct super-class in
 the defmodel form for ~a" ',class ',class))))
-       ;
-       ; slot accessors once class is defined...
-       ;
-       ,@(mapcar (lambda (slotspec)
-                   (destructuring-bind
-                       (slotname &rest slotargs
-                         &key (cell t) owning unchanged-if (accessor slotname) reader writer type
-                         &allow-other-keys)
-                       slotspec
+					;
+					; slot accessors once class is defined...
+					;
+	,@(mapcar (lambda (slotspec)
+		    (destructuring-bind
+			  (slotname &rest slotargs
+				    &key (cell t) owning unchanged-if (accessor slotname) reader writer type
+				    &allow-other-keys)
+			slotspec
                      
-                     (declare (ignorable slotargs))
-                     (when cell
-                       (let* ((reader-fn (or reader accessor))
-                              (writer-fn (or writer accessor))
-                              )
-                         `(eval-when (#-sbcl :compile-toplevel :load-toplevel :execute) ; ph -- prevent sbcl warning
-                            (setf (md-slot-cell-type ',class ',slotname) ,cell)
-                            ,(when owning
-                               `(setf (md-slot-owning-direct? ',class ',slotname) ,owning))
-                            ,(when reader-fn
-                               `(defmethod ,reader-fn ((self ,class))
-                                  (md-slot-value self ',slotname)))
+		      (declare (ignorable slotargs))
+		      (when cell
+			(let* ((reader-fn (or reader accessor))
+			       (writer-fn (or writer accessor))
+			       )
+			  `(eval-when (#-sbcl :compile-toplevel :load-toplevel :execute) ; ph -- prevent sbcl warning
+			     (setf (md-slot-cell-type ',class ',slotname) ,cell)
+			     ,(when owning
+				    `(setf (md-slot-owning-direct? ',class ',slotname) ,owning))
+			     ,(when reader-fn
+				    `(defmethod ,reader-fn ((self ,class))
+				       (md-slot-value self ',slotname)))
                             
-                            ,(when writer-fn
-                               `(defmethod (setf ,writer-fn) (new-value (self ,class))
-                                  (setf (md-slot-value self ',slotname)
-                                    ,(if type
-                                         `(coerce new-value ',type)
-                                       'new-value))))
+			     ,(when writer-fn
+				    `(defmethod (setf ,writer-fn) (new-value (self ,class))
+				       (setf (md-slot-value self ',slotname)
+					     ,(if type
+						  `(coerce new-value ',type)
+						  'new-value))))
                             
-                            ,(when unchanged-if
-                               `(def-c-unchanged-test (,class ,slotname) ,unchanged-if))
-                            )
-                         ))
-                     ))
-           slotspecs))))
+			     ,(when unchanged-if
+				    `(def-c-unchanged-test (,class ,slotname) ,unchanged-if))
+			     )
+			  ))
+		      ))
+		  slotspecs)))))
 
 (defun defmd-canonicalize-slot (slotname
                                 &key