X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=mop.lisp;h=3505a1bdf754c72113855cebbd510907d3e89cbc;hb=90c2e4c13bd89c48de9fe0da126547447b7b9e01;hp=5307f3ed545f07ed60be74ca9ee88378f1ab2cce;hpb=0bbfff4333e985e6a556d118d12cd23fa1d96a47;p=hyperobject.git diff --git a/mop.lisp b/mop.lisp index 5307f3e..3505a1b 100644 --- a/mop.lisp +++ b/mop.lisp @@ -13,9 +13,9 @@ ;;;; ;;;; $Id$ ;;;; -;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg +;;;; This file is Copyright (c) 2000-2006 by Kevin M. Rosenberg ;;;; ************************************************************************* - + (in-package #:hyperobject) ;; Main class @@ -47,10 +47,13 @@ ;;; The remainder of these fields are calculated one time ;;; in finalize-inheritence. - + (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 @@ -66,7 +69,7 @@ :documentation "The default view for a class") (documementation :initform nil :initarg :documentation :documentation "Documentation string for hyperclass.") - + ;; SQL commands (create-table-cmd :initform nil :reader create-table-cmd) (create-indices-cmds :initform nil :reader create-index-cmds) @@ -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 @@ -126,29 +134,29 @@ 'compute-effective-slot-definition))) 3) (pushnew :ho-normal-cesd cl:*features*)) - + (when (>= (length (generic-function-lambda-list (ensure-generic-function 'direct-slot-definition-class))) 3) (pushnew :ho-normal-dsdc cl:*features*)) - + (when (>= (length (generic-function-lambda-list (ensure-generic-function 'effective-slot-definition-class))) 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) +(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) @@ -175,7 +183,7 @@ #-lispworks (declare (ignore slot-name)) ) - + (dolist (option *class-options*) (eval `(process-class-option ,option))) (dolist (option *slot-options*) @@ -233,6 +241,22 @@ (t t))) +(defmethod initialize-instance :around ((obj hyperobject-dsd) &rest initargs) + (do* ((parsed (list obj)) + (name (first initargs) (first initargs)) + (val (second initargs) (second initargs))) + ((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)))) + (setq initargs (cddr initargs)))) + (defmethod compute-effective-slot-definition :around ((cl hyperobject-class) #+ho-normal-cesd name dsds) @@ -243,17 +267,14 @@ esd))) (defun compute-hyperobject-esd (esd dsds) - (let* ((dsd (car dsds)) - (value-type (canonicalize-value-type (slot-value dsd 'value-type)))) - (multiple-value-bind (sql-type sql-length) - (value-type-to-sql-type value-type) + (let* ((dsd (car dsds))) + (multiple-value-bind (sql-type sql-length) + (value-type-to-sql-type (dsd-value-type dsd)) (setf (esd-sql-type esd) sql-type) (setf (esd-sql-length esd) sql-length)) - (setf (slot-value esd 'type) (value-type-to-lisp-type value-type)) - (setf (esd-value-type esd) value-type) (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) @@ -263,11 +284,12 @@ (aif (dsd-sql-name dsd) it (lisp-name-to-sql-name (slot-definition-name dsd)))) - (dolist (name '(print-formatter subobject hyperlink hyperlink-parameters + (dolist (name '(value-type print-formatter subobject hyperlink + 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)) @@ -379,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))))) @@ -391,41 +414,46 @@ 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" (unless (user-name cl) (setf (user-name cl) (format nil "~:(~A~)" (class-name cl)))) - + (setf (user-name-plural cl) (if (and (consp (user-name cl)) (cadr (user-name cl))) (cadr (user-name cl)) @@ -440,7 +468,7 @@ SQL name" (if (listp it) (car it) it)))) - + (unless (sql-name cl) (setf (sql-name cl) (lisp-name-to-sql-name (class-name cl)))) ) @@ -478,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)