commit c700e9be8e93b4b7f0ae633d71bc84ef8640702b
parent 941e93ec5c8cda918668e7871ab9ef3d78e6c3bf
Author: Tomas Hlavaty <tom@logand.com>
Date: Tue, 23 Aug 2011 00:15:16 +0200
more mop fixes
- move mop.lisp back to orm.lisp due to compilation inter-dependencies
- introduce %persistent-object due to compute-effective-slot-definition
where slotd is expected to be persistent-slot-definition
- fix make-pinstance and instance except associations/fkeys
Diffstat:
| M | cl-2sql.asd | | | 1 | - |
| D | mop.lisp | | | 319 | ------------------------------------------------------------------------------- |
| M | orm.lisp | | | 367 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++----- |
3 files changed, 348 insertions(+), 339 deletions(-)
diff --git a/cl-2sql.asd b/cl-2sql.asd
@@ -26,5 +26,4 @@
(:file "macros")
;;#+(or postgresql sqlite) (:file "backend")
(:file "backend")
- (:file "mop")
(:file "orm")))
diff --git a/mop.lisp b/mop.lisp
@@ -1,319 +0,0 @@
-(in-package :2sql-orm)
-
-(defparameter *instance-cache* nil)
-
-(defmacro with-instance-cache (args &body body)
- (declare (ignore args))
- `(let ((*instance-cache* (make-hash-table)))
- ,@body))
-
-;; http://users.encs.concordia.ca/~haarslev/publications/jvlc92/node6.html
-;; http://objectmix.com/lisp/725624-help-creating-clos-meta-classes.html
-;; http://www.lispworks.com/documentation/lw50/LWRM/html/lwref-71.htm
-;; http://paste.lisp.org/display/123125
-;; http://www.cliki.net/MOP%20design%20patterns
-;; http://bc.tech.coop/blog/040412.html
-
-(defclass persistent-class (standard-class)
- ())
-
-(defmethod c2mop:validate-superclass ((class persistent-class)
- (superclass standard-class))
- t)
-
-(defclass persistent-object (#+nil standard-object)
- ((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 ()
- `(call-next-method)
- #+nil
- `(if (or #+nil(eq 'persistent-class (class-name class))
- (loop
- for x in direct-superclasses
- thereis (subtypep x (find-class 'persistent-object))))
- ;; already one of the (indirect) superclasses
- (call-next-method)
- ;; not one of the superclasses, so we have to add it
- (apply #'call-next-method class
- :direct-superclasses (append direct-superclasses
- (list (find-class 'persistent-object)))
- initargs)))
-
-;; http://www.cliki.net/MOP%20design%20patterns
-#+nil ;; TODO add persistent-object superclass automatically
-(defmethod initialize-instance :around ((class persistent-class) &rest initargs
- &key direct-superclasses)
- (declare (dynamic-extent initargs))
- (init-instance))
-
-;; http://www.cliki.net/MOP%20design%20patterns
-#+nil ;; TODO add persistent-object superclass automatically
-(defmethod reinitialize-instance :around
- ((class persistent-class) &rest initargs
- &key (direct-superclasses '() direct-superclasses-p))
- (declare (dynamic-extent initargs))
- (if direct-superclasses-p
- ;; if direct superclasses are explicitly passed this is exactly
- ;; like above
- (init-instance)
- ;; if direct superclasses are not explicitly passed we _must_
- ;; not change anything
- (call-next-method)))
-
-(defparameter *initializing-instance* nil)
-
-(defun check-cached-instance (a)
- (unless *initializing-instance*
- (assert (eq a (gethash (oid a) *instance-cache*)))))
-
-(defmethod c2mop::shared-initialize :around ((object persistent-object)
- slot-names &rest initargs
- &key &allow-other-keys)
- (declare (ignore initargs))
- (let ((*initializing-instance* t))
- (call-next-method)))
-
-(defmethod c2mop:slot-value-using-class :before ((class persistent-class)
- (a persistent-object)
- slotd)
- (unless (eq 'oid (c2mop:slot-definition-name slotd))
- (check-cached-instance a)))
-
-(defmethod (setf c2mop:slot-value-using-class) :before (value
- (class persistent-class)
- (a persistent-object)
- slotd)
- (unless (eq 'oid (c2mop:slot-definition-name slotd))
- (check-cached-instance a)))
-
-(defstruct proxy oid)
-
-(defmethod c2mop:slot-value-using-class :around ((class persistent-class)
- (a persistent-object)
- slotd)
- (let ((a (call-next-method)))
- a
- #+nil ;; TODO only for proxy slots
- (etypecase a
- (proxy (error "TODO maybe-dereference-proxy ~s" a))
- (persistent-object a))))
-
-(defmethod (setf c2mop:slot-value-using-class) :around (value
- (class persistent-class)
- (a persistent-object)
- slotd)
- (call-next-method)
- #+nil(error "TODO (setf c2mop:slot-value-using-class) :around"))
-
-;;; persistent slots
-
-(defclass persistent-slot-definition ()
- ((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)
- ())
-
-(defclass persistent-effective-slot-definition
- (persistent-slot-definition c2mop:standard-effective-slot-definition)
- ())
-
-(defmethod c2mop:direct-slot-definition-class :around
- ((class persistent-class) &rest initargs)
- ;;(print (list :@@@-direct-slot-definition-class initargs))
- (find-class 'persistent-direct-slot-definition))
-
-(defmethod c2mop:effective-slot-definition-class
- ((class persistent-class) &rest initargs)
- ;;(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))
-
-(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-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-direct-slot-definition) &rest initargs
- &key direct-superclasses)
- ;;(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 ()
- ((hi :initarg :hi)))
-
-;;(c2mop:class-slots (find-class 'foo))
-
-#+nil
-(defclass person (#+nil persistent-object foo)
- ((name :type string :initarg :name #+nil :transient #+nil t)
- (age :type natural0 :initarg :age))
- (:metaclass persistent-class))
-
-;;(slot-value (make-instance 'person :age 12) 'age)
-
-;;(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~%"
- (c2mop:slot-definition-name s)
- (slot-value x (c2mop:slot-definition-name s)))))
-
-#+nil
-(defun persistent-slot-p (slot)
- (when (typep slot 'persistent-slot)
- (transient slot)))
-
-#+nil
-(defun list-pslots2 (class)
- (c2mop:class-slots class)
- #+nil
- (remove-if 'transient (c2mop:class-slots class)))
-
-;;(list-pslots (find-class 'person))
-;;(list-pslots (class-of (make-instance 'person :hi "cus" :name "John" :age 12)))
-
-
-
-
-;; 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)))
-
-(defun pslot-name (a)
- (c2mop:slot-definition-name a))
-
-(defun pslot-ltype (a)
- (ltype a))
-
-(defun pslot-initargs (a)
- (c2mop:slot-definition-initargs a))
-
-(defun pslot-initform (a)
- (c2mop:slot-definition-initform a))
-
-(defun pslot-ptype (a)
- (ptype a))
-
-(defun pslot-nullable (a)
- (nullable a))
-
-;; (pslot-ptype (cadr (list-pslots (find-class 'person))))
-
-#+nil
-(defpclass bar ()
- ((slot1 :initarg :slot1 :accessor slot1)
- (slot2 :initarg :slot2 :accessor slot2)))
-
-;;(with-instance-cache () (slot2 (make-pinstance 'bar :oid 123 :slot2 2)))
-;;(setf (slot2 (make-instance 'bar :slot2 2)) 3)
-;;(slot-value (make-instance 'bar :slot2 2) 'slot2)
-;;(setf (slot-value (make-instance 'bar :slot2 2) 'slot2) 3)
-
-#+nil
-(defpclass person ()
- ((name :type string :initarg :name)
- (age :type natural0 :initarg :age))
- #+nil
- (:metaclass persistent-class))
-
-#+nil
-(defpclass person ()
- ((name :type string :initarg :name)
- (birth-date :type pdate :initarg :birth-date))
- #+nil
- (:metaclass persistent-class))
-
-
-
-;;; http://www.b9.com/blog/archives/000084.html
-;;
-;; Also, special thanks to Christophe Rhodes, frequent contributor to
-;; SBCL's MOP, for his excellent suggestion in response to a question
-;; for improving CLSQL's MOP internals: CLSQL object definitions use
-;; custom slot types. For example, a CLSQL slot may have :type
-;; (varchar 10) specified which gets translated to a lisp type of (or
-;; null string). Rather than parsing and then re-storing the type
-;; atrribute of a slot in compute-effective-slot-definiton, Christophe
-;; suggested performing the type parsing in initialize-instance
-;; :around of the CLSQL direct-slot-definition object. Then, the real
-;; type attribute is stored in the both the direct and effective slot
-;; definition from the beginning.This is more AMOP complaint since
-;; 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.
diff --git a/orm.lisp b/orm.lisp
@@ -2,6 +2,8 @@
(in-package :2sql-orm)
+;;; orm types
+
;; string => string | clob
;; string 3 => char 3
;; text 5 &optional 2 => varchar 5 (no "" allowed, due to oracle)
@@ -113,9 +115,331 @@
(defptype oid () 'natural1)
+;;; persistent-object
+
+(defparameter *instance-cache* nil)
+
+(defmacro with-instance-cache (args &body body)
+ (declare (ignore args))
+ `(let ((*instance-cache* (make-hash-table)))
+ ,@body))
+
+;; http://users.encs.concordia.ca/~haarslev/publications/jvlc92/node6.html
+;; http://objectmix.com/lisp/725624-help-creating-clos-meta-classes.html
+;; http://www.lispworks.com/documentation/lw50/LWRM/html/lwref-71.htm
+;; http://paste.lisp.org/display/123125
+;; http://www.cliki.net/MOP%20design%20patterns
+;; http://bc.tech.coop/blog/040412.html
+
+(defclass persistent-class (standard-class)
+ ())
+
+(defmethod c2mop:validate-superclass ((class persistent-class)
+ (superclass standard-class))
+ t)
+
+(defclass %persistent-object (#+nil standard-object)
+ ()
+ (: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 ()
+ `(call-next-method)
+ #+nil
+ `(if (or #+nil(eq 'persistent-class (class-name class))
+ (loop
+ for x in direct-superclasses
+ thereis (subtypep x (find-class 'persistent-object))))
+ ;; already one of the (indirect) superclasses
+ (call-next-method)
+ ;; not one of the superclasses, so we have to add it
+ (apply #'call-next-method class
+ :direct-superclasses (append direct-superclasses
+ (list (find-class 'persistent-object)))
+ initargs)))
+
+;; http://www.cliki.net/MOP%20design%20patterns
+#+nil ;; TODO add persistent-object superclass automatically
+(defmethod initialize-instance :around ((class persistent-class) &rest initargs
+ &key direct-superclasses)
+ (declare (dynamic-extent initargs))
+ (init-instance))
+
+;; http://www.cliki.net/MOP%20design%20patterns
+#+nil ;; TODO add persistent-object superclass automatically
+(defmethod reinitialize-instance :around
+ ((class persistent-class) &rest initargs
+ &key (direct-superclasses '() direct-superclasses-p))
+ (declare (dynamic-extent initargs))
+ (if direct-superclasses-p
+ ;; if direct superclasses are explicitly passed this is exactly
+ ;; like above
+ (init-instance)
+ ;; if direct superclasses are not explicitly passed we _must_
+ ;; not change anything
+ (call-next-method)))
+
+(defparameter *initializing-instance* nil)
+
+(defun check-cached-instance (a)
+ (unless *initializing-instance*
+ (assert (eq a (gethash (oid a) *instance-cache*)))))
+
+(defmethod c2mop::shared-initialize :around ((object %persistent-object)
+ slot-names &rest initargs
+ &key &allow-other-keys)
+ (declare (ignore initargs))
+ (let ((*initializing-instance* t))
+ (call-next-method)))
+
+(defmethod c2mop:slot-value-using-class :before ((class persistent-class)
+ (a %persistent-object)
+ slotd)
+ (unless (eq 'oid (c2mop:slot-definition-name slotd))
+ (check-cached-instance a)))
+
+(defmethod (setf c2mop:slot-value-using-class) :before (value
+ (class persistent-class)
+ (a %persistent-object)
+ slotd)
+ (unless (eq 'oid (c2mop:slot-definition-name slotd))
+ (check-cached-instance a)))
+
+(defstruct proxy oid)
+
+(defmethod c2mop:slot-value-using-class :around ((class persistent-class)
+ (a %persistent-object)
+ slotd)
+ (let ((a (call-next-method)))
+ a
+ #+nil ;; TODO only for proxy slots
+ (etypecase a
+ (proxy (error "TODO maybe-dereference-proxy ~s" a))
+ (%persistent-object a))))
+
+(defmethod (setf c2mop:slot-value-using-class) :around (value
+ (class persistent-class)
+ (a %persistent-object)
+ slotd)
+ (call-next-method)
+ #+nil(error "TODO (setf c2mop:slot-value-using-class) :around"))
+
+;;; persistent slots
+
+(defclass persistent-slot-definition ()
+ ((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)
+ ())
+
+(defclass persistent-effective-slot-definition
+ (persistent-slot-definition c2mop:standard-effective-slot-definition)
+ ())
+
+(defmethod c2mop:direct-slot-definition-class :around
+ ((class persistent-class) &rest initargs)
+ ;;(print (list :@@@-direct-slot-definition-class initargs))
+ (find-class 'persistent-direct-slot-definition))
+
+(defmethod c2mop:effective-slot-definition-class
+ ((class persistent-class) &rest initargs)
+ ;;(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))
+
+(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-class) name direct-slot-definitions)
+ (let ((x (call-next-method)))
+ (assert (not (cdr direct-slot-definitions))) ;; TODO
+ (let ((slotd (car direct-slot-definitions)))
+ (assert (typep slotd 'persistent-slot-definition))
+ (with-slots (ltype ptype nullable) x ;; TODO transient
+ (setq ltype (ltype slotd)
+ ptype (ptype slotd)
+ nullable (nullable slotd))))
+ x))
+
+#+nil
+(defmethod initialize-instance :around
+ ((class persistent-direct-slot-definition) &rest initargs
+ &key direct-superclasses)
+ ;;(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 ()
+ ((hi :initarg :hi)))
+
+;;(c2mop:class-slots (find-class 'foo))
+
+#+nil
+(defclass person (#+nil persistent-object foo)
+ ((name :type string :initarg :name #+nil :transient #+nil t)
+ (age :type natural0 :initarg :age))
+ (:metaclass persistent-class))
+
+;;(slot-value (make-instance 'person :age 12) 'age)
+
+;;(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~%"
+ (c2mop:slot-definition-name s)
+ (slot-value x (c2mop:slot-definition-name s)))))
+
+#+nil
+(defun persistent-slot-p (slot)
+ (when (typep slot 'persistent-slot)
+ (transient slot)))
+
+#+nil
+(defun list-pslots2 (class)
+ (c2mop:class-slots class)
+ #+nil
+ (remove-if 'transient (c2mop:class-slots class)))
+
+;;(list-pslots (find-class 'person))
+;;(list-pslots (class-of (make-instance 'person :hi "cus" :name "John" :age 12)))
+
+
+
+
+;; 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)))
+
+(defun pslot-name (a)
+ (c2mop:slot-definition-name a))
+
+(defun pslot-ltype (a)
+ (ltype a))
+
+(defun pslot-initargs (a)
+ (c2mop:slot-definition-initargs a))
+
+(defun pslot-initform (a)
+ (c2mop:slot-definition-initform a))
+
+(defun pslot-ptype (a)
+ (ptype a))
+
+(defun pslot-nullable (a)
+ (nullable a))
+
+;; (pslot-ptype (cadr (list-pslots (find-class 'person))))
+
+#+nil
+(defpclass bar ()
+ ((slot1 :initarg :slot1 :accessor slot1)
+ (slot2 :initarg :slot2 :accessor slot2)))
+
+;;(with-instance-cache () (slot2 (make-pinstance 'bar :oid 123 :slot2 2)))
+;;(setf (slot2 (make-instance 'bar :slot2 2)) 3)
+;;(slot-value (make-instance 'bar :slot2 2) 'slot2)
+;;(setf (slot-value (make-instance 'bar :slot2 2) 'slot2) 3)
+
+#+nil
+(defpclass person ()
+ ((name :type string :initarg :name)
+ (age :type natural0 :initarg :age))
+ #+nil
+ (:metaclass persistent-class))
+
+#+nil
+(defpclass person ()
+ ((name :type string :initarg :name)
+ (birth-date :type pdate :initarg :birth-date))
+ #+nil
+ (:metaclass persistent-class))
+
+
+
+;;; http://www.b9.com/blog/archives/000084.html
+;;
+;; Also, special thanks to Christophe Rhodes, frequent contributor to
+;; SBCL's MOP, for his excellent suggestion in response to a question
+;; for improving CLSQL's MOP internals: CLSQL object definitions use
+;; custom slot types. For example, a CLSQL slot may have :type
+;; (varchar 10) specified which gets translated to a lisp type of (or
+;; null string). Rather than parsing and then re-storing the type
+;; atrribute of a slot in compute-effective-slot-definiton, Christophe
+;; suggested performing the type parsing in initialize-instance
+;; :around of the CLSQL direct-slot-definition object. Then, the real
+;; type attribute is stored in the both the direct and effective slot
+;; definition from the beginning.This is more AMOP complaint since
+;; 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.
+
+
+(defclass persistent-object (%persistent-object)
+ ((oid :type oid :initarg :oid :accessor oid))
+ (:metaclass persistent-class))
+
(defmethod cl-postgres:to-sql-string ((a persistent-object))
(cl-postgres:to-sql-string (oid a)))
+;;; db stuff
+
(defconstant +class-id-bit-size+ 16)
(defmacro oid-exp (class-id)
@@ -158,7 +482,7 @@
(q:returning ,returning-cols))))
(defun assert-type (value type)
- (print (list :assert-type1 value type (type-of value)))
+ ;;(print (list :assert-type1 value type (type-of value)))
(unless (typep value type)
(cond ;; TODO more cases
((typep value 'string)
@@ -172,10 +496,14 @@
:timezone nil))))
((subtypep type 'persistent-object)
(error "TODO assert-type persistent-object"))))
- (print (list :assert-type2 value type (type-of value)))
+ ;;(print (list :assert-type2 value type (type-of value)))
(assert (typep value type))
value)
+(defun cache-pinstance (a)
+ (assert (not (gethash (oid a) *instance-cache*)))
+ (setf (gethash (oid a) *instance-cache*) a))
+
(defun make-pinstance (class-name &rest args)
(multiple-value-bind (known unknown)
(loop
@@ -187,20 +515,19 @@
if c collect (list (cadr c) name initarg ltype) into known
else collect (list name initarg ltype) into unknown
finally (return (values known unknown)))
- (let ((x (apply #'make-instance class-name
- (nconc
- (loop
- for (v name initarg ltype) in known
- appending (list initarg (assert-type v ltype)))
- (loop
- for (name initarg ltype) in unknown
- for v in (car
- (insert-into class-name (mapcar #'cadr known)
- (mapcar #'car known)
- (mapcar #'car unknown)))
- appending (list initarg (assert-type v ltype)))))))
- (assert (not (gethash (oid x) *instance-cache*)))
- (setf (gethash (oid x) *instance-cache*) x))))
+ (cache-pinstance
+ (apply #'make-instance class-name
+ (nconc
+ (loop
+ for (v name initarg ltype) in known
+ appending (list initarg (assert-type v ltype)))
+ (loop
+ for (name initarg ltype) in unknown
+ for v in (car
+ (insert-into class-name (mapcar #'cadr known)
+ (mapcar #'car known)
+ (mapcar #'car unknown)))
+ appending (list initarg (assert-type v ltype))))))))
(defparameter *instance-collector-cache* nil) ;; equal form->fn
@@ -239,12 +566,14 @@
(defmacro instance (tab &optional alias) ;; use inside 2sql queries
(let ((pslots (list-pslots tab)))
(push (lambda (row)
- (values (let ((oid (pop row))
+ (values (let ((oid (car row))
(args (loop
for x in pslots
- appending (list (car (pslot-initargs x)) (pop row))))) ;; TODO resolve pclassp foreign ref (lazy foreign reference?)
+ appending (list (car (pslot-initargs x))
+ (assert-type (pop row) (pslot-ltype x)))))) ;; TODO resolve pclassp foreign ref (lazy foreign reference?)
+ ;;(print (list :@@@ (mapcar (lambda (x) (cons x (type-of x))) args)))
(or (gethash oid *instance-cache*)
- (apply #'make-pinstance tab :oid oid args)) ;; TODO test this case
+ (cache-pinstance (apply #'make-instance tab args)))
#+nil
(unless (eq :null oid)
;; TODO uniq oid->instance cache
