X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fmetaclasses.lisp;h=1fde1eef9f2319b7045396d3d113b0f51bf1a17a;hp=95b9c11ed6c5a14993548c740af2169ca89a3a26;hb=39e2802cd264ddacb3ca59b3b2c5c38f202149de;hpb=749f294e457f124cac7b1a6adf2764fbf3b0a849

diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp
index 95b9c11..1fde1ee 100644
--- a/sql/metaclasses.lisp
+++ b/sql/metaclasses.lisp
@@ -1,9 +1,7 @@
 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
 ;;;; *************************************************************************
 ;;;;
-;;;; $Id$
-;;;;
-;;;; CLSQL metaclass for standard-db-objects created in the OODDL. 
+;;;; CLSQL metaclass for standard-db-objects created in the OODDL.
 ;;;;
 ;;;; This file is part of CLSQL.
 ;;;;
@@ -16,21 +14,21 @@
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (when (>= (length (generic-function-lambda-list
-		     (ensure-generic-function
-		      'compute-effective-slot-definition)))
-	    3)
+                     (ensure-generic-function
+                      'compute-effective-slot-definition)))
+            3)
     (pushnew :kmr-normal-cesd cl:*features*))
-  
+
   (when (>= (length (generic-function-lambda-list
-		     (ensure-generic-function
-		      'direct-slot-definition-class)))
-	    3)
+                     (ensure-generic-function
+                      'direct-slot-definition-class)))
+            3)
     (pushnew :kmr-normal-dsdc cl:*features*))
-  
+
   (when (>= (length (generic-function-lambda-list
-		     (ensure-generic-function
-		      'effective-slot-definition-class)))
-	    3)
+                     (ensure-generic-function
+                      'effective-slot-definition-class)))
+            3)
     (pushnew :kmr-normal-esdc cl:*features*)))
 
 
@@ -48,109 +46,107 @@
    (key-slots
     :accessor key-slots
     :initform nil)
+   (normalizedp
+    :accessor normalizedp
+    :initform nil)
    (class-qualifier
     :accessor view-class-qualifier
     :initarg :qualifier
     :initform nil))
-  (:documentation "VIEW-CLASS metaclass."))
+  (:documentation "Metaclass for all CLSQL View Classes."))
 
 ;;; Lispworks 4.2 and before requires special processing of extra slot and class options
 
-(defconstant +extra-slot-options+ '(:column :db-kind :db-reader :nulls-ok :db-constraints
-				    :db-writer :db-type :db-info))
-(defconstant +extra-class-options+ '(:base-table))
+(defvar +extra-slot-options+ '(:column :db-kind :db-type :db-reader :void-value :db-constraints
+                               :db-writer :db-info))
+(defvar +extra-class-options+ '(:base-table))
 
+#+lispworks
 (dolist (slot-option +extra-slot-options+)
-  (process-slot-option standard-db-class slot-option))
+  (eval `(process-slot-option standard-db-class ,slot-option)))
 
+#+lispworks
 (dolist (class-option +extra-class-options+)
-  (process-class-option standard-db-class class-option))
+  (eval `(process-class-option standard-db-class ,class-option)))
 
 (defmethod validate-superclass ((class standard-db-class)
-				(superclass standard-class))
+                                (superclass standard-class))
   t)
 
 (defun table-name-from-arg (arg)
   (cond ((symbolp arg)
-	 arg)
-	((typep arg 'sql-ident)
-	 (slot-value arg 'name))
-	((stringp arg)
-	 (intern (symbol-name-default-case arg)))))
-
-(defun column-name-from-arg (arg)
-  (cond ((symbolp arg)
-	 arg)
-	((typep arg 'sql-ident)
-	 (slot-value arg 'name))
-	((stringp arg)
-	 (intern (symbol-name-default-case arg)))))
-
+         (intern (sql-escape arg)))
+        ((typep arg 'sql-ident)
+         (if (symbolp (slot-value arg 'name))
+             (intern (sql-escape (slot-value arg 'name)))
+             (sql-escape (slot-value arg 'name))))
+        ((stringp arg)
+         (sql-escape arg))))
 
 (defun remove-keyword-arg (arglist akey)
   (let ((mylist arglist)
-	(newlist ()))
+        (newlist ()))
     (labels ((pop-arg (alist)
-	     (let ((arg (pop alist))
-		   (val (pop alist)))
-	       (unless (equal arg akey)
-		 (setf newlist (append (list arg val) newlist)))
-	       (when alist (pop-arg alist)))))
+             (let ((arg (pop alist))
+                   (val (pop alist)))
+               (unless (equal arg akey)
+                 (setf newlist (append (list arg val) newlist)))
+               (when alist (pop-arg alist)))))
       (pop-arg mylist))
     newlist))
 
+(defun set-view-table-slot (class base-table)
+  (setf (view-table class)
+        (table-name-from-arg (or (and base-table
+                                      (if (listp base-table)
+                                          (car base-table)
+                                          base-table))
+                                 (class-name class)))))
+
 (defmethod initialize-instance :around ((class standard-db-class)
                                         &rest all-keys
-					&key direct-superclasses base-table
-                                        qualifier
-					&allow-other-keys)
+                                        &key direct-superclasses base-table
+                                        qualifier normalizedp
+                                        &allow-other-keys)
   (let ((root-class (find-class 'standard-db-object nil))
-	(vmc (find-class 'standard-db-class)))
+        (vmc 'standard-db-class))
     (setf (view-class-qualifier class)
           (car qualifier))
     (if root-class
-	(if (member-if #'(lambda (super)
-			   (eq (class-of super) vmc)) direct-superclasses)
-	    (call-next-method)
+        (if (some #'(lambda (super) (typep super vmc))
+                  direct-superclasses)
+            (call-next-method)
             (apply #'call-next-method
                    class
-		   :direct-superclasses (append (list root-class)
+                   :direct-superclasses (append (list root-class)
                                                 direct-superclasses)
-		   (remove-keyword-arg all-keys :direct-superclasses)))
-	(call-next-method))
-    (setf (view-table class)
-          (table-name-from-arg (sql-escape (or (and base-table
-                                                    (if (listp base-table)
-                                                        (car base-table)
-                                                        base-table))
-                                               (class-name class)))))
+                   (remove-keyword-arg all-keys :direct-superclasses)))
+        (call-next-method))
+    (set-view-table-slot class base-table)
+    (setf (normalizedp class) (car normalizedp))
     (register-metaclass class (nth (1+ (position :direct-slots all-keys))
                                    all-keys))))
 
 (defmethod reinitialize-instance :around ((class standard-db-class)
                                           &rest all-keys
-                                          &key base-table 
+                                          &key base-table normalizedp
                                           direct-superclasses qualifier
                                           &allow-other-keys)
   (let ((root-class (find-class 'standard-db-object nil))
-	(vmc (find-class 'standard-db-class)))
-    (setf (view-table class)
-          (table-name-from-arg (sql-escape (or (and base-table
-                                                    (if (listp base-table)
-                                                        (car base-table)
-                                                        base-table))
-                                               (class-name class)))))
+        (vmc 'standard-db-class))
+    (set-view-table-slot class base-table)
+    (setf (normalizedp class) (car normalizedp))
     (setf (view-class-qualifier class)
           (car qualifier))
     (if (and root-class (not (equal class root-class)))
-	(if (member-if #'(lambda (super)
-			   (eq (class-of super) vmc)) direct-superclasses)
-	    (call-next-method)
+        (if (some #'(lambda (super) (typep super vmc))
+                  direct-superclasses)
+            (call-next-method)
             (apply #'call-next-method
                    class
                    :direct-superclasses (append (list root-class)
                                                 direct-superclasses)
-		   (remove-keyword-arg all-keys :direct-superclasses)))
+                   (remove-keyword-arg all-keys :direct-superclasses)))
         (call-next-method)))
   (register-metaclass class (nth (1+ (position :direct-slots all-keys))
                                  all-keys)))
@@ -165,9 +161,9 @@
 
 (defun describe-db-layout (class)
   (flet ((not-db-col (col)
-           (not (member (nth 2 col)  '(nil :base :key))))
+           (not (member (nth 2 col) '(nil :base :key))))
          (frob-slot (slot)
-           (let ((type (slot-value slot 'type)))
+           (let ((type (slot-definition-type slot)))
              (if (eq type t)
                  (setq type nil))
              (list (slot-value slot 'name)
@@ -190,27 +186,18 @@
       (setq all-slots (remove-if #'not-db-col all-slots))
       (setq all-slots (stable-sort all-slots #'string< :key #'car))
       (setf (object-definition class) all-slots))
-    #-(or allegro openmcl)
+    #-(or sbcl allegro)
     (setf (key-slots class) (remove-if-not (lambda (slot)
-					     (eql (slot-value slot 'db-kind)
-						  :key))
-					   (ordered-class-slots class)))))
+                                             (eql (slot-value slot 'db-kind)
+                                                  :key))
+                                           (slots-for-possibly-normalized-class class)))))
 
-#+(or allegro openmcl)
+#+(or sbcl allegro)
 (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))
-					 (ordered-class-slots class))))
+                                           (eql (slot-value slot 'db-kind)
+                                                :key))
+                                         (slots-for-possibly-normalized-class class))))
 
 ;; return the deepest view-class ancestor for a given view class
 
@@ -246,7 +233,9 @@ the slot name.")
     :accessor view-class-slot-db-kind
     :initarg :db-kind
     :initform :base
-    :type keyword
+    ;; openmcl 0.14.2 stores the value as list in the DSD
+    ;; :type (or list keyword)
+    #-openmcl :type #-openmcl keyword
     :documentation
     "The kind of DB mapping which is performed for this slot.  :base
 indicates the slot maps to an ordinary column of the DB view.  :key
@@ -286,68 +275,74 @@ column definition in the database.")
     :initarg :db-constraints
     :initform nil
     :documentation
-    "A single constraint or list of constraints for this column")
-   (nulls-ok
-    :accessor view-class-slot-nulls-ok
-    :initarg :nulls-ok
+    "A keyword symbol representing a single SQL column constraint or list of such symbols.")
+   (void-value
+    :accessor view-class-slot-void-value
+    :initarg :void-value
     :initform nil
     :documentation
-    "If t, all sql NULL values retrieved from the database become nil; if nil,
-all NULL values retrieved are converted by DATABASE-NULL-VALUE")
+    "Value to store if the SQL value is NULL. Default is NIL.")
    (db-info
     :accessor view-class-slot-db-info
     :initarg :db-info
     :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.")
+   (autoincrement-sequence
+    :accessor view-class-slot-autoincrement-sequence
+    :initarg :autoincrement-sequence
+    :initform nil
+    :documentation "A string naming the (possibly automatically generated) sequence
+for a slot with an :auto-increment constraint.")))
 
 (defparameter *db-info-lambda-list*
   '(&key join-class
-	 home-key
-	 foreign-key
+         home-key
+         foreign-key
          (key-join nil)
          (target-slot nil)
-	 (retrieval :immmediate)
-	 (set nil)))
-	  
+         (retrieval :immmediate)
+         (set nil)))
+
 (defun parse-db-info (db-info-list)
   (destructuring-bind
-	(&key join-class home-key key-join foreign-key (delete-rule nil)
-	      (target-slot nil) (retrieval :deferred) (set nil))
+        (&key join-class home-key key-join foreign-key (delete-rule nil)
+              (target-slot nil) (retrieval :deferred) (set t))
       db-info-list
     (let ((ih (make-hash-table :size 6)))
       (if join-class
-	  (setf (gethash :join-class ih) join-class)
-	  (error "Must specify :join-class in :db-info"))
+          (setf (gethash :join-class ih) join-class)
+          (error "Must specify :join-class in :db-info"))
       (if home-key
-	  (setf (gethash :home-key ih) home-key)
-	  (error "Must specify :home-key in :db-info"))
+          (setf (gethash :home-key ih) home-key)
+          (error "Must specify :home-key in :db-info"))
       (when delete-rule
-	(setf (gethash :delete-rule ih) delete-rule))
+        (setf (gethash :delete-rule ih) delete-rule))
       (if foreign-key
-	  (setf (gethash :foreign-key ih) foreign-key)
-	  (error "Must specify :foreign-key in :db-info"))
+          (setf (gethash :foreign-key ih) foreign-key)
+          (error "Must specify :foreign-key in :db-info"))
       (when key-join
         (setf (gethash :key-join ih) t))
       (when target-slot
-	(setf (gethash :target-slot ih) target-slot))
+        (setf (gethash :target-slot ih) target-slot))
       (when set
-	(setf (gethash :set ih) set))
+        (setf (gethash :set ih) set))
       (when retrieval
-	(progn
-	  (setf (gethash :retrieval ih) retrieval)
-	  (if (eql retrieval :immediate)
-	      (setf (gethash :set ih) nil))))
+        (progn
+          (setf (gethash :retrieval ih) retrieval)
+          (if (eql retrieval :immediate)
+              (setf (gethash :set ih) nil))))
       ih)))
 
 (defclass view-class-direct-slot-definition (view-class-slot-definition-mixin
-					     standard-direct-slot-definition)
+                                             standard-direct-slot-definition)
   ())
 
 (defclass view-class-effective-slot-definition (view-class-slot-definition-mixin
-						standard-effective-slot-definition)
+                                                standard-effective-slot-definition)
   ())
 
 (defmethod direct-slot-definition-class ((class standard-db-class)
@@ -357,152 +352,199 @@ all NULL values retrieved are converted by DATABASE-NULL-VALUE")
   (find-class 'view-class-direct-slot-definition))
 
 (defmethod effective-slot-definition-class ((class standard-db-class)
-					    #+kmr-normal-esdc &rest
-					    initargs)
+                                            #+kmr-normal-esdc &rest
+                                            initargs)
   (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))
+(when (not (symbol-function 'compute-class-precedence-list))
+  (eval
+   (defun compute-class-precedence-list (class)
+     (class-precedence-list class))))
 
-#-(or sbcl cmu)
+#-mop-slot-order-reversed
 (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)
+        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)
-	    (push name desired-sequence)))))
+        (let ((name (slot-definition-name s)))
+          (unless (find name desired-sequence)
+            (push name desired-sequence)))))
     (dolist (desired desired-sequence)
       (let ((slot (find desired slots :key #'slot-definition-name)))
-	(assert slot)
-	(push slot output-slots)))
+        (assert slot)
+        (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."
-  #-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)))
+(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)
+            (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)
+            'character)
+           ((eq (ensure-keyword specified-type) :varchar)
+            'string)
+           (t
+            specified-type))))
+    (if (and type (not (member :not-null (listify db-constraints))))
+        `(or null ,type)
+        (or type t))))
 
 ;; 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.
 
+(declaim (inline delistify))
+(defun delistify (list)
+  "Some MOPs, like openmcl 0.14.2, cons attribute values in a list."
+  (if (listp list)
+      (car list)
+      list))
+
+(declaim (inline delistify-dsd))
+;; there is an :after method below too
+(defmethod initialize-instance :around
+    ((obj view-class-direct-slot-definition)
+     &rest initargs &key db-constraints db-kind type &allow-other-keys)
+  (when (and (not db-kind) (member :primary-key (listify db-constraints)))
+    (warn "Slot ~S constrained to be :primary-key, but not marked as :db-kind :key"
+          (slot-definition-name obj)))
+  (apply #'call-next-method obj
+         'specified-type type
+         :type (if (and (eql db-kind :virtual) (null type))
+                   t
+                   (compute-lisp-type-from-specified-type
+                    type db-constraints))
+         initargs))
+
+(defun compute-column-name (arg)
+  (database-identifier arg nil))
+
+(defun %convert-db-info-to-hash (slot-def)
+  ;; 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 .... >)?
+  (setf (slot-value slot-def 'db-info)
+        (when (slot-boundp slot-def 'db-info)
+          (let ((info (view-class-slot-db-info slot-def)))
+            (etypecase info
+              (hash-table info)
+              (atom info)
+              (list
+               (cond ((and (> (length info) 1)
+                           (atom (car info)))
+                      (parse-db-info info))
+                     ((and (= 1 (length info))
+                           (listp (car info)))
+                      (parse-db-info (car info)))
+                     (t info))))))))
+
+(defmethod initialize-instance :after
+    ((obj view-class-direct-slot-definition)
+     &key &allow-other-keys)
+  (setf (view-class-slot-column obj) (compute-column-name obj)
+        (view-class-slot-autoincrement-sequence obj)
+        (dequote
+         (view-class-slot-autoincrement-sequence obj)))
+  (%convert-db-info-to-hash obj))
+
 (defmethod compute-effective-slot-definition ((class standard-db-class)
-					      #+kmr-normal-cesd slot-name
-					      direct-slots)
+                                              #+kmr-normal-cesd slot-name
+                                              direct-slots)
   #+kmr-normal-cesd (declare (ignore slot-name))
 
-  (let ((slotd (call-next-method))
-	(sd (car direct-slots)))
-    
-    (typecase sd
-      (view-class-slot-definition-mixin
-       ;; Use the specified :column argument if it is supplied, otherwise
-       ;; the column slot is filled in with the slot-name,  but transformed
-       ;; to be sql safe, - to _ and such.
-       (setf (slot-value slotd 'column)
-             (column-name-from-arg
-              (if (slot-boundp sd 'column)
-                  (view-class-slot-column sd)
-                  (column-name-from-arg
-                   (sql-escape (slot-definition-name sd))))))
-       
-       (setf (slot-value slotd 'db-type)
-             (when (slot-boundp sd 'db-type)
-               (view-class-slot-db-type sd)))
-       
-       (setf (slot-value slotd 'nulls-ok)
-             (view-class-slot-nulls-ok sd))
-       
-       ;; :db-kind slot value defaults to :base (store slot value in
-       ;; database)
-       
-       (setf (slot-value slotd 'db-kind)
-             (if (slot-boundp sd 'db-kind)
-                 (view-class-slot-db-kind sd)
-                 :base))
-       
-       (setf (slot-value slotd 'db-writer)
-             (when (slot-boundp sd 'db-writer)
-               (view-class-slot-db-writer sd)))
-       (setf (slot-value slotd 'db-constraints)
-             (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 .... >)?
-       
-       (setf (slot-value slotd 'db-info)
-             (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))))
-
-       ;; 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
-		     #+allegro :name 
-		     #+allegro (slot-definition-name sd))
-       (setf (slot-value slotd 'column)
-             (column-name-from-arg
-              (sql-escape (slot-definition-name sd))))
-
-       (setf (slot-value slotd 'db-info) nil)
-       (setf (slot-value slotd 'db-kind)
-             :virtual)))
-    slotd))
+  ;; KMR: store the user-specified type and then compute
+  ;; real Lisp type and store it
+  (let ((dsd (car direct-slots)))
+    (let ((esd (call-next-method)))
+      (typecase dsd
+        (view-class-slot-definition-mixin
+         (setf (slot-value esd 'column) (compute-column-name dsd))
+
+         (macrolet
+             ((safe-copy-value (name &optional default)
+                (let ((fn (intern (format nil "~A~A" 'view-class-slot- name ))))
+                  `(setf (slot-value esd ',name)
+                    (or (when (slot-boundp dsd ',name)
+                          (delistify-dsd (,fn dsd)))
+                     ,default)))))
+           (safe-copy-value autoincrement-sequence)
+           (safe-copy-value db-type)
+           (safe-copy-value void-value)
+           (safe-copy-value db-reader)
+           (safe-copy-value db-writer)
+           ;; :db-kind slot value defaults to :base (store slot value in
+           ;; database)
+           (safe-copy-value db-kind :base)
+           (safe-copy-value db-constraints)
+           (safe-copy-value db-info)
+           (%convert-db-info-to-hash esd))
+
+         (setf (specified-type esd)
+               (delistify-dsd (specified-type dsd)))
+         ;; In older SBCL's the type-check-function is computed at
+         ;; defclass expansion, which is too early for the CLSQL type
+         ;; conversion to take place. This gets rid of it. It's ugly
+         ;; but it's better than nothing -wcp10/4/10.
+         #+(and sbcl #.(cl:if (cl:and (cl:find-package :sb-pcl)
+                                      (cl:find-symbol "%TYPE-CHECK-FUNCTION" :sb-pcl))
+                              '(cl:and) '(cl:or)))
+         (setf (slot-value esd 'sb-pcl::%type-check-function) nil)
+
+         )
+        ;; all other slots
+        (t
+         (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)))
+
+         ;; has no column name if it is not a database column
+         (setf (slot-value esd 'column) nil)
+         (setf (slot-value esd 'db-info) nil)
+         (setf (slot-value esd 'db-kind) :virtual)
+         (setf (specified-type esd) (slot-definition-type dsd)))
+        )
+      esd)))
 
 (defun slotdefs-for-slots-with-class (slots class)
   (let ((result nil))
     (dolist (s slots)
       (let ((c (slotdef-for-slot-with-class s class)))
-	(if c (setf result (cons c result)))))
+        (if c (setf result (cons c result)))))
     result))
 
 (defun slotdef-for-slot-with-class (slot class)
-  (find-if #'(lambda (d) (eql slot (slot-definition-name d)))
-	   (class-slots class)))
+  (typecase slot
+    (standard-slot-definition slot)
+    (symbol
+     (find-if #'(lambda (d) (eql slot (slot-definition-name d)))
+              (class-slots class)))))
 
 #+ignore
 (eval-when (:compile-toplevel :load-toplevel :execute)
@@ -513,3 +555,66 @@ which does type checking before storing a value in a slot."
   #+kmr-normal-esdc
   (setq cl:*features* (delete :kmr-normal-esdc cl:*features*))
   )
+
+(defmethod database-identifier ( (name standard-db-class)
+                                &optional database find-class-p)
+  "the majority of this function is in expressions.lisp
+   this is here to make loading be less painful (try-recompiles) in SBCL"
+  (declare (ignore find-class-p))
+  (database-identifier (view-table name) database))
+
+(defmethod database-identifier ((name view-class-slot-definition-mixin)
+                                &optional database find-class-p)
+  (declare (ignore find-class-p))
+  (database-identifier
+   (if (slot-boundp name 'column)
+       (delistify-dsd (view-class-slot-column name))
+       (slot-definition-name name))
+   database))
+
+(defun find-standard-db-class (name &aux cls)
+  (and (setf cls (ignore-errors (find-class name)))
+       (typep cls 'standard-db-class)
+       cls))
+
+(defun slots-for-possibly-normalized-class (class)
+  (if (normalizedp class)
+      (ordered-class-direct-slots class)
+      (ordered-class-slots class)))
+
+(defun key-slot-p (slot-def)
+  "takes a slot def and returns whether or not it is a key"
+  (eql :key (view-class-slot-db-kind slot-def)))
+
+(defun join-slot-p (slot-def)
+  "takes a slot def and returns whether or not it is a key"
+  (eql :join (view-class-slot-db-kind slot-def)))
+
+(defun key-or-base-slot-p (slot-def)
+  "takes a slot def and returns whether or not it is a key"
+  (member (view-class-slot-db-kind slot-def) '(:key :base)))
+
+(defun direct-normalized-slot-p (class slot-name)
+  "Is this a normalized class and if so is the slot one of our direct slots?"
+  (setf slot-name (to-slot-name slot-name))
+  (and (typep class 'standard-db-class)
+       (normalizedp class)
+       (member slot-name (ordered-class-direct-slots class)
+               :key #'slot-definition-name)))
+
+(defun not-direct-normalized-slot-p (class slot-name)
+  "Is this a normalized class and if so is the slot not one of our direct slots?"
+  (setf slot-name (to-slot-name slot-name))
+  (and (typep class 'standard-db-class)
+       (normalizedp class)
+       (not (member slot-name (ordered-class-direct-slots class)
+                    :key #'slot-definition-name))))
+
+(defun slot-has-default-p (slot)
+  "returns nil if the slot does not have a default constraint"
+  (let* ((constraints
+           (when (typep slot '(or view-class-direct-slot-definition
+                               view-class-effective-slot-definition))
+             (listify (view-class-slot-db-constraints slot)))))
+    (member :default constraints)))
+