r11039: use initialize-instance :around direct-slot-definition to be more amop compliant

diff --git a/mop.lisp b/mop.lisp
index 7d6a77b419dd04a38a7bef97e9c1a26bb8a6c1ae..18ca5be2d47c575b5e25d42589ceea7c10758552 100644 (file)
--- 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