From 4ac9d6f44a5fc2ffa7e723aabbe944ec6d343404 Mon Sep 17 00:00:00 2001
From: "Kevin M. Rosenberg" <kevin@rosenberg.net>
Date: Fri, 18 Aug 2006 07:45:31 +0000
Subject: [PATCH] r11039: use initialize-instance :around
 direct-slot-definition to be more amop compliant

---
 mop.lisp | 29 +++++++++++++++++++++--------
 1 file changed, 21 insertions(+), 8 deletions(-)

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
-- 
2.34.1