X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=mop.lisp;h=3505a1bdf754c72113855cebbd510907d3e89cbc;hb=90c2e4c13bd89c48de9fe0da126547447b7b9e01;hp=a3500c410f91a8d3b788a1b8d87d259d438e85a1;hpb=6f01128c624d4879ef724be4e514b2fa2b9d0f63;p=hyperobject.git diff --git a/mop.lisp b/mop.lisp index a3500c4..3505a1b 100644 --- a/mop.lisp +++ b/mop.lisp @@ -51,6 +51,9 @@ (subobjects :initform nil :accessor subobjects :documentation "List of fields that contain a list of subobjects objects.") + (compute-cached-values :initform nil :accessor compute-cached-values + :documentation + "List of fields that contain a list of compute-cached-value objects.") (hyperlinks :type list :initform nil :accessor hyperlinks :documentation "List of fields that have hyperlinks") (direct-rules :type list :initform nil :initarg :direct-rules @@ -82,11 +85,22 @@ (defclass subobject () ((name-class :type symbol :initarg :name-class :reader name-class) (name-slot :type symbol :initarg :name-slot :reader name-slot) - (subobj-class :type symbol :initarg :subobj-class :reader subobj-class) + (lazy-class :type symbol :initarg :lazy-class :reader lazy-class) (lookup :type (or function symbol) :initarg :lookup :reader lookup) (lookup-keys :type list :initarg :lookup-keys :reader lookup-keys)) (:documentation "subobject information") - (:default-initargs :name-class nil :name-slot nil :subobj-class nil + (:default-initargs :name-class nil :name-slot nil :lazy-class nil + :lookup nil :lookup-keys nil)) + +(defclass compute-cached-value () + ((name-class :type symbol :initarg :name-class :reader name-class) + (name-slot :type symbol :initarg :name-slot :reader name-slot) + (lazy-class :type symbol :initarg :lazy-class + :reader lazy-class) + (lookup :type (or function symbol) :initarg :lookup :reader lookup) + (lookup-keys :type list :initarg :lookup-keys :reader lookup-keys)) + (:documentation "subobject information") + (:default-initargs :name-class nil :name-slot nil :lazy-class nil :lookup nil :lookup-keys nil)) @@ -112,13 +126,7 @@ t) (defmethod finalize-inheritance :after ((cl hyperobject-class)) - ;; Work-around needed for OpenMCL - #+ignore - (unless (find-class (class-name cl)) - (setf (find-class (class-name cl)) cl)) - - (init-hyperobject-class cl) - ) + (init-hyperobject-class cl)) (eval-when (:compile-toplevel :load-toplevel :execute) (when (>= (length (generic-function-lambda-list @@ -139,16 +147,16 @@ 3) (pushnew :ho-normal-esdc cl:*features*))) -;; Slot definitions (defmethod direct-slot-definition-class ((cl hyperobject-class) #+ho-normal-dsdc &rest iargs) + (declare (ignore iargs)) (find-class 'hyperobject-dsd)) (defmethod effective-slot-definition-class ((cl hyperobject-class) #+ho-normal-esdc &rest iargs) + (declare (ignore iargs)) (find-class 'hyperobject-esd)) - ;;; Slot definitions (eval-when (:compile-toplevel :load-toplevel :execute) @@ -234,22 +242,21 @@ t))) (defmethod initialize-instance :around ((obj hyperobject-dsd) &rest initargs) - (do* ((saved-initargs initargs) - (parsed (list obj)) + (do* ((parsed (list obj)) (name (first initargs) (first initargs)) (val (second initargs) (second initargs))) - ((null initargs) - (apply #'call-next-method parsed)) + ((null initargs) + (apply #'call-next-method parsed)) (if (eql name :value-type) (progn (setq val (canonicalize-value-type val)) (setq parsed (append parsed (list name val))) (setq parsed (append parsed (list :type (value-type-to-lisp-type - (canonicalize-value-type val)))))) - (setq parsed (append parsed (list name val)))) + (canonicalize-value-type val)))))) + (setq parsed (append parsed (list name val)))) (setq initargs (cddr initargs)))) - + (defmethod compute-effective-slot-definition :around ((cl hyperobject-class) #+ho-normal-cesd name dsds) @@ -267,7 +274,7 @@ (setf (esd-sql-length esd) sql-length)) (setf (esd-user-name esd) (aif (dsd-user-name dsd) - it + it (string-downcase (symbol-name (slot-definition-name dsd))))) (setf (esd-sql-name esd) (aif (dsd-sql-name dsd) @@ -278,11 +285,11 @@ it (lisp-name-to-sql-name (slot-definition-name dsd)))) (dolist (name '(value-type print-formatter subobject hyperlink - hyperlink-parameters + hyperlink-parameters unbound-lookup description value-constraint indexed null-allowed unique short-description void-text read-only-groups hidden-groups unit disable-predicate view-type - list-of-values stored)) + list-of-values compute-cached-value stored)) (setf (slot-value esd name) (slot-value dsd name))) esd)) @@ -394,10 +401,11 @@ SQL name" ;; The reader is a function and the reader-keys are slot names. The slot is lazily set to ;; the result of applying the function to the slot-values of those slots, and that value ;; is also returned. -(defun ensure-lazy-reader (cl class-name slot-name subobj-class reader +(defun ensure-lazy-reader (cl class-name slot-name lazy-class reader &rest reader-keys) + (declare (ignore class-name)) (setf (getf (gethash cl *lazy-readers*) slot-name) - (aif subobj-class + (aif lazy-class it (list* reader (copy-list reader-keys))))) @@ -406,35 +414,40 @@ SQL name" nil)) +(defun store-lazily-computed-objects (cl slot esd-accessor obj-class) + (setf (slot-value cl slot) + (let ((objs '())) + (dolist (slot (class-slots cl)) + (let-when + (def (funcall esd-accessor slot)) + (let ((obj (make-instance obj-class + :name-class (class-name cl) + :name-slot (slot-definition-name slot) + :lazy-class (when (atom def) + def) + :lookup (when (listp def) + (car def)) + :lookup-keys (when (listp def) + (cdr def))))) + (unless (eq (lookup obj) t) + (apply #'ensure-lazy-reader + cl + (name-class obj) (name-slot obj) + (lazy-class obj) + (lookup obj) (lookup-keys obj)) + (push obj objs))))) + ;; sbcl/cmu reverse class-slots compared to the defclass form + ;; so re-reverse on cmu/sbcl + #+(or cmu sbcl) objs + #-(or cmu sbcl) (nreverse objs) + ))) + (defun finalize-subobjects (cl) - "Process class subobjects slot" - (setf (subobjects cl) - (let ((subobjects '())) - (dolist (slot (class-slots cl)) - (let-when - (subobj-def (esd-subobject slot)) - (let ((subobject - (make-instance 'subobject - :name-class (class-name cl) - :name-slot (slot-definition-name slot) - :subobj-class (when (atom subobj-def) - subobj-def) - :lookup (when (listp subobj-def) - (car subobj-def)) - :lookup-keys (when (listp subobj-def) - (cdr subobj-def))))) - (unless (eq (lookup subobject) t) - (apply #'ensure-lazy-reader - cl - (name-class subobject) (name-slot subobject) - (subobj-class subobject) - (lookup subobject) (lookup-keys subobject)) - (push subobject subobjects))))) - ;; sbcl/cmu reverse class-slots compared to the defclass form - ;; so re-reverse on cmu/sbcl - #+(or cmu sbcl) subobjects - #-(or cmu sbcl) (nreverse subobjects) - ))) + (store-lazily-computed-objects cl 'subobjects 'esd-subobject 'subobject)) + +(defun finalize-compute-cached (cl) + (store-lazily-computed-objects cl 'compute-cached-values + 'esd-compute-cached-value 'compute-cached-value)) (defun finalize-class-slots (cl) "Make sure all class slots have an expected value" @@ -493,6 +506,7 @@ SQL name" (defun init-hyperobject-class (cl) "Initialize a hyperobject class. Calculates all class slots" (finalize-subobjects cl) + (finalize-compute-cached cl) (finalize-views cl) (finalize-hyperlinks cl) (finalize-sql cl)