X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fmetaclasses.lisp;h=594211c08bda72b95db783aa55f8d8292d38ff45;hp=701181da53a8bb3a4da0217511485eb1587ccb19;hb=fa4da6e40c8970a26c2b9fe8adb9a041ff39568d;hpb=11261eca2090842638d1b3b7c12b7cc1f6d58f09

diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp
index 701181d..594211c 100644
--- a/sql/metaclasses.lisp
+++ b/sql/metaclasses.lisp
@@ -107,12 +107,12 @@
                                         qualifier
 					&allow-other-keys)
   (let ((root-class (find-class 'standard-db-object nil))
-	(vmc (find-class 'standard-db-class)))
+	(vmc 'standard-db-class))
     (setf (view-class-qualifier class)
           (car qualifier))
     (if root-class
-	(if (member-if #'(lambda (super)
-			   (eq (class-of super) vmc)) direct-superclasses)
+	(if (some #'(lambda (super) (typep super vmc))
+                  direct-superclasses)
 	    (call-next-method)
             (apply #'call-next-method
                    class
@@ -135,7 +135,7 @@
                                           direct-superclasses qualifier
                                           &allow-other-keys)
   (let ((root-class (find-class 'standard-db-object nil))
-	(vmc (find-class 'standard-db-class)))
+	(vmc 'standard-db-class))
     (setf (view-table class)
           (table-name-from-arg (sql-escape (or (and base-table
                                                     (if (listp base-table)
@@ -145,8 +145,8 @@
     (setf (view-class-qualifier class)
           (car qualifier))
     (if (and root-class (not (equal class root-class)))
-	(if (member-if #'(lambda (super)
-			   (eq (class-of super) vmc)) direct-superclasses)
+	(if (some #'(lambda (super) (typep super vmc))
+                  direct-superclasses)
 	    (call-next-method)
             (apply #'call-next-method
                    class
@@ -386,31 +386,33 @@ which does type checking before storing a value in a slot."
   ;; 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
-  (cond
-    ((consp specified-type)
-     (cond
-       ((and (symbolp (car specified-type))
-	     (string-equal (symbol-name (car specified-type)) "string"))
-	'string)
-       ((and (symbolp (car specified-type))
-	     (string-equal (symbol-name (car specified-type)) "varchar"))
-	'string)
-       ((and (symbolp (car specified-type))
-	     (string-equal (symbol-name (car specified-type)) "char"))
-	'string)
-       (t
-	specified-type)))
-    ((eq (ensure-keyword specified-type) :bigint)
-     'integer)
-    ((eq (ensure-keyword specified-type) :char)
-     'character)
-    ((eq (ensure-keyword specified-type) :varchar)
-     'string)
-    ((and specified-type
-	  (not (eql :not-null (slot-value slotd 'db-constraints))))
-     `(or null ,specified-type))
-    (t
-     specified-type)))
+  (let ((type
+         (cond
+           ((consp specified-type)
+            (cond
+              ((and (symbolp (car specified-type))
+                    (string-equal (symbol-name (car specified-type)) "string"))
+               'string)
+              ((and (symbolp (car specified-type))
+                    (string-equal (symbol-name (car specified-type)) "varchar"))
+               'string)
+              ((and (symbolp (car specified-type))
+                    (string-equal (symbol-name (car specified-type)) "char"))
+               'string)
+              (t
+               specified-type)))
+           ((eq (ensure-keyword specified-type) :bigint)
+            'integer)
+           ((eq (ensure-keyword specified-type) :char)
+            'character)
+           ((eq (ensure-keyword specified-type) :varchar)
+            'string)
+           (t
+            specified-type)))
+        (constraints (slot-value slotd 'db-constraints)))
+    (if (and type (not (member :not-null (listify constraints))))
+        `(or null ,type)
+        type)))
 
 ;; Compute the slot definition for slots in a view-class.  Figures out
 ;; what kind of database value (if any) is stored there, generates and
@@ -444,8 +446,8 @@ which does type checking before storing a value in a slot."
 	       (null (specified-type dsd)))
       (setf (specified-type dsd)
 	(slot-definition-type dsd))
-      (setf #-clisp (slot-value dsd 'type)
-	    #+clisp (slot-definition-type dsd)
+      (setf #-(or clisp sbcl) (slot-value dsd 'type)
+	    #+(or clisp sbcl) (slot-definition-type dsd)
 	    (compute-lisp-type-from-slot-specification
 	     dsd (slot-definition-type dsd))))