r9269: 7 May 2004 Kevin Rosenberg (kevin@rosenberg.net)

        * sql/metaclass.lisp: Work-around openmcl's CHANGE-CLASS
        changing the type-specifier. Use a lisp type of (OR NULL FOO)
        for a specified-type of FOO unless :db-constraints :not-null.

diff --git a/ChangeLog b/ChangeLog
index 90803120810e525d4ddf11177b1d8ac11f8e8b91..d7fa8276d1a419803bec0c3023471bc88205bb8d 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,4 +1,7 @@
-6 May 2004 Kevin Rosenberg (kevin@rosenberg.net)
+7 May 2004 Kevin Rosenberg (kevin@rosenberg.net)
+       * sql/metaclass.lisp: Work-around openmcl's CHANGE-CLASS
+       changing the type-specifier. Use a lisp type of (OR NULL FOO)
+       for a specified-type of FOO unless :db-constraints :not-null.

        * tests/test-*.lisp: Rename fields so that joins occur on
        fields with different names. This ensures that join code is
        selecting the proper name.
        * tests/test-*.lisp: Rename fields so that joins occur on
        fields with different names. This ensures that join code is
        selecting the proper name.


@@ -6,7 +9,7 @@
        view class for testing.
        * sql/objects.lisp: Use view-table rather than name of table
        in a number of places to fix errors noted with using :base-table.
        view class for testing.
        * sql/objects.lisp: Use view-table rather than name of table
        in a number of places to fix errors noted with using :base-table.

-       
+

 6 May 2004 Marcus Pearce (m.t.pearce@city.ac.uk) 
         * sql/objects.lisp: replace *update-records-on-make-instance* with 
         *db-auto-sync* which also controls both automatic creation of 
 6 May 2004 Marcus Pearce (m.t.pearce@city.ac.uk) 
         * sql/objects.lisp: replace *update-records-on-make-instance* with 
         *db-auto-sync* which also controls both automatic creation of 

diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp
index edb794298f3d374b088409c6e361185f592db15c..0dcb3aefea52033c2bc2b97129617ece76cf521e 100644 (file)
--- a/sql/metaclasses.lisp
+++ b/sql/metaclasses.lisp
@@ -380,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."
 (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."

-  (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
   ;; 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


@@ -394,9 +393,9 @@ which does type checking before storing a value in a slot."
        specified-type)))
     ((eq (ensure-keyword specified-type) :bigint)
      'integer)
        specified-type)))
     ((eq (ensure-keyword specified-type) :bigint)
      'integer)

-    #+openmcl
-    ((null specified-type)
-     t)
+    ((and specified-type
+         (not (eql :not-null (slot-value slotd 'db-constraints))))
+     `(or null ,specified-type))

     (t
      specified-type)))
 
     (t
      specified-type)))
 


@@ -470,17 +469,22 @@ which does type checking before storing a value in a slot."
         )
        ;; all other slots
        (t
         )
        ;; 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 'column)
           (column-name-from-arg
            (sql-escape (slot-definition-name dsd))))

-        
+

         (setf (slot-value esd 'db-info) nil)
         (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)
       esd)))
   
 (defun slotdefs-for-slots-with-class (slots class)