X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=mop.lisp;h=7d6a77b419dd04a38a7bef97e9c1a26bb8a6c1ae;hb=920865199d81789ced3a9e0a24f4c95b3ec6fa7f;hp=528c99f58c77d311270ab78f796fa0ded9b4dd22;hpb=0817a8721cbefca2205dcde535ff6b164033abef;p=hyperobject.git

diff --git a/mop.lisp b/mop.lisp
index 528c99f..7d6a77b 100644
--- a/mop.lisp
+++ b/mop.lisp
@@ -15,7 +15,7 @@
 ;;;;
 ;;;; This file is Copyright (c) 2000-2003 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.")
@@ -64,6 +64,8 @@
 	     :documentation "Unique ID for the class")
    (default-view :initform nil :initarg :default-view :accessor default-view
 		 :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)
@@ -114,7 +116,7 @@
   #+ignore
   (unless (find-class (class-name cl))
     (setf (find-class (class-name cl)) cl))
-  
+
   (init-hyperobject-class cl)
   )
 
@@ -124,13 +126,13 @@
 		      '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)))
@@ -142,7 +144,7 @@
 					 #+ho-normal-dsdc &rest 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)
   (find-class 'hyperobject-esd))
 
@@ -173,7 +175,7 @@
     #-lispworks
     (declare (ignore slot-name))
     )
-  
+
   (dolist (option *class-options*)
     (eval `(process-class-option ,option)))
   (dolist (option *slot-options*)
@@ -243,11 +245,13 @@
 (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) 
+    (multiple-value-bind (sql-type sql-length)
 	(value-type-to-sql-type value-type)
       (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 (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)
@@ -309,6 +313,8 @@ SQL name"
   (case (base-value-type value-type)
     ((:string :cdata :varchar :char)
      '(or null string))
+    (:datetime
+     '(or null integer))
     (:character
      '(or null character))
     (:fixnum
@@ -345,6 +351,8 @@ SQL name"
 	:single-float)
        (:double-float
 	:double-float)
+       (:datetime
+        :long-integer)
        (otherwise
 	:text))
      length)))
@@ -373,7 +381,7 @@ 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)
   (setf (getf (gethash cl *lazy-readers*) slot-name)
     (aif subobj-class
@@ -419,7 +427,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))
@@ -434,7 +442,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))))
   )
@@ -442,7 +450,7 @@ SQL name"
 (defun finalize-documentation (cl)
   "Calculate class documentation slot"
   (let ((*print-circle* nil))
-    (setf (documentation (class-name cl) 'class)
+    (setf (documentation cl 'type)
 	  (format nil "Hyperobject~A~A~A~A"
 		  (aif (user-name cl)
 		       (format nil ": ~A" it ""))