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 3505a1bdf754c72113855cebbd510907d3e89cbc..9f66bf289034d23229a4debd35392722dfad11ca 100644 (file)
--- 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 5f698bd69632e9bef3249918cf2f22f3a9fa467a..7ee4ad4bd6adb735cc512451048e2c3825db657e 100644 (file)
--- 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 bc93bd97cdbfdaaf5147da987a7d214f6d5f99d8..a90064ad5197f0fa1a4919a8999c2fb21684e1e5 100644 (file)
--- 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