From: Kevin M. Rosenberg Date: Thu, 4 Jan 2007 18:12:57 +0000 (+0000) Subject: r11447: major reworking of mop internals to support OpenMCL. X-Git-Tag: debian-2.11.0-2~6 X-Git-Url: http://git.kpe.io/?p=hyperobject.git;a=commitdiff_plain;h=4daae1a3c91e61b3df8fd87d419391b57e2914df r11447: major reworking of mop internals to support OpenMCL. Now, rather than doing all computation at the time of finalize-inheritance, certain slot processing is done via shared-initialize so that slots (like user-name) always have a valid value. Otherwise, OpenMCL would complain slot was invalid at time of instance creation, before finalize inheritance. --- diff --git a/mop.lisp b/mop.lisp index 3505a1b..9f66bf2 100644 --- a/mop.lisp +++ b/mop.lisp @@ -62,7 +62,7 @@ (direct-views :type list :initform nil :initarg :direct-views :accessor direct-views :documentation "List of views") - (class-id :type integer :initform nil + (class-id :type integer :initform (+ (* 1000000 (get-universal-time)) (random 1000000)) :accessor class-id :documentation "Unique ID for the class") (default-view :initform nil :initarg :default-view :accessor default-view @@ -125,8 +125,100 @@ (defmethod validate-superclass ((class hyperobject-class) (superclass standard-class)) t) + +(declaim (inline delistify)) +(defun delistify (list) + "Some MOPs, like openmcl 0.14.2, cons attribute values in a list." + (if (listp list) + (car list) + list)) + +(defun remove-keyword-arg (arglist akey) + (let ((mylist arglist) + (newlist ())) + (labels ((pop-arg (alist) + (let ((arg (pop alist)) + (val (pop alist))) + (unless (equal arg akey) + (setf newlist (append (list arg val) newlist))) + (when alist (pop-arg alist))))) + (pop-arg mylist)) + newlist)) + +(defun remove-keyword-args (arglist akeys) + (let ((mylist arglist) + (newlist ())) + (labels ((pop-arg (alist) + (let ((arg (pop alist)) + (val (pop alist))) + (unless (find arg akeys) + (setf newlist (append (list arg val) newlist))) + (when alist (pop-arg alist))))) + (pop-arg mylist)) + newlist)) + + +(defmethod shared-initialize :around ((class hyperobject-class) slot-names + &rest initargs + &key direct-superclasses + user-name sql-name name description + &allow-other-keys) + ;(format t "ii ~S ~S ~S ~S ~S~%" initargs base-table direct-superclasses user-name sql-name) + (let ((root-class (find-class 'hyperobject nil)) + (vmc 'hyperobject-class) + user-name-plural user-name-str sql-name-str) + ;; when does CLSQL pass :qualifier to initialize instance? + (setq user-name-str + (if user-name + (delistify user-name) + (and name (format nil "~:(~A~)" name)))) + + (setq sql-name-str + (if sql-name + (delistify sql-name) + (and name (lisp-name-to-sql-name name)))) + + (if sql-name + (delistify sql-name) + (and name (lisp-name-to-sql-name name))) + + (setq description (delistify description)) + + (setq user-name-plural + (if (and (consp user-name) (second user-name)) + (second user-name) + (and user-name-str (format nil "~A~P" user-name-str 2)))) + + (flet ((do-call-next-method (direct-superclasses) + (let ((fn-args (list class slot-names :direct-superclasses direct-superclasses)) + (rm-args '(:direct-superclasses))) + (when user-name-str + (setq fn-args (nconc fn-args (list :user-name user-name-str))) + (push :user-name rm-args)) + (when user-name-plural + (setq fn-args (nconc fn-args (list :user-name-plural user-name-plural))) + (push :user-name-plural rm-args)) + (when sql-name-str + (setq fn-args (nconc fn-args (list :sql-name sql-name-str))) + (push :sql-name rm-args)) + (when description + (setq fn-args (nconc fn-args (list :description description))) + (push :description rm-args)) + (setq fn-args (nconc fn-args (remove-keyword-args initargs rm-args))) + (apply #'call-next-method fn-args)))) + (if root-class + (if (some #'(lambda (super) (typep super vmc)) + direct-superclasses) + (do-call-next-method direct-superclasses) + (do-call-next-method direct-superclasses #+nil (append (list root-class) + direct-superclasses))) + (do-call-next-method direct-superclasses))))) + + (defmethod finalize-inheritance :after ((cl hyperobject-class)) - (init-hyperobject-class cl)) + "Initialize a hyperobject class. Calculates all class slots" + (finalize-subobjects cl) + (finalize-compute-cached cl)) (eval-when (:compile-toplevel :load-toplevel :execute) (when (>= (length (generic-function-lambda-list @@ -241,21 +333,6 @@ (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 @@ -446,32 +523,9 @@ SQL name" (store-lazily-computed-objects cl 'subobjects 'esd-subobject 'subobject)) (defun finalize-compute-cached (cl) - (store-lazily-computed-objects cl 'compute-cached-values + (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)) - (format nil "~A~P" (if (consp (user-name cl)) - (car (user-name cl)) - (user-name cl)) - 2))) - - (dolist (name '(user-name description version guid sql-name)) - (awhen (slot-value cl name) - (setf (slot-value cl name) - (if (listp it) - (car it) - it)))) - - (unless (sql-name cl) - (setf (sql-name cl) (lisp-name-to-sql-name (class-name cl)))) - ) (defun finalize-documentation (cl) "Calculate class documentation slot" @@ -505,16 +559,15 @@ 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) (finalize-rules cl) - (finalize-class-slots cl) (finalize-documentation cl)) + + ;;;; ************************************************************************* ;;;; Metaclass Slot Accessors ;;;; ************************************************************************* diff --git a/tests.lisp b/tests.lisp index 5f698bd..7ee4ad4 100644 --- a/tests.lisp +++ b/tests.lisp @@ -141,12 +141,21 @@ Mary Jackson Thu, 4 May 2000 03:02:01 Style & Grace ") -(deftest :s1 (years-at-address home) +(deftest :cv1 (years-at-address home) 10) -(deftest :s2 (years-at-address office) +(deftest :cv2 (years-at-address office) 5) -(deftest :cv1 (equal (create-time mary) *now*) +(deftest :cv3 (equal (create-time mary) *now*) t) + +(deftest :s1 (slot-value (class-of mary) 'ho::user-name) + "Person") + +(deftest :s2 (slot-value (class-of mary) 'ho::user-name-plural) + "Persons") + +(deftest :s3 (slot-value (class-of home) 'ho::user-name-plural) + "Addresses") diff --git a/views.lisp b/views.lisp index bc93bd9..a90064a 100644 --- a/views.lisp +++ b/views.lisp @@ -65,7 +65,7 @@ (obj-data-printer :type (or function null) :initform nil :initarg :obj-data-printer :accessor obj-data-printer) - (obj-data-print-code :type (or function null) :initform nil + (obj-data-print-code :type (or function list null) :initform nil :initarg :obj-data-print-code :accessor obj-data-print-code) (obj-data-start-printer :type (or function string null) :initform nil