X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=mop.lisp;h=2ccf8d685a106ae8e51f3111781a90b495ce9442;hb=b5ae9d611ffe002ecdb5d19d926b952857cd26c4;hp=5307f3ed545f07ed60be74ca9ee88378f1ab2cce;hpb=0bbfff4333e985e6a556d118d12cd23fa1d96a47;p=hyperobject.git

diff --git a/mop.lisp b/mop.lisp
index 5307f3e..2ccf8d6 100644
--- a/mop.lisp
+++ b/mop.lisp
@@ -13,9 +13,9 @@
 ;;;;
 ;;;; $Id$
 ;;;;
-;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
+;;;; This file is Copyright (c) 2000-2006 by Kevin M. Rosenberg
 ;;;; *************************************************************************
- 
+
 (in-package #:hyperobject)
 
 ;; Main class
@@ -47,7 +47,7 @@
 
    ;;; The remainder of these fields are calculated one time
    ;;; in finalize-inheritence.
-   
+
    (subobjects :initform nil :accessor subobjects
 	       :documentation
 	       "List of fields that contain a list of subobjects objects.")
@@ -66,7 +66,7 @@
 		 :documentation "The default view for a class")
    (documementation :initform nil :initarg :documentation
 		    :documentation "Documentation string for hyperclass.")
-   
+
    ;; SQL commands
    (create-table-cmd :initform nil :reader create-table-cmd)
    (create-indices-cmds :initform nil :reader create-index-cmds)
@@ -112,13 +112,7 @@
   t)
 
 (defmethod finalize-inheritance :after ((cl hyperobject-class))
-  ;; Work-around needed for OpenMCL
-  #+ignore
-  (unless (find-class (class-name cl))
-    (setf (find-class (class-name cl)) cl))
-  
-  (init-hyperobject-class cl)
-  )
+  (init-hyperobject-class cl))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (when (>= (length (generic-function-lambda-list
@@ -126,29 +120,29 @@
 		      'compute-effective-slot-definition)))
 	    3)
     (pushnew :ho-normal-cesd cl:*features*))
-  
+
     (when (>= (length (generic-function-lambda-list
 		       (ensure-generic-function
 			'direct-slot-definition-class)))
 	    3)
       (pushnew :ho-normal-dsdc cl:*features*))
-    
+
     (when (>= (length (generic-function-lambda-list
 		       (ensure-generic-function
 			'effective-slot-definition-class)))
 	      3)
       (pushnew :ho-normal-esdc cl:*features*)))
 
-;; Slot definitions
 (defmethod direct-slot-definition-class ((cl hyperobject-class)
 					 #+ho-normal-dsdc &rest iargs)
+  (declare (ignore iargs))
   (find-class 'hyperobject-dsd))
 
-(defmethod effective-slot-definition-class ((cl hyperobject-class) 
+(defmethod effective-slot-definition-class ((cl hyperobject-class)
 					    #+ho-normal-esdc &rest iargs)
+  (declare (ignore iargs))
   (find-class 'hyperobject-esd))
 
-
 ;;; Slot definitions
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
@@ -175,7 +169,7 @@
     #-lispworks
     (declare (ignore slot-name))
     )
-  
+
   (dolist (option *class-options*)
     (eval `(process-class-option ,option)))
   (dolist (option *slot-options*)
@@ -233,6 +227,22 @@
     (t
      t)))
 
+(defmethod initialize-instance :around ((obj hyperobject-dsd) &rest initargs)
+  (do* ((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,17 +253,14 @@
 	esd)))
 
 (defun compute-hyperobject-esd (esd dsds)
-  (let* ((dsd (car dsds))
-	 (value-type (canonicalize-value-type (slot-value dsd 'value-type))))
-    (multiple-value-bind (sql-type sql-length) 
-	(value-type-to-sql-type value-type)
+  (let* ((dsd (car dsds)))
+    (multiple-value-bind (sql-type sql-length)
+	(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 '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
+               it
 	       (string-downcase (symbol-name (slot-definition-name dsd)))))
     (setf (esd-sql-name esd)
 	  (aif (dsd-sql-name dsd)
@@ -263,7 +270,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 unbound-lookup
 		    description value-constraint indexed null-allowed
 		    unique short-description void-text read-only-groups
 		    hidden-groups unit disable-predicate view-type
@@ -379,8 +387,9 @@ SQL name"
 ;; The reader is a function and the reader-keys are slot names.  The slot is lazily set to
 ;; the result of applying the function to the slot-values of those slots, and that value
 ;; is also returned.
-(defun ensure-lazy-reader (cl class-name slot-name subobj-class reader 
+(defun ensure-lazy-reader (cl class-name slot-name subobj-class reader
 			   &rest reader-keys)
+  (declare (ignore class-name))
   (setf (getf (gethash cl *lazy-readers*) slot-name)
     (aif subobj-class
 	 it
@@ -425,7 +434,7 @@ SQL name"
   "Make sure all class slots have an expected value"
   (unless (user-name cl)
     (setf (user-name cl) (format nil "~:(~A~)" (class-name cl))))
-  
+
   (setf (user-name-plural cl)
 	(if (and (consp (user-name cl)) (cadr (user-name cl)))
 	    (cadr (user-name cl))
@@ -440,7 +449,7 @@ SQL name"
 	     (if (listp it)
 		 (car it)
 	       it))))
-  
+
   (unless (sql-name cl)
     (setf (sql-name cl) (lisp-name-to-sql-name (class-name cl))))
   )