[cells-cvs] CVS cells

ktilton ktilton at common-lisp.net
Sat Feb 16 05:04:56 UTC 2008


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

Modified Files:
	defmodel.lisp 
Log Message:


--- /project/cells/cvsroot/cells/defmodel.lisp	2008/02/11 14:47:30	1.15
+++ /project/cells/cvsroot/cells/defmodel.lisp	2008/02/16 05:04:56	1.16
@@ -24,75 +24,75 @@
      (eval-when (:compile-toplevel :execute :load-toplevel)
        (setf (get ',class :cell-types) nil)
        (setf (get ',class 'slots-excluded-from-persistence)
-             ',(loop for slotspec in slotspecs
-		  unless (and (getf (cdr slotspec) :ps t)
-			      (getf (cdr slotspec) :persistable t))
-		  collect (car slotspec)))) 
+         ',(loop for slotspec in slotspecs
+               unless (and (getf (cdr slotspec) :ps t)
+                        (getf (cdr slotspec) :persistable t))
+               collect (car slotspec)))) 
      ;; define slot macros before class so they can appear in
      ;; initforms and default-initargs
      ,@(delete nil
-	       (loop for slotspec in slotspecs
-		  nconcing (destructuring-bind
-				 (slotname &rest slotargs
-					   &key (cell t) owning (accessor slotname) reader
-					   &allow-other-keys)
-			       slotspec
+         (loop for slotspec in slotspecs
+             nconcing (destructuring-bind
+                          (slotname &rest slotargs
+                            &key (cell t) owning (accessor slotname) reader
+                            &allow-other-keys)
+                          slotspec
                         
-			     (declare (ignorable slotargs owning))
-			     (list
-			      (when cell
-				(let* ((reader-fn (or reader accessor))
-				       (deriver-fn (intern$ "^" (symbol-name reader-fn))))
-				  `(eval-when (:compile-toplevel :execute :load-toplevel)
-				     (unless (macro-function ',deriver-fn)
-				       (defmacro ,deriver-fn ()
-					 `(,',reader-fn self)))
-				     #+sbcl (unless (fboundp ',reader-fn)
-					      (defgeneric ,reader-fn (slot))))))))))
+                        (declare (ignorable slotargs owning))
+                        (list
+                         (when cell
+                           (let* ((reader-fn (or reader accessor))
+                                  (deriver-fn (intern$ "^" (symbol-name reader-fn))))
+                             `(eval-when (:compile-toplevel :execute :load-toplevel)
+                                (unless (macro-function ',deriver-fn)
+                                  (defmacro ,deriver-fn ()
+                                    `(,',reader-fn self)))
+                                #+sbcl (unless (fboundp ',reader-fn)
+                                         (defgeneric ,reader-fn (slot))))))))))
      
-					;
-					; -------  defclass ---------------  (^slot-value ,model ',',slotname)
-					;
+     ;
+     ; -------  defclass ---------------  (^slot-value ,model ',',slotname)
+     ;
      
      (progn
        (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)))
+         ,(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
+            `(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...
-					;
+       ;
+       ; 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)
+                       (slotname &rest slotargs
+                         &key (cell t) owning unchanged-if (accessor slotname) reader writer type
+                         &allow-other-keys)
                        slotspec
                      
                      (declare (ignorable slotargs))
@@ -100,27 +100,27 @@
                        (let* ((reader-fn (or reader accessor))
                               (writer-fn (or writer accessor))
                               )
-                         `(eval-when (#+sbcl :load-toplevel :execute) ; ph -- prevent sbcl warning
+                         `(progn ;; eval-when (#+sbcl :load-toplevel :execute) ; ph -- prevent sbcl warning
                             (setf (md-slot-cell-type ',class ',slotname) ,cell)
                             ,(when owning
-				   `(setf (md-slot-owning ',class ',slotname) ,owning))
+                               `(setf (md-slot-owning ',class ',slotname) ,owning))
                             ,(when reader-fn
-				   `(defmethod ,reader-fn ((self ,class))
-				      (md-slot-value self ',slotname)))
+                               `(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))))
+                               `(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))
+                               `(def-c-unchanged-test (,class ,slotname) ,unchanged-if))
                             )
                          ))
                      ))
-		 slotspecs)
+           slotspecs)
        (find-class ',class))))
 
 (defun defmd-canonicalize-slot (slotname




More information about the Cells-cvs mailing list