From: Kevin M. Rosenberg Date: Fri, 9 Apr 2004 08:57:39 +0000 (+0000) Subject: r8903: fixes for AllegroCL/Lispworks/OpenMCL X-Git-Tag: v3.8.6~692 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=e3ed4080f0a28d94e81aad7452fb1f81e1e50253 r8903: fixes for AllegroCL/Lispworks/OpenMCL --- diff --git a/ChangeLog b/ChangeLog index a0a248b..c4f8a95 100644 --- 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 diff --git a/base/package.lisp b/base/package.lisp index dd2c674..58a2eea 100644 --- a/base/package.lisp +++ b/base/package.lisp @@ -118,7 +118,10 @@ #:transaction #:transaction-level #:conn-pool - + #:command-recording-stream + #:result-recording-stream + #:view-classes + ;; utils.lisp #:number-to-sql-string #:float-to-sql-string diff --git a/debian/changelog b/debian/changelog index dac5884..e83776f 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +cl-sql (2.4.1-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg Fri, 9 Apr 2004 02:56:46 -0600 + cl-sql (2.4.0-1) unstable; urgency=low * New upstream diff --git a/debian/docs b/debian/docs index 5502ed8..33aa9a8 100644 --- a/debian/docs +++ b/debian/docs @@ -1,3 +1,4 @@ NEWS README TODO +CONTRIBUTORS diff --git a/sql/kmr-mop.lisp b/sql/kmr-mop.lisp index bcd893a..e935f1c 100644 --- a/sql/kmr-mop.lisp +++ b/sql/kmr-mop.lisp @@ -46,3 +46,6 @@ (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 8ac8637..a0b9471 100644 --- 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)))))) - (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) @@ -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)) - (class-slots class))))) + (ordered-class-slots 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)) - (class-slots class)))) + (ordered-class-slots 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 - :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 @@ -436,6 +449,62 @@ all NULL values retrieved are converted by DATABASE-NULL-VALUE") (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. @@ -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)) + (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))) - (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))) - ;; 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 )? @@ -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)) - (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 @@ -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))) - (class-slots class))) + (ordered-class-slots class))) #+ignore (eval-when (:compile-toplevel :load-toplevel :execute) diff --git a/sql/objects.lisp b/sql/objects.lisp index a397b87..0d87e0e 100644 --- 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))) - (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))))) @@ -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) - (dolist (slotdef (class-slots self)) + (dolist (slotdef (ordered-class-slots self)) (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)) - (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)))) @@ -297,7 +297,7 @@ superclass of the newly-defined View Class." 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)) @@ -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)) - (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.")) @@ -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)) - (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.")) @@ -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))) - (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 diff --git a/sql/package.lisp b/sql/package.lisp index 50fc11a..01dae36 100644 --- 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-direct-superclasses) + #:class-direct-superclasses + #:compute-class-precedence-list) #+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-direct-superclasses) + #:class-direct-superclasses + #:compute-class-precedence-list) #+scl (:shadowing-import-from #:clos diff --git a/tests/test-init.lisp b/tests/test-init.lisp index 2c4fab2..5dd6775 100644 --- a/tests/test-init.lisp +++ b/tests/test-init.lisp @@ -251,7 +251,7 @@ 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)