X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fmetaclasses.lisp;h=0dcb3aefea52033c2bc2b97129617ece76cf521e;hb=7cffee5771647bc8ab8dc6de6891fb3829523d32;hp=b22e27a49a3014c02385c148c83da161c7fdf27a;hpb=b43e20a168dae4ae9d176ebc0fbf18ea6e4517dc;p=clsql.git

diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp
index b22e27a..0dcb3ae 100644
--- a/sql/metaclasses.lisp
+++ b/sql/metaclasses.lisp
@@ -60,9 +60,11 @@
 			       :db-writer :db-info))
 (defvar +extra-class-options+ '(:base-table))
 
+#+lispworks
 (dolist (slot-option +extra-slot-options+)
   (process-slot-option standard-db-class slot-option))
 
+#+lispworks
 (dolist (class-option +extra-class-options+)
   (process-class-option standard-db-class class-option))
 
@@ -198,15 +200,6 @@
 
 #+(or allegro openmcl)
 (defmethod finalize-inheritance :after ((class standard-db-class))
-  ;; KMRL for slots without a type set, openmcl sets type-predicate to ccl:false
-  ;; for standard-db-class
-  #+openmcl
-  (mapcar 
-   #'(lambda (s)
-       (if (eq 'ccl:false (slot-value s 'ccl::type-predicate))
-	   (setf (slot-value s 'ccl::type-predicate) 'ccl:true)))
-   (class-slots class))
-
   (setf (key-slots class) (remove-if-not (lambda (slot)
 					   (eql (slot-value slot 'db-kind)
 						:key))
@@ -387,7 +380,6 @@ implementations."
 (defun compute-lisp-type-from-slot-specification (slotd specified-type)
   "Computes the Lisp type for a user-specified type. Needed for OpenMCL
 which does type checking before storing a value in a slot."
-  #-openmcl (declare (ignore slotd))
   ;; This function is called after the base compute-effective-slots is called.
   ;; OpenMCL sets the type-predicate based on the initial value of the slots type.
   ;; so we have to override the type-predicates here
@@ -396,24 +388,15 @@ which does type checking before storing a value in a slot."
      (cond
        ((and (symbolp (car specified-type))
 	     (string-equal (symbol-name (car specified-type)) "string"))
-	#+openmcl (setf (slot-value slotd 'ccl::type-predicate) 'stringp)
 	'string)
        (t
-	#+openmcl (setf (slot-value slotd 'ccl::type-predicate) 'ccl:true)
 	specified-type)))
     ((eq (ensure-keyword specified-type) :bigint)
      'integer)
-    #+openmcl
-    ((null specified-type)
-     ;; setting this here is not enough since openmcl later sets the
-     ;; type-predicate to ccl:false. So, have to check slots again
-     ;; in finalize-inheritance 
-     #+openmcl (setf (slot-value slotd 'ccl::type-predicate) 'ccl:true)
-     t)
+    ((and specified-type
+	  (not (eql :not-null (slot-value slotd 'db-constraints))))
+     `(or null ,specified-type))
     (t
-     ;; This can be improved for OpenMCL to set a more specific type
-     ;; predicate based on the value specified-type 
-     #+openmcl (setf (slot-value slotd 'ccl::type-predicate) 'ccl:true)
      specified-type)))
 
 ;; Compute the slot definition for slots in a view-class.  Figures out
@@ -486,17 +469,22 @@ which does type checking before storing a value in a slot."
 	 )
 	;; all other slots
 	(t
-	 (change-class esd 'view-class-effective-slot-definition
-		       #+allegro :name 
-		       #+allegro (slot-definition-name dsd))
+	 (let ((type-predicate #+openmcl (slot-value esd 'ccl::type-predicate)))
+	   
+	   (change-class esd 'view-class-effective-slot-definition
+			 #+allegro :name 
+			 #+allegro (slot-definition-name dsd))
+	   #+openmcl (setf (slot-value esd 'ccl::type-predicate)
+			   type-predicate))
 	 
 	 (setf (slot-value esd 'column)
 	   (column-name-from-arg
 	    (sql-escape (slot-definition-name dsd))))
-	 
+
 	 (setf (slot-value esd 'db-info) nil)
-	 (setf (slot-value esd 'db-kind)
-	   :virtual)))
+	 (setf (slot-value esd 'db-kind) :virtual)
+	 (setf (specified-type esd) (slot-definition-type dsd)))
+	)
       esd)))
   
 (defun slotdefs-for-slots-with-class (slots class)