X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=mop.lisp;h=18ca5be2d47c575b5e25d42589ceea7c10758552;hb=3a8891dc54f83ccdc16bd4094f75cab2cd3dab6e;hp=7d6a77b419dd04a38a7bef97e9c1a26bb8a6c1ae;hpb=920865199d81789ced3a9e0a24f4c95b3ec6fa7f;p=hyperobject.git

diff --git a/mop.lisp b/mop.lisp
index 7d6a77b..18ca5be 100644
--- a/mop.lisp
+++ b/mop.lisp
@@ -233,6 +233,23 @@
     (t
      t)))
 
+(defmethod initialize-instance :around ((obj hyperobject-dsd) &rest initargs)
+  (do* ((saved-initargs initargs)
+        (parsed (list obj))
+        (name (first initargs) (first initargs))
+        (val (second initargs) (second initargs)))
+      ((null initargs)
+       (apply #'call-next-method parsed))
+    (if (eql name :value-type)
+        (progn
+          (setq val (canonicalize-value-type val))
+          (setq parsed (append parsed (list name val)))
+          (setq parsed (append parsed (list :type
+                                            (value-type-to-lisp-type
+                                             (canonicalize-value-type val))))))
+      (setq parsed (append parsed (list name val))))
+    (setq initargs (cddr initargs))))
+  
 (defmethod compute-effective-slot-definition :around ((cl hyperobject-class)
 						      #+ho-normal-cesd name
 						      dsds)
@@ -243,16 +260,11 @@
 	esd)))
 
 (defun compute-hyperobject-esd (esd dsds)
-  (let* ((dsd (car dsds))
-	 (value-type (canonicalize-value-type (slot-value dsd 'value-type))))
+  (let* ((dsd (car dsds)))
     (multiple-value-bind (sql-type sql-length)
-	(value-type-to-sql-type value-type)
+	(value-type-to-sql-type (dsd-value-type dsd))
       (setf (esd-sql-type esd) sql-type)
       (setf (esd-sql-length esd) sql-length))
-    (setf (slot-value esd #-sbcl 'type
-                          #+sbcl 'sb-pcl::%type)
-          (value-type-to-lisp-type value-type))
-    (setf (esd-value-type esd) value-type)
     (setf (esd-user-name esd)
 	  (aif (dsd-user-name dsd)
 	       it
@@ -265,7 +277,8 @@
 	  (aif (dsd-sql-name dsd)
 	       it
 	       (lisp-name-to-sql-name (slot-definition-name dsd))))
-    (dolist (name '(print-formatter subobject hyperlink hyperlink-parameters
+    (dolist (name '(value-type print-formatter subobject hyperlink
+                    hyperlink-parameters
 		    description value-constraint indexed null-allowed
 		    unique short-description void-text read-only-groups
 		    hidden-groups unit disable-predicate view-type