X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fmetaclasses.lisp;h=34e6c696cd9e1a8af59be50d93989abc51e7fe0d;hb=e3f355aa2b125569097bd7108fbbd14daa23e7aa;hp=a0b94716461ac2683559dab24189eeb57e79c5a4;hpb=e3ed4080f0a28d94e81aad7452fb1f81e1e50253;p=clsql.git diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp index a0b9471..34e6c69 100644 --- a/sql/metaclasses.lisp +++ b/sql/metaclasses.lisp @@ -37,7 +37,7 @@ ;; ------------------------------------------------------------ ;; metaclass: view-class -(defclass standard-db-class (standard-class) +(defclass view-metaclass (standard-class) ((view-table :accessor view-table :initarg :view-table) @@ -91,7 +91,7 @@ #+lispworks (defmethod clos::canonicalize-defclass-slot :around - ((prototype standard-db-class) slot) + ((prototype view-metaclass) slot) "\\lw\\ signals an error on unknown slot options; so this method removes any extra allowed options before calling the default method and returns the canonicalized extra options concatenated to the result @@ -121,7 +121,7 @@ of the default method. The extra allowed options are the value of the #+lispworks (defmethod clos::canonicalize-class-options :around - ((prototype standard-db-class) class-options) + ((prototype view-metaclass) class-options) "\\lw\\ signals an error on unknown class options; so this method removes any extra allowed options before calling the default method and returns the canonicalized extra options concatenated to the result @@ -145,7 +145,7 @@ of the default method. The extra allowed options are the value of the result)) -(defmethod validate-superclass ((class standard-db-class) +(defmethod validate-superclass ((class view-metaclass) (superclass standard-class)) t) @@ -178,13 +178,13 @@ of the default method. The extra allowed options are the value of the (pop-arg mylist)) newlist)) -(defmethod initialize-instance :around ((class standard-db-class) +(defmethod initialize-instance :around ((class view-metaclass) &rest all-keys &key direct-superclasses base-table schemas version qualifier &allow-other-keys) (let ((root-class (find-class 'standard-db-object nil)) - (vmc (find-class 'standard-db-class))) + (vmc (find-class 'view-metaclass))) (setf (view-class-qualifier class) (car qualifier)) (if root-class @@ -210,13 +210,13 @@ of the default method. The extra allowed options are the value of the (register-metaclass class (nth (1+ (position :direct-slots all-keys)) all-keys)))) -(defmethod reinitialize-instance :around ((class standard-db-class) +(defmethod reinitialize-instance :around ((class view-metaclass) &rest all-keys &key base-table schemas version direct-superclasses qualifier &allow-other-keys) (let ((root-class (find-class 'standard-db-object nil)) - (vmc (find-class 'standard-db-class))) + (vmc (find-class 'view-metaclass))) (setf (view-table class) (table-name-from-arg (sql-escape (or (and base-table (if (listp base-table) @@ -284,9 +284,9 @@ of the default method. The extra allowed options are the value of the (ordered-class-slots class))))) #+(or allegro openmcl) -(defmethod finalize-inheritance :after ((class standard-db-class)) +(defmethod finalize-inheritance :after ((class view-metaclass)) ;; KMRL for slots without a type set, openmcl sets type-predicate to ccl:false - ;; for standard-db-class + ;; for view-metaclass #+openmcl (mapcar #'(lambda (s) @@ -437,13 +437,13 @@ all NULL values retrieved are converted by DATABASE-NULL-VALUE") standard-effective-slot-definition) ()) -(defmethod direct-slot-definition-class ((class standard-db-class) +(defmethod direct-slot-definition-class ((class view-metaclass) #+kmr-normal-dsdc &rest initargs) (declare (ignore initargs)) (find-class 'view-class-direct-slot-definition)) -(defmethod effective-slot-definition-class ((class standard-db-class) +(defmethod effective-slot-definition-class ((class view-metaclass) #+kmr-normal-esdc &rest initargs) (declare (ignore initargs)) @@ -455,25 +455,22 @@ all NULL values retrieved are converted by DATABASE-NULL-VALUE") (class-precedence-list class)) #-(or sbcl cmu) -(defmethod compute-slots ((class standard-db-class)) +(defmethod compute-slots ((class view-metaclass)) "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 + (push name desired-sequence))))) (dolist (desired desired-sequence) (let ((slot (find desired slots :key #'slot-definition-name))) (assert slot) (push slot output-slots))) - - (nreverse 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 @@ -509,7 +506,7 @@ which does type checking before storing a value in a slot." ;; what kind of database value (if any) is stored there, generates and ;; verifies the column name. -(defmethod compute-effective-slot-definition ((class standard-db-class) +(defmethod compute-effective-slot-definition ((class view-metaclass) #+kmr-normal-cesd slot-name direct-slots) #+kmr-normal-cesd (declare (ignore slot-name)) @@ -592,7 +589,7 @@ which does type checking before storing a value in a slot." (defun slotdef-for-slot-with-class (slot class) (find-if #'(lambda (d) (eql slot (slot-definition-name d))) - (ordered-class-slots class))) + (class-slots class))) #+ignore (eval-when (:compile-toplevel :load-toplevel :execute)