[elephant-cvs] CVS update: elephant/src/metaclasses.lisp

[blee at common-lisp.net]

Update of /project/elephant/cvsroot/elephant/src
In directory common-lisp.net:/tmp/cvs-serv17181/src

Modified Files:
	metaclasses.lisp 
Log Message:
openmcl

Date: Thu Sep  2 09:15:49 2004
Author: blee

Index: elephant/src/metaclasses.lisp
diff -u elephant/src/metaclasses.lisp:1.3 elephant/src/metaclasses.lisp:1.4
--- elephant/src/metaclasses.lisp:1.3	Mon Aug 30 23:15:12 2004
+++ elephant/src/metaclasses.lisp	Thu Sep  2 09:15:48 2004
@@ -83,6 +83,7 @@
 (defmethod direct-slot-definition-class ((class persistent-metaclass) &rest initargs)
   (let ((allocation-key (getf initargs :allocation))
 	(transient-p (getf initargs :transient)))
+    (when (consp transient-p) (setq transient-p (car transient-p)))
     (cond ((and (eq allocation-key :class) transient-p)
 	   (find-class 'transient-direct-slot-definition))
 	  ((and (eq allocation-key :class) (not transient-p))
@@ -111,6 +112,7 @@
 
 (defmethod effective-slot-definition-class ((class persistent-metaclass) &rest initargs)
   (let ((transient-p (getf initargs :transient)))
+    (when (consp transient-p) (setq transient-p (car transient-p)))
     (cond (transient-p
 	   (find-class 'transient-effective-slot-definition))
 	  (t
@@ -138,6 +140,43 @@
   (let ((slot-definition (call-next-method)))
     (ensure-storage-exists class slot-definition slot-name)
     slot-definition))
+
+#+openmcl
+(defmethod compute-effective-slot-definition ((class persistent-metaclass) slot-name direct-slot-definitions)
+  (declare (ignore slot-name))
+  (apply #'make-effective-slot-definition class
+	 (compute-effective-slot-definition-initargs 
+	  class direct-slot-definitions)))
+
+#+openmcl
+(defmethod compute-effective-slot-definition-initargs ((class slots-class)
+						       direct-slots)
+  (let* ((name (loop for s in direct-slots
+		     when s
+		     do (return (slot-definition-name s))))
+	 (initer (dolist (s direct-slots)
+                   (when (%slot-definition-initfunction s)
+                     (return s))))
+         (documentor (dolist (s direct-slots)
+                       (when (%slot-definition-documentation s)
+                         (return s))))
+         (first (car direct-slots))
+         (initargs (let* ((initargs nil))
+                     (dolist (dslot direct-slots initargs)
+                       (dolist (dslot-arg (%slot-definition-initargs  dslot))
+                         (pushnew dslot-arg initargs :test #'eq))))))
+    (list
+     :name name
+     :allocation (%slot-definition-allocation first)
+     :documentation (when documentor (nth-value
+                                      1
+                                      (%slot-definition-documentation
+                                       documentor)))
+     :class (%slot-definition-class first)
+     :initargs initargs
+     :initfunction (if initer (%slot-definition-initfunction initer))
+     :initform (if initer (%slot-definition-initform initer))
+     :type (or (%slot-definition-type first) t))))
 
 (defun ensure-transient-chain (slot-definitions initargs)
   (declare (ignore initargs))