r11094: 03 Sep 2006 Kevin Rosenberg <kevin@rosenberg.net>

        * Version 3.7.1
        * sql/metaclasses.lisp: Rework slot type's to be more AMOP
        compatibile. Add warning for a metaclass condition that should
        not occur.
        * sql/time.lisp: Fixed symbol case inconsistency causing problem
        in AllegroCL's modern lisp. First sign of bug noted by
        Joel Reymond on clsql-devel.
        * clsql.asd: Make time.lisp depend on utils.lisp

diff --git a/ChangeLog b/ChangeLog
index a8c653b61621daa6f77ca4156ce6bab6009839b7..f43bda4971fb7579857f51fc4fdeb8f90f706b2a 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,15 @@
+03 Sep 2006  Kevin Rosenberg <kevin@rosenberg.net>
+       * Version 3.7.1
+       * sql/metaclasses.lisp: Rework slot type's to be more AMOP
+       compatibile. Add warning for a metaclass condition that should
+       not occur.
+       * sql/time.lisp: Fixed symbol case inconsistency causing problem
+       in AllegroCL's modern lisp. First sign of bug noted by
+       Joel Reymond on clsql-devel.
+       * clsql.asd: Make time.lisp depend on utils.lisp
+
 31 Aug 2006  Kevin Rosenberg <kevin@rosenberg.net>
-       * db-mysql/mysql-loader: Apply patch from Marcus Pearce to push 
+       * db-mysql/mysql-loader.lisp: Apply patch from Marcus Pearce to push 
        *library-file-dir* to CLSQL's library path.
 
 30 Aug 2006  Kevin Rosenberg <kevin@rosenberg.net>

diff --git a/clsql.asd b/clsql.asd
index 1a5fcdf1c18fdfce2d5f1c1f1619405955584231..26ee04fafeb63850851ac7fda87b9cc1060a0935 100644 (file)
--- a/clsql.asd
+++ b/clsql.asd
@@ -51,8 +51,8 @@ oriented interface."
                         (:file "base-classes" :depends-on ("package"))
                          (:file "conditions" :depends-on ("base-classes"))
                          (:file "db-interface" :depends-on ("conditions"))
-                        (:file "time" :depends-on ("package" "conditions"))
                         (:file "utils" :depends-on ("package" "db-interface"))
+                        (:file "time" :depends-on ("package" "conditions" "utils"))
                          (:file "generics" :depends-on ("package"))))
                (:module database
                         :pathname ""

diff --git a/debian/changelog b/debian/changelog
index 46b3a2f1cee2459ffdd31cb53b64489b6e2418c1..c27ec2fa825703642b2f75a349dc33aa88c4aae6 100644 (file)
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+cl-sql (3.7.1-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr@debian.org>  Mon,  4 Sep 2006 21:17:05 -0600
+
 cl-sql (3.7.0-1) unstable; urgency=low
 
   * New upstream

diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp
index 594211c08bda72b95db783aa55f8d8292d38ff45..71a5df680a15a1711b6b61699b6b86ede1ebd758 100644 (file)
--- a/sql/metaclasses.lisp
+++ b/sql/metaclasses.lisp
@@ -294,8 +294,9 @@ column definition in the database.")
     :documentation "Description of the join.")
    (specified-type
     :accessor specified-type
+    :initarg specified-type
     :initform nil
-    :documentation "KMR: Internal slot storing the :type specified by user.")))
+    :documentation "Internal slot storing the :type specified by user.")))
 
 (defparameter *db-info-lambda-list*
   '(&key join-class
@@ -380,27 +381,22 @@ implementations."
        (push slot output-slots)))
     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."
-  ;; 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
+(defun compute-lisp-type-from-specified-type (specified-type db-constraints)
+  "Computes the Lisp type for a user-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)))
+            (let* ((first (first specified-type))
+                   (name (etypecase first
+                           (symbol (symbol-name first))
+                           (string first))))
+              (cond
+               ((or (string-equal name "string")
+                    (string-equal name "varchar")
+                    (string-equal name "char"))
+                'string)
+               (t
+                specified-type))))
            ((eq (ensure-keyword specified-type) :bigint)
             'integer)
            ((eq (ensure-keyword specified-type) :char)
@@ -408,11 +404,10 @@ which does type checking before storing a value in a slot."
            ((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))))
+            specified-type))))
+    (if (and type (not (member :not-null (listify db-constraints))))
         `(or null ,type)
-        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
@@ -432,7 +427,30 @@ which does type checking before storing a value in a slot."
       (car list)
       list))
 
-(defvar *impl-type-attrib-name* #-clisp 'type #+clisp 'clos::$type)
+(defmethod initialize-instance :around ((obj view-class-direct-slot-definition)
+                                        &rest initargs)
+  (do* ((saved-initargs initargs)
+        (parsed (list obj))
+        (name (first initargs) (first initargs))
+        (val (second initargs) (second initargs))
+        (type nil)
+        (db-constraints nil))
+      ((null initargs)
+       (setq parsed
+             (append parsed
+                     (list 'specified-type type
+                           :type (compute-lisp-type-from-specified-type
+                                  type db-constraints))))
+       (apply #'call-next-method parsed))
+    (case name
+      (:db-constraints
+       (setq db-constraints val)
+       (setq parsed (append parsed (list name val))))
+      (:type
+       (setq type val))
+      (t
+       (setq parsed (append parsed (list name val)))))
+    (setq initargs (cddr initargs))))
 
 (defmethod compute-effective-slot-definition ((class standard-db-class)
                                              #+kmr-normal-cesd slot-name
@@ -442,15 +460,6 @@ which does type checking before storing a value in a slot."
   ;; KMR: store the user-specified type and then compute
   ;; real Lisp type and store it
   (let ((dsd (car direct-slots)))
-    (when (and (typep dsd 'view-class-slot-definition-mixin)
-              (null (specified-type dsd)))
-      (setf (specified-type dsd)
-       (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))))
-
     (let ((esd (call-next-method)))
       (typecase dsd
        (view-class-slot-definition-mixin
@@ -514,13 +523,16 @@ which does type checking before storing a value in a slot."
         )
        ;; all other slots
        (t
-        (let ((type-predicate #+openmcl (slot-value esd 'ccl::type-predicate)))
-          #-openmcl (declare (ignore type-predicate))
-          #-(or clisp sbcl)  (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))
+         (unless (typep esd 'view-class-effective-slot-definition)
+           (warn "Non view-class-direct-slot object with non-view-class-effective-slot-definition in compute-effective-slot-definition")
+
+           (let ((type-predicate #+openmcl (slot-value esd 'ccl::type-predicate)))
+             #-openmcl (declare (ignore type-predicate))
+             #-(or clisp sbcl)  (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

diff --git a/sql/time.lisp b/sql/time.lisp
index 22fd87be14bee56b044ac62ce0df6f9dfc100a42..751203334a3665e2079f73eece2460eb4d54cc78 100644 (file)
--- a/sql/time.lisp
+++ b/sql/time.lisp
@@ -406,7 +406,9 @@
 );eval-when
 
 (defmacro wrap-time-for-date (time-func &key (result-func))
-  (let ((date-func (intern (replace-string (symbol-name time-func) "TIME" "DATE"))))
+  (let ((date-func (intern (replace-string (symbol-name time-func) 
+                                           (symbol-name-default-case "TIME")
+                                           (symbol-name-default-case "DATE")))))
     `(defun ,date-func (number &rest more-numbers)
       (let ((result (apply #',time-func (mapcar #'date->time (cons number more-numbers)))))
        ,(if result-func