From: Kevin M. Rosenberg Date: Thu, 6 May 2004 17:10:52 +0000 (+0000) Subject: r9269: 7 May 2004 Kevin Rosenberg (kevin@rosenberg.net) X-Git-Tag: v3.8.6~500 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=7cffee5771647bc8ab8dc6de6891fb3829523d32 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 9080312..d7fa827 100644 --- 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. @@ -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. - + 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 edb7942..0dcb3ae 100644 --- 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." - (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 @@ -394,9 +393,9 @@ which does type checking before storing a value in a slot." 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))) @@ -470,17 +469,22 @@ which does type checking before storing a value in a slot." ) ;; 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 '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)