r8903: fixes for AllegroCL/Lispworks/OpenMCL

diff --git a/ChangeLog b/ChangeLog
index a0a248b3b90bbc7914e812c06b7d74b57efd54f8..c4f8a957a0071a2bcaa0d1cadfbc025ca8dcc347 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,16 @@
+09 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net)
+       * Version 2.4.1 released: CLSQL-TESt suite passes
+       all tests for postgresql and CMUCL, SBCL, OpenMCL.
+       Allegro and Lispworks pass all tests except for
+       FDML/LOOP/1 since the loop extension have not yet
+       been ported to those implementions.
+       * sql/metaclasses.lisp: Added new slot to standard-db-class
+       to hold user-specified type. OpenMCL adjustments to compensate
+       for its type-predicate function. Since AllegroCL, Lispworks,
+       and OpenMCL have different slot orders, added compute-slots
+       and ordered-class-slots functions so their slot order matches
+       SBCL/CMUCL.
+

 08 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net)
        * Version 2.4.0 released: All tests for clsql-classic now finish
        correctly on Allegro, Lispworks, CMUCL, SBCL, OpenMCL for
 08 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net)
        * Version 2.4.0 released: All tests for clsql-classic now finish
        correctly on Allegro, Lispworks, CMUCL, SBCL, OpenMCL for

diff --git a/base/package.lisp b/base/package.lisp
index dd2c674eeda5f21fa35ab16d2afbf72159748a40..58a2eeaaeb792d51e8ecede5b3f78f72a82bffd7 100644 (file)
--- a/base/package.lisp
+++ b/base/package.lisp
@@ -118,7 +118,10 @@
         #:transaction
         #:transaction-level
         #:conn-pool
         #:transaction
         #:transaction-level
         #:conn-pool

-
+        #:command-recording-stream
+        #:result-recording-stream
+        #:view-classes
+        

         ;; utils.lisp
         #:number-to-sql-string
         #:float-to-sql-string
         ;; utils.lisp
         #:number-to-sql-string
         #:float-to-sql-string

diff --git a/debian/changelog b/debian/changelog
index dac58845a0d3957207e73f1c330f18a8c859942a..e83776f679abafde3522dadd02cb15fdcbe9c156 100644 (file)
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+cl-sql (2.4.1-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr@debian.org>  Fri,  9 Apr 2004 02:56:46 -0600
+

 cl-sql (2.4.0-1) unstable; urgency=low
 
   * New upstream
 cl-sql (2.4.0-1) unstable; urgency=low
 
   * New upstream

diff --git a/debian/docs b/debian/docs
index 5502ed8f40fc4c37d8385e57c16b8d2642ecff18..33aa9a844e5b173c6ca5c0a333a20885c57c3b7c 100644 (file)
--- a/debian/docs
+++ b/debian/docs
@@ -1,3 +1,4 @@
 NEWS
 README
 TODO
 NEWS
 README
 TODO

+CONTRIBUTORS

diff --git a/sql/kmr-mop.lisp b/sql/kmr-mop.lisp
index bcd893acfbecc6fa9662c3b537af9efe820ec3d7..e935f1ca0e1ef585b8b68ebbe455a304ac9f8ed8 100644 (file)
--- a/sql/kmr-mop.lisp
+++ b/sql/kmr-mop.lisp
@@ -46,3 +46,6 @@
   (declare (ignore metaclass slot-name))
   )
 
   (declare (ignore metaclass slot-name))
   )
 

+(defun ordered-class-slots (class)
+  #+(or cmu sbcl) (class-slots class)
+  #-(or cmu sbcl) (reverse (class-slots class)))

diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp
index 8ac86374d2ca1423cfab8fee3e746c73096ca91d..a0b94716461ac2683559dab24189eeb57e79c5a4 100644 (file)
--- a/sql/metaclasses.lisp
+++ b/sql/metaclasses.lisp
@@ -262,7 +262,7 @@ of the default method.  The extra allowed options are the value of the
                    (slot-value slot 'db-kind)
                    (and (slot-boundp slot 'column)
                         (slot-value slot 'column))))))
                    (slot-value slot 'db-kind)
                    (and (slot-boundp slot 'column)
                         (slot-value slot 'column))))))

-    (let ((all-slots (mapcar #'frob-slot (class-slots class))))
+    (let ((all-slots (mapcar #'frob-slot (ordered-class-slots class))))

       (setq all-slots (remove-if #'not-db-col all-slots))
       (setq all-slots (stable-sort all-slots #'string< :key #'car))
       ;;(mapcar #'dink-type all-slots)
       (setq all-slots (remove-if #'not-db-col all-slots))
       (setq all-slots (stable-sort all-slots #'string< :key #'car))
       ;;(mapcar #'dink-type all-slots)


@@ -281,14 +281,23 @@ of the default method.  The extra allowed options are the value of the
     (setf (key-slots class) (remove-if-not (lambda (slot)
                                             (eql (slot-value slot 'db-kind)
                                                  :key))
     (setf (key-slots class) (remove-if-not (lambda (slot)
                                             (eql (slot-value slot 'db-kind)
                                                  :key))

-                                          (class-slots class)))))
+                                          (ordered-class-slots class)))))

 
 #+(or allegro openmcl)
 (defmethod finalize-inheritance :after ((class standard-db-class))
 
 #+(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))
   (setf (key-slots class) (remove-if-not (lambda (slot)
                                           (eql (slot-value slot 'db-kind)
                                                :key))

-                                        (class-slots class))))
+                                        (ordered-class-slots class))))

 
 ;; return the deepest view-class ancestor for a given view class
 
 
 ;; return the deepest view-class ancestor for a given view class
 


@@ -375,7 +384,11 @@ all NULL values retrieved are converted by DATABASE-NULL-VALUE")
    (db-info
     :accessor view-class-slot-db-info
     :initarg :db-info
    (db-info
     :accessor view-class-slot-db-info
     :initarg :db-info

-    :documentation "Description of the join.")))
+    :documentation "Description of the join.")
+   (specified-type
+    :accessor specified-type
+    :initform nil
+    :documentation "KMR: Internal slot storing the :type specified by user.")))

 
 (defparameter *db-info-lambda-list*
   '(&key join-class
 
 (defparameter *db-info-lambda-list*
   '(&key join-class


@@ -436,6 +449,62 @@ all NULL values retrieved are converted by DATABASE-NULL-VALUE")
   (declare (ignore initargs))
   (find-class 'view-class-effective-slot-definition))
 
   (declare (ignore initargs))
   (find-class 'view-class-effective-slot-definition))
 

+#+openmcl
+(defun compute-class-precedence-list (class)
+  ;; safe to call this in openmcl
+  (class-precedence-list class))
+
+#-(or sbcl cmu)
+(defmethod compute-slots ((class standard-db-class))
+  "Need to sort order of class slots so they are the same across
+implementations."
+  (let ((slots (call-next-method))
+       desired-sequence
+       output-slots)
+
+    (dolist (c (compute-class-precedence-list class))
+      (dolist (s (class-direct-slots c))
+       (let ((name (slot-definition-name s)))
+         (unless (find name desired-sequence)
+           (setq desired-sequence (append desired-sequence (list name)))))))
+    ;; desired-sequence is reversed at this time
+    (dolist (desired desired-sequence)
+      (let ((slot (find desired slots :key #'slot-definition-name)))
+       (assert slot)
+       (push slot output-slots)))
+
+    (nreverse output-slots)))
+
+(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
+  (cond
+    ((consp specified-type)
+     (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)))
+    #+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)
+    (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
 ;; what kind of database value (if any) is stored there, generates and
 ;; verifies the column name.
 ;; Compute the slot definition for slots in a view-class.  Figures out
 ;; what kind of database value (if any) is stored there, generates and
 ;; verifies the column name.


@@ -444,6 +513,7 @@ all NULL values retrieved are converted by DATABASE-NULL-VALUE")
                                              #+kmr-normal-cesd slot-name
                                              direct-slots)
   #+kmr-normal-cesd (declare (ignore slot-name))
                                              #+kmr-normal-cesd slot-name
                                              direct-slots)
   #+kmr-normal-cesd (declare (ignore slot-name))

+

   (let ((slotd (call-next-method))
        (sd (car direct-slots)))
     
   (let ((slotd (call-next-method))
        (sd (car direct-slots)))
     


@@ -463,7 +533,6 @@ all NULL values retrieved are converted by DATABASE-NULL-VALUE")
              (when (slot-boundp sd 'db-type)
                (view-class-slot-db-type sd)))
        
              (when (slot-boundp sd 'db-type)
                (view-class-slot-db-type sd)))
        

-

        (setf (slot-value slotd 'nulls-ok)
              (view-class-slot-nulls-ok sd))
        
        (setf (slot-value slotd 'nulls-ok)
              (view-class-slot-nulls-ok sd))
        


@@ -482,7 +551,6 @@ all NULL values retrieved are converted by DATABASE-NULL-VALUE")
              (when (slot-boundp sd 'db-constraints)
                (view-class-slot-db-constraints sd)))
                
              (when (slot-boundp sd 'db-constraints)
                (view-class-slot-db-constraints sd)))
                

-       

        ;; I wonder if this slot option and the previous could be merged,
        ;; so that :base and :key remain keyword options, but :db-kind
        ;; :join becomes :db-kind (:join <db info .... >)?
        ;; I wonder if this slot option and the previous could be merged,
        ;; so that :base and :key remain keyword options, but :db-kind
        ;; :join becomes :db-kind (:join <db info .... >)?


@@ -491,7 +559,16 @@ all NULL values retrieved are converted by DATABASE-NULL-VALUE")
              (when (slot-boundp sd 'db-info)
                (if (listp (view-class-slot-db-info sd))
                    (parse-db-info (view-class-slot-db-info sd))
              (when (slot-boundp sd 'db-info)
                (if (listp (view-class-slot-db-info sd))
                    (parse-db-info (view-class-slot-db-info sd))

-                   (view-class-slot-db-info sd)))))
+                   (view-class-slot-db-info sd))))
+
+       ;; KMR: store the user-specified type and then compute
+       ;; real Lisp type and store it
+       (setf (specified-type slotd)
+            (slot-definition-type slotd))
+       (setf (slot-value slotd 'type)
+            (compute-lisp-type-from-slot-specification 
+             slotd (slot-definition-type slotd)))
+       )

       ;; all other slots
       (t
        (change-class slotd 'view-class-effective-slot-definition
       ;; all other slots
       (t
        (change-class slotd 'view-class-effective-slot-definition


@@ -515,7 +592,7 @@ all NULL values retrieved are converted by DATABASE-NULL-VALUE")
 
 (defun slotdef-for-slot-with-class (slot class)
   (find-if #'(lambda (d) (eql slot (slot-definition-name d)))
 
 (defun slotdef-for-slot-with-class (slot class)
   (find-if #'(lambda (d) (eql slot (slot-definition-name d)))

-          (class-slots class)))
+          (ordered-class-slots class)))

 
 #+ignore
 (eval-when (:compile-toplevel :load-toplevel :execute)
 
 #+ignore
 (eval-when (:compile-toplevel :load-toplevel :execute)

diff --git a/sql/objects.lisp b/sql/objects.lisp
index a397b87eead6f1e035d98203a38b58a7e6f0db31..0d87e0ed65850e91dea75f3048a1395bc4fbd8d1 100644 (file)
--- a/sql/objects.lisp
+++ b/sql/objects.lisp
@@ -113,7 +113,7 @@
                                       &key (database *default-database*))
   (let ((schemadef nil)
         (tclass (find-class view-class-name)))
                                       &key (database *default-database*))
   (let ((schemadef nil)
         (tclass (find-class view-class-name)))

-    (dolist (slotdef (class-slots tclass))
+    (dolist (slotdef (ordered-class-slots tclass))

       (let ((res (database-generate-column-definition view-class-name
                                                       slotdef database)))
         (when res (setf schemadef (cons res schemadef)))))
       (let ((res (database-generate-column-definition view-class-name
                                                       slotdef database)))
         (when res (setf schemadef (cons res schemadef)))))


@@ -145,7 +145,7 @@ the view. The argument DATABASE has a default value of
   (values))
 
 (defmethod %install-class ((self standard-db-class) database &aux schemadef)
   (values))
 
 (defmethod %install-class ((self standard-db-class) database &aux schemadef)

-  (dolist (slotdef (class-slots self))
+  (dolist (slotdef (ordered-class-slots self))

     (let ((res (database-generate-column-definition (class-name self)
                                                     slotdef database)))
       (when res 
     (let ((res (database-generate-column-definition (class-name self)
                                                     slotdef database)))
       (when res 


@@ -262,7 +262,7 @@ superclass of the newly-defined View Class."
 
 (defun generate-selection-list (vclass)
   (let ((sels nil))
 
 (defun generate-selection-list (vclass)
   (let ((sels nil))

-    (dolist (slotdef (class-slots vclass))
+    (dolist (slotdef (ordered-class-slots vclass))

       (let ((res (generate-attribute-reference vclass slotdef)))
        (when res
           (push (cons slotdef res) sels))))
       (let ((res (generate-attribute-reference vclass slotdef)))
        (when res
           (push (cons slotdef res) sels))))


@@ -297,7 +297,7 @@ superclass of the newly-defined View Class."
       list))
 
 (defun slot-type (slotdef)
       list))
 
 (defun slot-type (slotdef)

-  (let ((slot-type (slot-definition-type slotdef)))
+  (let ((slot-type (specified-type slotdef)))

     (if (listp slot-type)
         (cons (find-symbol (symbol-name (car slot-type)) :clsql-sys)
               (cdr slot-type))
     (if (listp slot-type)
         (cons (find-symbol (symbol-name (car slot-type)) :clsql-sys)
               (cdr slot-type))


@@ -529,7 +529,7 @@ associated with that database."))
                     (db-value-from-slot slot value database)))))
     (let* ((view-class (class-of obj))
           (view-class-table (view-table view-class))
                     (db-value-from-slot slot value database)))))
     (let* ((view-class (class-of obj))
           (view-class-table (view-table view-class))

-          (slots (remove-if-not #'slot-storedp (class-slots view-class)))
+          (slots (remove-if-not #'slot-storedp (ordered-class-slots view-class)))

           (record-values (mapcar #'slot-value-list slots)))
       (unless record-values
         (error "No settable slots."))
           (record-values (mapcar #'slot-value-list slots)))
       (unless record-values
         (error "No settable slots."))


@@ -558,7 +558,7 @@ associated with that database."))
                     (db-value-from-slot slot value database)))))
     (let* ((view-class (class-of obj))
           (view-class-table (view-table view-class))
                     (db-value-from-slot slot value database)))))
     (let* ((view-class (class-of obj))
           (view-class-table (view-table view-class))

-          (slots (remove-if-not #'slot-storedp (class-slots view-class)))
+          (slots (remove-if-not #'slot-storedp (ordered-class-slots view-class)))

           (record-values (mapcar #'slot-value-list slots)))
       (unless record-values
         (error "No settable slots."))
           (record-values (mapcar #'slot-value-list slots)))
       (unless record-values
         (error "No settable slots."))


@@ -619,7 +619,7 @@ associated with that database."))
   (let* ((view-class (class-of instance))
         (joins (remove-if #'(lambda (sd)
                               (not (equal (view-class-slot-db-kind sd) :join)))
   (let* ((view-class (class-of instance))
         (joins (remove-if #'(lambda (sd)
                               (not (equal (view-class-slot-db-kind sd) :join)))

-                          (class-slots view-class))))
+                          (ordered-class-slots view-class))))

     (dolist (slot joins)
       (let ((delete-rule (gethash :delete-rule (view-class-slot-db-info slot))))
        (cond
     (dolist (slot joins)
       (let ((delete-rule (gethash :delete-rule (view-class-slot-db-info slot))))
        (cond

diff --git a/sql/package.lisp b/sql/package.lisp
index 50fc11a9ea9025636aa54fa4fbf675d80235bad3..01dae368da78d2e8b95225cefa15c3e60d77ce84 100644 (file)
--- a/sql/package.lisp
+++ b/sql/package.lisp
@@ -65,7 +65,8 @@
     #:class-prototype #:generic-function-method-class #:intern-eql-specializer
     #:make-method-lambda #:generic-function-lambda-list
     #:class-precedence-list #:slot-definition-type
     #:class-prototype #:generic-function-method-class #:intern-eql-specializer
     #:make-method-lambda #:generic-function-lambda-list
     #:class-precedence-list #:slot-definition-type

-    #:class-direct-superclasses)
+    #:class-direct-superclasses
+    #:compute-class-precedence-list)

    #+clsql-cmucl-mop 
    (:shadowing-import-from 
     #:pcl
    #+clsql-cmucl-mop 
    (:shadowing-import-from 
     #:pcl


@@ -86,7 +87,8 @@
     #:class-prototype #:generic-function-method-class #:intern-eql-specializer
     #:make-method-lambda #:generic-function-lambda-list
     #:class-precedence-list #:slot-definition-type
     #:class-prototype #:generic-function-method-class #:intern-eql-specializer
     #:make-method-lambda #:generic-function-lambda-list
     #:class-precedence-list #:slot-definition-type

-    #:class-direct-superclasses)
+    #:class-direct-superclasses
+    #:compute-class-precedence-list)

    #+scl
    (:shadowing-import-from 
     #:clos
    #+scl
    (:shadowing-import-from 
     #:clos

diff --git a/tests/test-init.lisp b/tests/test-init.lisp
index 2c4fab23c3a006f3266837a6e7bb8c84a7247505..5dd6775a7834978b05f8456d081728971c7d534b 100644 (file)
--- a/tests/test-init.lisp
+++ b/tests/test-init.lisp
@@ -251,7 +251,7 @@
        forms)))
 
 (defun test-initialise-database ()
        forms)))
 
 (defun test-initialise-database ()

-    ;; Delete the instance records
+  ;; Delete the instance records

   (with-ignore-errors 
     (clsql:delete-instance-records company1)
     (clsql:delete-instance-records employee1)
   (with-ignore-errors 
     (clsql:delete-instance-records company1)
     (clsql:delete-instance-records employee1)