cl-2sql

commit 941e93ec5c8cda918668e7871ab9ef3d78e6c3bf
parent cc2c82a56b8af4bcac3bf344398eb55c4b3f567f
Author: Tomas Hlavaty <tom@logand.com>
Date:   Tue, 23 Aug 2011 00:04:50 +0200

remember ltype, ptype and nullable and add transient slots in persistent-slot-definition

Diffstat:
M
mop.lisp
 | 
87
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-----------------

1 file changed, 69 insertions(+), 18 deletions(-)
diff --git a/mop.lisp b/mop.lisp
@@ -25,6 +25,9 @@
   ((oid :type oid :initarg :oid :accessor oid))
   (:metaclass persistent-class))
 
+;;(c2mop:ensure-finalized (find-class 'persistent-object))
+;;(c2mop:class-slots (find-class 'persistent-object))
+
 ;; http://www.cliki.net/MOP%20design%20patterns
 #+nil ;; TODO add persistent-object superclass automatically
 (defmacro init-instance ()
@@ -111,9 +114,10 @@
 ;;; persistent slots
 
 (defclass persistent-slot-definition ()
-  (#+nil(transient :type boolean :initarg :transient :initform nil :accessor transient)
-   #+nil(ptype :initarg :ptype :accessor ptype)
-   #+nil(nullable :initarg :nullable :accessor nullable)))
+  ((ltype :reader ltype) ;; remember unexpanded
+   (ptype :reader ptype) ;; remember computed
+   (nullable :reader nullable)
+   (transient :type boolean :initarg :transient :initform nil :accessor transient)))
 
 (defclass persistent-direct-slot-definition
     (persistent-slot-definition c2mop:standard-direct-slot-definition)
@@ -133,30 +137,69 @@
   ;;(format t "getting eff class. initargs=~s~%" initargs)
   (find-class 'persistent-effective-slot-definition))
 
+#+nil
 (defmethod c2mop:compute-effective-slot-definition
     ((class persistent-class) slot-name direct-slots)
+  (call-next-method)
   #+nil
   (format t "computing slot definition: class=~s name=~s slots=~s~%"
           class slot-name direct-slots)
+  #+nil
   (let ((result (call-next-method)))
     ;;(break "~s" result)
     #+nil
     (format t "    result: ~s~%" result)
     result))
 
-#+nil
+(defmethod initialize-instance :before
+    ((class persistent-direct-slot-definition) &rest initargs
+     &key direct-superclasses)
+  (declare (ignore direct-superclasses))
+  (with-slots (ltype ptype nullable) class ;; TODO transient
+    (setq ltype (getf initargs :type)
+          ptype (lisp-type-to-ptype ltype)
+          nullable (unless (eql 'boolean ltype)
+                     (typep nil ltype)))))
+
 (defmethod c2mop:compute-effective-slot-definition :around
-    ((class persistent-effective-slot-definition) name direct-slot-definitions)
-  (make-instance (c2mop:effective-slot-definition-class class)))
+    ((class persistent-class) name direct-slot-definitions)
+  (let ((x (call-next-method)))
+    (assert (not (cdr direct-slot-definitions))) ;; TODO
+    (let ((slotd (car direct-slot-definitions)))
+      (if (or (typep slotd 'persistent-direct-slot-definition)
+              (typep slotd 'persistent-effective-slot-definition))
+          (with-slots (ltype ptype nullable) x
+            (setq ltype (ltype slotd)
+                  ptype (ptype slotd)
+                  nullable (nullable slotd)))
+          (error "OOPS ~s" slotd)
+          #+nil
+          (with-slots (transient) x
+            (setq transient t))))
+    x))
 
 #+nil
 (defmethod initialize-instance :around
-    ((class persistent-effective-slot-definition) &rest initargs
+    ((class persistent-direct-slot-definition) &rest initargs
      &key direct-superclasses)
-  (declare (ignore direct-superclasses))
-  (print (list :@@@@ initargs))
-  (call-next-method))
-
+  ;;(declare (ignore direct-superclasses))
+  #+nil
+  (with-slots (ltype ptype nullable) class
+    (setq ltype (getf initargs :type)
+          ptype (lisp-type-to-ptype ltype)
+          nullable (unless (eql 'boolean ltype)
+                     (typep nil ltype))))
+  (call-next-method)
+  #+nil
+  (let ((ltype (getf initargs :type)))
+    (apply #'call-next-method
+           class
+           `(:ltype ,ltype
+                    :ptype ,(lisp-type-to-ptype ltype)
+                    :nullable ,(unless (eql 'boolean ltype)
+                                       (typep nil ltype))
+                    ,@initargs)
+           direct-superclasses)))
 
 #+nil
 (defclass foo ()
@@ -175,6 +218,15 @@
 ;;(c2mop:class-slots (find-class 'person))
 
 #+nil
+(defclass person2 (persistent-object foo)
+  ((name :type string :initarg :name #+nil :transient #+nil t)
+   (age :type natural0 :initarg :age))
+  (:metaclass persistent-class))
+
+;;(c2mop:ensure-finalized (find-class 'person2))
+;;(c2mop:class-slots (find-class 'person2))
+
+#+nil
 (let ((x (make-instance 'person :hi "cus" :name "John" :age 12)))
   (dolist (s (c2mop:class-slots (class-of x)))
     (format t "slot ~s = ~s~%"
@@ -197,6 +249,8 @@
 
 
 
+
+;; TODO revert to defmethod or hook initialize-instance, ccl expands types too early:-{
 (defun list-pslots (class)
   (c2mop:class-slots (if (symbolp class) (find-class class) class)))
 
@@ -204,7 +258,7 @@
   (c2mop:slot-definition-name a))
 
 (defun pslot-ltype (a)
-  (c2mop:slot-definition-type a))
+  (ltype a))
 
 (defun pslot-initargs (a)
   (c2mop:slot-definition-initargs a))
@@ -213,12 +267,10 @@
   (c2mop:slot-definition-initform a))
 
 (defun pslot-ptype (a)
-  (lisp-type-to-ptype (pslot-ltype a)))
+  (ptype a))
 
 (defun pslot-nullable (a)
-  (let ((type (pslot-ltype a)))
-    (unless (eql 'boolean type)
-      (typep nil type))))
+  (nullable a))
 
 ;; (pslot-ptype (cadr (list-pslots (find-class 'person))))
 
@@ -264,4 +316,4 @@
 ;; AMOP doesn't specify that one may change the type attribute of a
 ;; slot. This is clearly seen since CLSQL no longer needs to modify
 ;; OpenMCL's ccl:type-predicate slot attribute after the type was
-;; changed in compute-effective-slot-definition.
-\ No newline at end of file
+;; changed in compute-effective-slot-definition.