r5304: *** empty log message ***

diff --git a/base-class.lisp b/base-class.lisp
index 9682f3d5438b67fb4e009fa7c30bfb526dfbec90..ad7920fbcbf11e69ebff69401e8826490ce36619 100644 (file)
--- a/base-class.lisp
+++ b/base-class.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;

-;;;; $Id: base-class.lisp,v 1.10 2003/06/06 21:59:29 kevin Exp $
+;;;; $Id: base-class.lisp,v 1.11 2003/07/14 04:10:02 kevin Exp $

 ;;;;
 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
 ;;;;
 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************


@@ -22,6 +22,6 @@
 
 (defmethod print-object ((obj hyperobject) (s stream))
   (print-unreadable-object (obj s :type t :identity nil)
 
 (defmethod print-object ((obj hyperobject) (s stream))
   (print-unreadable-object (obj s :type t :identity nil)

-    (funcall (obj-data-printer (get-category-view obj :compact-text))
+    (funcall (obj-data-printer (get-view-id obj :compact-text))

             obj s nil)))
 
             obj s nil)))
 

diff --git a/mop.lisp b/mop.lisp
index 4ea60683b33184e8e93e2d66b54380639512baf1..e42ee8bfbc991b33ceca85ea3eccd4015a405c54 100644 (file)
--- a/mop.lisp
+++ b/mop.lisp
@@ -11,7 +11,7 @@
 ;;;; in Text, HTML, and XML formats. This includes hyperlinking\r
 ;;;; capability and sub-objects.\r
 ;;;;\r
 ;;;; in Text, HTML, and XML formats. This includes hyperlinking\r
 ;;;; capability and sub-objects.\r
 ;;;;\r

-;;;; $Id: mop.lisp,v 1.83 2003/07/11 18:02:41 kevin Exp $\r
+;;;; $Id: mop.lisp,v 1.84 2003/07/14 04:10:02 kevin Exp $\r

 ;;;;\r
 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg\r
 ;;;; *************************************************************************\r
 ;;;;\r
 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg\r
 ;;;; *************************************************************************\r


@@ -78,12 +78,14 @@
   (:documentation "Metaclass for Markup Language classes."))\r
 \r
 (defclass subobject ()\r
   (:documentation "Metaclass for Markup Language classes."))\r
 \r
 (defclass subobject ()\r

-  ((name-class :type symbol :initform nil :initarg :name-class :reader name-class)\r
-   (name-slot :type symbol :initform nil :initarg :name-slot :reader name-slot)\r
-   (lookup :type (or function symbol) :initform nil :initarg :lookup :reader lookup)\r
-   (lookup-keys :type list :initform nil :initarg :lookup-keys\r
-               :reader lookup-keys))\r
-  (:documentation "Contains subobject information"))\r
+  ((name-class :type symbol :initarg :name-class :reader name-class)\r
+   (name-slot :type symbol :initarg :name-slot :reader name-slot)\r
+   (subobj-class :type symbol :initarg :subobj-class :reader subobj-class)\r
+   (lookup :type (or function symbol) :initarg :lookup :reader lookup)\r
+   (lookup-keys :type list :initarg :lookup-keys :reader lookup-keys))\r
+  (:documentation "subobject information")\r
+  (:default-initargs :name-class nil :name-slot nil :subobj-class nil\r
+                    :lookup nil :lookup-keys nil))\r

 \r
 \r
 (defmethod print-object ((obj subobject) (s stream))\r
 \r
 \r
 (defmethod print-object ((obj subobject) (s stream))\r


@@ -344,89 +346,37 @@ SQL name"
 \r
 ;;;; Class initialization function\r
 \r
 \r
 ;;;; Class initialization function\r
 \r

-;; defines a slot-unbound method for class and slot-name, fills\r
-;; the slot by calling reader function with the slot values of\r
-;; the instance's reader-keys\r
-(defmacro def-lazy-reader (class slot-name reader &rest reader-keys)\r
-  (let* ((the-slot-name (gensym))\r
-        (the-class (gensym))\r
-        (the-instance (gensym))\r
-        (keys '()))\r
-    (dolist (key reader-keys)\r
-      (push (list 'slot-value the-instance (list 'quote key)) keys))\r
-    (setq keys (nreverse keys))\r
-    `(defmethod slot-unbound (,the-class (,the-instance ,class)\r
-                             (,the-slot-name (eql ',slot-name)))\r
-      (declare (ignore ,the-class))\r
-      (setf (slot-value ,the-instance ,the-slot-name) (,reader ,@keys)))))\r
-\r
-\r
-#+lispworks\r
-(defun intern-eql-specializer (slot)\r
-  `(eql ,slot))\r
-\r
-#+(or sbcl cmu lispworks)\r
-(defun ensure-lazy-reader (class-name slot-name reader &rest reader-keys)\r
-  (let ((keys nil)\r
-       (gf (ensure-generic-function 'slot-unbound)))\r
-    (dolist (key reader-keys)\r
-      (push (list 'slot-value 'the-instance (list 'quote key)) keys))\r
-    (setq keys (nreverse keys))\r
-    (multiple-value-bind (method-lambda init-args-values)\r
-       (make-method-lambda\r
-        gf\r
-        (class-prototype (generic-function-method-class gf))\r
-        #-lispworks\r
-        `(lambda (the-class the-instance the-slot-name)\r
-          (declare (ignore the-class))\r
-          (setf (slot-value the-instance the-slot-name) (,reader ,@keys)))\r
-        #+lispworks\r
-        '(the-class the-instance the-slot-name)\r
-        #+lispworks\r
-        nil\r
-        #+lispworks\r
-        `(setf (slot-value the-instance the-slot-name) (,reader ,@keys))\r
-        nil)\r
-      (add-method gf\r
-                 (apply\r
-                  #'make-instance (generic-function-method-class gf)\r
-                  ':specializers (list (class-of (find-class class-name))\r
-                                       (find-class class-name)\r
-                                       (intern-eql-specializer slot-name))\r
-                  ':lambda-list '(the-class the-instance the-slot-name)\r
-                  ':function (compile nil method-lambda)\r
-                  init-args-values)))))\r
-\r
-#+(or allegro scl openmcl)\r
-(progn\r
-  ;; One entry for each class with lazy readers defined.  The value is a plist mapping\r
-  ;; slot-name to a lazy reader, each of which is a list of a function and slot-names.\r
-  (defvar *lazy-readers* (make-hash-table))\r
+;; One entry for each class with lazy readers defined.  The value is a plist mapping\r
+;; slot-name to a lazy reader, each of which is a list of a function and slot-names.\r
+(defvar *lazy-readers* (make-hash-table))\r

 \r
 (defmethod slot-unbound :around ((class hyperobject-class) instance slot-name)\r
   (let ((lazy-reader (loop for super in (class-precedence-list class)\r
 \r
 (defmethod slot-unbound :around ((class hyperobject-class) instance slot-name)\r
   (let ((lazy-reader (loop for super in (class-precedence-list class)\r

-                          as lazy-reader = (getf (gethash super *lazy-readers*) slot-name)\r
-                          when lazy-reader return it)))\r
+                        as lazy-reader = (getf (gethash super *lazy-readers*) slot-name)\r
+                        when lazy-reader return it)))\r

     (if lazy-reader\r
        (setf (slot-value instance slot-name)\r
     (if lazy-reader\r
        (setf (slot-value instance slot-name)\r

-             (apply (car lazy-reader)\r
-                    (loop for arg-slot-name in (cdr lazy-reader)\r
-                          collect (slot-value instance arg-slot-name))))\r
-       ;; No lazy reader -- defer to regular slot-unbound handling.\r
-       (call-next-method))))\r
-\r
-  ;; The reader is a function and the reader-keys are slot names.  The slot is lazily set to\r
-  ;; the result of applying the function to the slot-values of those slots, and that value\r
-  ;; is also returned.\r
-  (defun ensure-lazy-reader (class-name slot-name reader &rest reader-keys)\r
-    (setf (getf (gethash (find-class class-name) *lazy-readers*) slot-name)\r
-         (list* reader (copy-list reader-keys))))\r
-\r
-  (defun remove-lazy-reader (class-name slot-name)\r
-    (setf (getf (gethash (find-class class-name) *lazy-readers*) slot-name)\r
-         nil))\r
-  \r
-  ) ;; #+(or allegro sc openmcll)\r
+         (if (atom lazy-reader)\r
+             (make-instance lazy-reader)\r
+           (apply (car lazy-reader)\r
+                  (loop for arg-slot-name in (cdr lazy-reader)\r
+                      collect (slot-value instance arg-slot-name)))))\r
+      ;; No lazy reader -- defer to regular slot-unbound handling.\r
+      (call-next-method))))\r
+\r
+;; The reader is a function and the reader-keys are slot names.  The slot is lazily set to\r
+;; the result of applying the function to the slot-values of those slots, and that value\r
+;; is also returned.\r
+(defun ensure-lazy-reader (class-name slot-name subobj-class reader \r
+                          &rest reader-keys)\r
+  (setf (getf (gethash (find-class class-name) *lazy-readers*) slot-name)\r
+    (aif subobj-class\r
+        it\r
+        (list* reader (copy-list reader-keys)))))\r
+\r
+(defun remove-lazy-reader (class-name slot-name)\r
+  (setf (getf (gethash (find-class class-name) *lazy-readers*) slot-name)\r
+    nil))\r

 \r
 \r
 (defun finalize-subobjects (cl)\r
 \r
 \r
 (defun finalize-subobjects (cl)\r


@@ -440,30 +390,24 @@ SQL name"
                    (make-instance 'subobject\r
                                   :name-class (class-name cl)\r
                                   :name-slot (slot-definition-name slot)\r
                    (make-instance 'subobject\r
                                   :name-class (class-name cl)\r
                                   :name-slot (slot-definition-name slot)\r

-                                  :lookup (if (atom subobj-def)\r
-                                              subobj-def\r
-                                              (car subobj-def))\r
-                                  :lookup-keys (if (atom subobj-def)\r
-                                                   nil\r
-                                                   (cdr subobj-def)))))\r
+                                  :subobj-class (when (atom subobj-def)\r
+                                                  subobj-def)\r
+                                  :lookup (when (listp subobj-def)\r
+                                            (car subobj-def))\r
+                                  :lookup-keys (when (listp subobj-def)\r
+                                                 (cdr subobj-def)))))\r

               (unless (eq (lookup subobject) t)\r
               (unless (eq (lookup subobject) t)\r

-                #+ignore ;; #-(or sbcl cmu lispworks)\r
-                (eval\r
-                 `(hyperobject::def-lazy-reader ,(name-class subobject)\r
-                   ,(name-slot subobject) ,(lookup subobject)\r
-                   ,@(lookup-keys subobject)))\r
-                #+(or sbcl cmu lispworks allegro scl openmcl)\r

                 (apply #'ensure-lazy-reader \r
                        (name-class subobject) (name-slot subobject)\r
                 (apply #'ensure-lazy-reader \r
                        (name-class subobject) (name-slot subobject)\r

-                       (lookup subobject) (lookup-keys subobject)))\r
-              (push subobject subobjects))))\r
+                       (subobj-class subobject)\r
+                       (lookup subobject) (lookup-keys subobject))\r
+                (push subobject subobjects)))))\r

          ;; sbcl/cmu reverse class-slots compared to the defclass form\r
          ;; so re-reverse on cmu/sbcl\r
          #+(or cmu sbcl) subobjects\r
          #-(or cmu sbcl) (nreverse subobjects)\r
          )))\r
 \r
          ;; sbcl/cmu reverse class-slots compared to the defclass form\r
          ;; so re-reverse on cmu/sbcl\r
          #+(or cmu sbcl) subobjects\r
          #-(or cmu sbcl) (nreverse subobjects)\r
          )))\r
 \r

-\r

 (defun finalize-class-slots (cl)\r
   "Make sure all class slots have an expected value"\r
   (unless (user-name cl)\r
 (defun finalize-class-slots (cl)\r
   "Make sure all class slots have an expected value"\r
   (unless (user-name cl)\r


@@ -477,13 +421,12 @@ SQL name"
                                   (user-name cl))\r
                    2)))\r
 \r
                                   (user-name cl))\r
                    2)))\r
 \r

-  (dolist (name '(user-name description version guid sql-name\r
-                 direct-views direct-rules))\r
+  (dolist (name '(user-name description version guid sql-name))\r

     (awhen (slot-value cl name)\r
           (setf (slot-value cl name)\r
     (awhen (slot-value cl name)\r
           (setf (slot-value cl name)\r

-                (etypecase (slot-value cl name)\r
-                  (cons (car it))\r
-                  ((or string symbol) it)))))\r
+            (if (listp it)\r
+                (car it)\r
+              it))))\r

   \r
   (unless (sql-name cl)\r
     (setf (sql-name cl) (lisp-name-to-sql-name (class-name cl))))\r
   \r
   (unless (sql-name cl)\r
     (setf (sql-name cl) (lisp-name-to-sql-name (class-name cl))))\r

diff --git a/package.lisp b/package.lisp
index 1f001443d3f9ded10bf3f6b0ca29862e141cacc8..a52e65eebc74665d559e1610b4435b8935c416c7 100644 (file)
--- a/package.lisp
+++ b/package.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg\r
 ;;;; Date Started:  Apr 2000\r
 ;;;;\r
 ;;;; Programmer:    Kevin M. Rosenberg\r
 ;;;; Date Started:  Apr 2000\r
 ;;;;\r

-;;;; $Id: package.lisp,v 1.50 2003/06/24 08:32:32 kevin Exp $\r
+;;;; $Id: package.lisp,v 1.51 2003/07/14 04:10:02 kevin Exp $\r

 ;;;;\r
 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg\r
 ;;;; *************************************************************************\r
 ;;;;\r
 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg\r
 ;;;; *************************************************************************\r


@@ -44,6 +44,7 @@
    #:hyperobject-class-user-name\r
    #:load-all-subobjects\r
    #:view\r
    #:hyperobject-class-user-name\r
    #:load-all-subobjects\r
    #:view\r

+   #:view-subobjects\r

    #:fmt-comma-integer\r
    #:processed-queued-definitions\r
    #:all-subobjects\r
    #:fmt-comma-integer\r
    #:processed-queued-definitions\r
    #:all-subobjects\r

diff --git a/rules.lisp b/rules.lisp
index 336c86f2fa3e02bbc39c1dc14ad0bf4bb001dc52..3807676c83550d4555190d84e681f9dd18ce9ef3 100644 (file)
--- a/rules.lisp
+++ b/rules.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;

-;;;; $Id: rules.lisp,v 1.47 2003/06/20 08:35:21 kevin Exp $
+;;;; $Id: rules.lisp,v 1.48 2003/07/14 04:10:02 kevin Exp $

 ;;;;
 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
 ;;;;
 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************


@@ -36,21 +36,18 @@
                     ,@source-code)))))))
   
 (defun finalize-rules (cl)
                     ,@source-code)))))))
   
 (defun finalize-rules (cl)

-  (let* ((direct-rules (direct-rules cl))
-        (rules '()))
-    (dolist (rule direct-rules)
-      (destructuring-bind (name (&key dependants volatile) &rest source-code)
-         rule
-       (setf dependants (mklist dependants)
-             volatile (mklist volatile))
-       (push
-        (make-instance 'rule :name name :dependants dependants
-                       :volatile volatile :source-code source-code
-                       :access-slots (appendnew dependants volatile)
-                       :func (compile-rule
-                              source-code dependants volatile cl))
-        rules)))
-    (setf (rules cl) (nreverse rules))))
+  (setf (rules cl)
+    (loop for rule in (direct-rules cl)
+       collect 
+         (destructuring-bind (name (&key dependants volatile) &rest source-code)
+             rule
+           (setf dependants (mklist dependants)
+                 volatile (mklist volatile))
+           (make-instance 'rule :name name :dependants dependants
+                          :volatile volatile :source-code source-code
+                          :access-slots (appendnew dependants volatile)
+                          :func (compile-rule
+                                 source-code dependants volatile cl))))))

 
 
 (defun fire-class-rules (cl obj slot)
 
 
 (defun fire-class-rules (cl obj slot)

diff --git a/views.lisp b/views.lisp
index 6c102965ef1cbfef5b86a54fe61c4777d48c93bc..cd4f69bd657cc3cd2907173be2356c1a66429c95 100644 (file)
--- a/views.lisp
+++ b/views.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;

-;;;; $Id: views.lisp,v 1.60 2003/07/11 18:02:41 kevin Exp $
+;;;; $Id: views.lisp,v 1.61 2003/07/14 04:10:02 kevin Exp $

 ;;;;
 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
 ;;;;
 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************


@@ -21,10 +21,8 @@
                 :documentation "Class of object to be viewed.")
    (slots :initform nil :initarg :slots :accessor slots
          :documentation "List of effective slots for object to be viewed.")
                 :documentation "Class of object to be viewed.")
    (slots :initform nil :initarg :slots :accessor slots
          :documentation "List of effective slots for object to be viewed.")

-   (name :initform nil :initarg :name :accessor name
-        :documentation "Name for this view.")
-   (category :initform nil :initarg :category :accessor category
-            :documentation "Category for view. Helpful when want to find a view corresponding to a particular category.")
+   (id :initform nil :initarg :id :accessor id
+       :documentation "id for this view.")

    (source-code :initform nil :initarg :source-code :accessor source-code 
                :documentation "Source code for generating view.")
    (country-language :initform :en :initarg :country-language
    (source-code :initform nil :initarg :source-code :accessor source-code 
                :documentation "Source code for generating view.")
    (country-language :initform :en :initarg :country-language


@@ -95,21 +93,42 @@
   (:documentation "View class for a hyperobject"))
 
 
   (:documentation "View class for a hyperobject"))
 
 

-(defun get-category-view (obj category &optional slots)
+(defun get-default-view-id (obj-cl)
+  (aif (views obj-cl)
+      (id (car it))
+      :compact-text))
+
+(defun find-view-id-in-class-precedence (obj-cl vid)
+  "Looks for a view in class and parent classes"
+  (when (typep obj-cl 'hyperobject-class)
+    (aif (find vid (views obj-cl) :key #'id :test #'eq)
+        it
+        (let (cpl)
+          (handler-case
+              (setq cpl (class-precedence-list obj-cl))
+            (error (e)
+              (declare (ignore e))
+              ;; can't get cpl unless class finalized
+              (make-instance (class-name obj-cl))
+              (setq cpl (class-precedence-list obj-cl))))
+          (find-view-id-in-class-precedence (second cpl) vid)))))
+                                           
+  
+(defun get-view-id (obj vid &optional slots)

   "Find or make a category view for an object"
   "Find or make a category view for an object"

-  (let ((obj-class (class-of obj)))
-    (if (null category)
-       (default-view obj-class)
-       (aif (find category (views obj-class) :key #'category)
-            it
-            (let ((view
-                   (make-instance 'object-view
-                     :object-class (find-class obj-class)
-                     :category category
-                     :slots slots)))
-              (push view (views obj-class))
-              view)))))
-                            
+  (let ((obj-cl (class-of obj)))
+    (unless vid
+      (setq vid (get-default-view-id obj-cl)))
+    (aif (find-view-id-in-class-precedence obj-cl vid)
+        it
+        (let ((view
+               (make-instance 'object-view
+                 :object-class (class-name obj-cl)
+                 :id vid
+                 :slots slots)))
+          (push view (views obj-cl))
+          view))))
+

 ;;;; *************************************************************************
 ;;;;  Metaclass Intialization
 ;;;; *************************************************************************
 ;;;; *************************************************************************
 ;;;;  Metaclass Intialization
 ;;;; *************************************************************************


@@ -119,15 +138,9 @@
   (unless (default-print-slots cl)
     (setf (default-print-slots cl)
          (mapcar #'slot-definition-name (class-slots cl))))
   (unless (default-print-slots cl)
     (setf (default-print-slots cl)
          (mapcar #'slot-definition-name (class-slots cl))))

-  (let ((views '()))
-    (dolist (view-def (direct-views cl))
-      (push (make-object-view cl view-def) views))
-    (setf (views cl) (nreverse views)))
-  (cond
-    ((views cl)
-     (setf (default-view cl) (car (views cl))))
-    (t
-     (setf (default-view cl) (make-object-view cl :default)))))
+  (setf (views cl)
+    (loop for view-def in (direct-views cl)
+       collect (make-object-view cl view-def))))

 
 (defun make-object-view (cl view-def)
   "Make an object view from a definition. Do nothing if a class is passed so that reinitialization will be a no-op"
 
 (defun make-object-view (cl view-def)
   "Make an object view from a definition. Do nothing if a class is passed so that reinitialization will be a no-op"


@@ -135,22 +148,21 @@
     ((typep view-def 'object-view)
      view-def)
     ((eq view-def :default)
     ((typep view-def 'object-view)
      view-def)
     ((eq view-def :default)

-     (let* ((name (class-name cl))
-           (view (make-instance 'object-view :name "automatic"
-                                :object-class (class-name cl)
-                                :category :compact-text)))
-       view))
+     (make-instance 'object-view 
+       :object-class (class-name cl)
+       :id :compact-text))

     ((consp view-def)
      (make-instance 'object-view
                    :object-class (class-name cl)
     ((consp view-def)
      (make-instance 'object-view
                    :object-class (class-name cl)

-                   :name (getf view-def :name)
+                   :id (getf view-def :id)
+                   :slots (getf view-def :slots)

                    :source-code (getf view-def :source-code)))
     (t
      (error "Invalid parameter to make-object-view: ~S" view-def))))
 
 (defmethod initialize-instance :after ((self object-view)
                                       &rest initargs 
                    :source-code (getf view-def :source-code)))
     (t
      (error "Invalid parameter to make-object-view: ~S" view-def))))
 
 (defmethod initialize-instance :after ((self object-view)
                                       &rest initargs 

-                                      &key 
+                                      &key

                                       &allow-other-keys)
   (initialize-view self))
   
                                       &allow-other-keys)
   (initialize-view self))
   


@@ -158,21 +170,33 @@
   "Calculate all view slots for a hyperobject class"
   (let ((obj-cl (find-class (object-class view))))
     (cond
   "Calculate all view slots for a hyperobject class"
   (let ((obj-cl (find-class (object-class view))))
     (cond

-     ((category view)
-      (initialize-view-by-category obj-cl view))

      ((source-code view)
       (initialize-view-by-source-code view))
      ((source-code view)
       (initialize-view-by-source-code view))

+     ((id view)
+      (initialize-view-by-id obj-cl view))

      (t
      (t

-      (setf (category view) :compact-text)
-      (initialize-view-by-category obj-cl view)))))
+      (setf (id view) :compact-text)
+      (initialize-view-by-id obj-cl view)))))
+
+

 
 (defun initialize-view-by-source-code (view)
   "Initialize a view based upon a source code"
   (let* ((source-code (source-code view))
 
 (defun initialize-view-by-source-code (view)
   "Initialize a view based upon a source code"
   (let* ((source-code (source-code view))

-        (*package* (symbol-package (object-class view)))
-        (printer `(lambda (x s)
-                    (declare (ignorable x s))
-                    ,@source-code)))
+        (printer `(lambda
+                      (,(intern (symbol-name '#:self) 
+                                (symbol-package (object-class view)))
+                       ,(intern (symbol-name '#:s) 
+                                (symbol-package (object-class view))))
+                    (declare (ignorable 
+                              ,(intern (symbol-name '#:self) 
+                                       (symbol-package (object-class view)))
+                              ,(intern (symbol-name '#:s) 
+                                       (symbol-package (object-class view)))))
+                    (with-slots ,(slots view) 
+                        ,(intern (symbol-name '#:self) 
+                                 (symbol-package (object-class view)))
+                      ,@source-code))))

     (setf (printer view) 
       (compile nil (eval printer)))))
 
     (setf (printer view) 
       (compile nil (eval printer)))))
 


@@ -247,7 +271,7 @@
   (vector-push-extend '(write-string "</span> " s) print-func)
   (ppfc-html-link name type formatter cdata nlink print-func))
 
   (vector-push-extend '(write-string "</span> " s) print-func)
   (ppfc-html-link name type formatter cdata nlink print-func))
 

-(defun push-print-fun-code (category slot nlink print-func)
+(defun push-print-fun-code (vid slot nlink print-func)

   (let* ((formatter (esd-print-formatter slot))
         (name (slot-definition-name slot))
         (user-name (esd-user-name slot))
   (let* ((formatter (esd-print-formatter slot))
         (name (slot-definition-name slot))
         (user-name (esd-user-name slot))


@@ -255,7 +279,7 @@
         (xml-tag (escape-xml-string user-name))
         (type (slot-value slot 'type))
         (cdata (not (null
         (xml-tag (escape-xml-string user-name))
         (type (slot-value slot 'type))
         (cdata (not (null

-                     (and (in category :xml :xhtml :xml-link :xhtml-link
+                     (and (in vid :xml :xhtml :xml-link :xhtml-link

                               :xml-labels :ie-xml-labels
                               :xhtml-link-labels :xml-link-labels :ie-xml-link
                               :ie-xml-link-labels)
                               :xml-labels :ie-xml-labels
                               :xhtml-link-labels :xml-link-labels :ie-xml-link
                               :ie-xml-link-labels)


@@ -263,7 +287,7 @@
                               (lisp-type-is-a-string type))))))
         (hyperlink (esd-hyperlink slot)))
     
                               (lisp-type-is-a-string type))))))
         (hyperlink (esd-hyperlink slot)))
     

-    (case category
+    (case vid

       (:compact-text
        (vector-push-extend
        `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func))
       (:compact-text
        (vector-push-extend
        `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func))


@@ -310,20 +334,25 @@
 
 
 (defun view-has-links-p (view)
 
 
 (defun view-has-links-p (view)

-  (in (category view) :html-link :xhtml-link :xml-link :ie-xml-link
+  (in (id view) :html-link :xhtml-link :xml-link :ie-xml-link

       :html-link-labels :xhtml-link-labels :xml-link-labels
       :ie-xml-link-labels))
 
       :html-link-labels :xhtml-link-labels :xml-link-labels
       :ie-xml-link-labels))
 

-(defun initialize-view-by-category (obj-cl view)
-  "Initialize a view based upon a preset category"
-  (unless (in (category view) :compact-text :compact-text-labels
-             :html :html-labels :html-link-labels
-             :xhtml :xhtml-labels :xhtml-link-labels
-             :xhtml-link :html-link
-             :xml :xml-labels :xml-link :ie-xml-link
-             :xml-link-labels :ie-xml-link-labels
-             :display-table :edit-table)
-    (error "Unknown view category ~A" (category view)))
+(defun creatable-view-id-p (obj-cl vid)
+  "Returns T if a view id can be created for this class"
+  (declare (ignore obj-cl))
+  (in vid :compact-text :compact-text-labels
+      :html :html-labels :html-link-labels
+      :xhtml :xhtml-labels :xhtml-link-labels
+      :xhtml-link :html-link
+      :xml :xml-labels :xml-link :ie-xml-link
+      :xml-link-labels :ie-xml-link-labels
+      :display-table :edit-table))
+
+(defun initialize-view-by-id (obj-cl view)
+  "Initialize a view based upon a preset vid"
+  (unless (creatable-view-id-p obj-cl (id view))
+    (error "Unable to automatically create view id ~A" (id view)))

   
   (unless (slots view) (setf (slots view) (default-print-slots obj-cl)))
 
   
   (unless (slots view) (setf (slots view) (default-print-slots obj-cl)))
 


@@ -338,7 +367,7 @@
       (unless slot
        (error "Slot ~A is not found in class ~S" slot-name obj-cl))
       
       (unless slot
        (error "Slot ~A is not found in class ~S" slot-name obj-cl))
       

-      (push-print-fun-code (category view) slot (length links) print-func)
+      (push-print-fun-code (id view) slot (length links) print-func)

       (when (> (length slots) 1)
        (vector-push-extend '(write-char #\space s) print-func))
 
       (when (> (length slots) 1)
        (vector-push-extend '(write-char #\space s) print-func))
 


@@ -354,11 +383,11 @@
     
     (setf (link-slots view) (nreverse links)))
 
     
     (setf (link-slots view) (nreverse links)))
 

-  (finalize-view-by-category view)
+  (finalize-view-by-id view)

   view)
 
   view)
 

-(defun finalize-view-by-category (view)
-  (case (category view)
+(defun finalize-view-by-id (view)
+  (case (id view)

     ((or :compact-text :compact-text-labels)
      (initialize-text-view view))
     ((or :html :html-labels)
     ((or :compact-text :compact-text-labels)
      (initialize-text-view view))
     ((or :html :html-labels)


@@ -390,12 +419,6 @@
      (setf (link-ampersand view) "&amp;"))))
 
 
      (setf (link-ampersand view) "&amp;"))))
 
 

-(defun make-std-object-slots-view (class-name slots)
-  #'(lambda (obj strm)
-      )
-    
-  )
-

 ;;;; *************************************************************************
 ;;;;  View Data Format Section
 ;;;; *************************************************************************
 ;;;; *************************************************************************
 ;;;;  View Data Format Section
 ;;;; *************************************************************************


@@ -497,16 +520,17 @@
   (write-char #\newline strm))
 
 (defun initialize-xml-view (view)
   (write-char #\newline strm))
 
 (defun initialize-xml-view (view)

-  (setf (file-start-str view) "") ; (std-xml-header)
-  (setf (list-start-indent view)  t)
-  (setf (list-start-printer view) #'xmlformat-list-start-func)
-  (setf (list-end-indent view) t)
-  (setf (list-end-printer view) #'xmlformat-list-end-func)
-  (setf (obj-start-printer view) (format nil "<~(~a~)>" (object-class-name view)))
-  (setf (obj-start-indent view) t)
-  (setf (subobj-end-printer view) (format nil "</~(~a~)>~%" (object-class-name view)))
-  (setf (subobj-end-indent view) nil)
-  (setf (obj-data-indent view) nil))
+  (let ((name (string-downcase (symbol-name (object-class view)))))
+    (setf (file-start-str view) "")    ; (std-xml-header)
+    (setf (list-start-indent view)  t)
+    (setf (list-start-printer view) #'xmlformat-list-start-func)
+    (setf (list-end-indent view) t)
+    (setf (list-end-printer view) #'xmlformat-list-end-func)
+    (setf (obj-start-printer view) (format nil "<~(~a~)>" name))
+    (setf (obj-start-indent view) t)
+    (setf (subobj-end-printer view) (format nil "</~(~a~)>~%" name))
+    (setf (subobj-end-indent view) nil)
+    (setf (obj-data-indent view) nil)))

 
 
 ;;; File Start and Ends
 
 
 ;;; File Start and Ends


@@ -656,18 +680,18 @@
             (load-all-subobjects it))))
   objs)
 
             (load-all-subobjects it))))
   objs)
 

-(defun view-subobjects (obj strm &optional category (indent 0) filter
+(defun view-subobjects (obj strm &optional vid (indent 0) filter

                        subobjects refvars link-printer)
   (when (hyperobject-class-subobjects obj)
     (dolist (subobj (hyperobject-class-subobjects obj))
       (aif (slot-value obj (name-slot subobj))
           (view-hyperobject
                        subobjects refvars link-printer)
   (when (hyperobject-class-subobjects obj)
     (dolist (subobj (hyperobject-class-subobjects obj))
       (aif (slot-value obj (name-slot subobj))
           (view-hyperobject

-           it (get-category-view (car (mklist it)) category)
-           category strm (1+ indent) filter subobjects refvars
+           it (get-view-id (car (mklist it)) vid)
+           vid strm (1+ indent) filter subobjects refvars

            link-printer)))))
 
          
            link-printer)))))
 
          

-(defun view-hyperobject (objs view strm &optional category (indent 0) filter
+(defun view-hyperobject (objs view strm &optional vid (indent 0) filter

                         subobjects refvars link-printer)
   "Display a single or list of hyperobject-class instances and their subobjects"
   (let-when (objlist (mklist objs))
                         subobjects refvars link-printer)
   "Display a single or list of hyperobject-class instances and their subobjects"
   (let-when (objlist (mklist objs))


@@ -688,24 +712,22 @@
          (fmt-obj-end obj view strm indent)
          (when subobjects 
            (fmt-subobj-start obj view strm indent)
          (fmt-obj-end obj view strm indent)
          (when subobjects 
            (fmt-subobj-start obj view strm indent)

-           (view-subobjects obj category strm indent filter subobjects
+           (view-subobjects obj vid strm indent filter subobjects

                             refvars link-printer)
            (fmt-subobj-end obj view strm indent))))
       (fmt-list-end (car objlist) view strm indent nobjs)))
   objs)
 
 
                             refvars link-printer)
            (fmt-subobj-end obj view strm indent))))
       (fmt-list-end (car objlist) view strm indent nobjs)))
   objs)
 
 

-(defun view (objs &key (stream *standard-output*) category view
+(defun view (objs &key (stream *standard-output*) vid view

             filter subobjects refvars file-wrapper link-printer)
   "EXPORTED Function: prints hyperobject-class objects. Calls view-hyperobject"
   (let-when (objlist (mklist objs))
             filter subobjects refvars file-wrapper link-printer)
   "EXPORTED Function: prints hyperobject-class objects. Calls view-hyperobject"
   (let-when (objlist (mklist objs))

-    (when category
-      (setq view (get-category-view (car objlist) category)))

     (unless view
     (unless view

-      (setq view (default-view (class-of (car objlist)))))
+      (setq view (get-view-id (car objlist) vid)))

     (when file-wrapper
       (fmt-file-start view stream))
     (when file-wrapper
       (fmt-file-start view stream))

-    (view-hyperobject objlist view stream category 0 filter subobjects refvars
+    (view-hyperobject objlist view stream vid 0 filter subobjects refvars

                      link-printer)
     (when file-wrapper
       (fmt-file-end view stream)))
                      link-printer)
     (when file-wrapper
       (fmt-file-end view stream)))