r10933: 08 May 2006 Kevin Rosenberg <kevin@rosenberg.net>

        * sql/metaclasses.lisp: Patch from James Bielman for
        checking slot constraints.

diff --git a/ChangeLog b/ChangeLog
index 2b89a075e3240a110611a40ba324dd630bae792f..7496e5db6f78d434c119297c96166f2cc83b1111 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,7 @@
+08 May 2006  Kevin Rosenberg <kevin@rosenberg.net>
+       * sql/metaclasses.lisp: Patch from James Bielman for
+       checking slot constraints.
+
 06 May 2006  Kevin Rosenberg <kevin@rosenberg.net>
        * doc/ref-fdml.xml: Documentation patch from Marcus Pearce for limit keyword
        

diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp
index f3a377eadcc841d32c7a21a86792b8506e90feec..594211c08bda72b95db783aa55f8d8292d38ff45 100644 (file)
--- a/sql/metaclasses.lisp
+++ b/sql/metaclasses.lisp
@@ -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