X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=hyperobject.lisp;h=f6ad52c20c617fc41e2b96aa74c0dbe978e6b6ac;hb=a332fc23291a68f46d2e973df7c28ec07a4abcfe;hp=926fde9b7d17847a96f057a9ad0c3a74818ca156;hpb=ec0e06f1c59ea3aa00090010a6d53ea3f712ed1d;p=hyperobject.git

diff --git a/hyperobject.lisp b/hyperobject.lisp
index 926fde9..f6ad52c 100644
--- a/hyperobject.lisp
+++ b/hyperobject.lisp
@@ -11,7 +11,7 @@
 ;;;; in Text, HTML, and XML formats. This includes hyperlinking
 ;;;; capability and sub-objects.
 ;;;;
-;;;; $Id: hyperobject.lisp,v 1.4 2002/11/04 19:19:04 kevin Exp $
+;;;; $Id: hyperobject.lisp,v 1.15 2002/11/25 04:49:22 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
@@ -19,158 +19,263 @@
  
 (in-package :hyperobject)
 
-
 (eval-when (:compile-toplevel :execute)
   (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3))))
 
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (shadowing-import
+   #+allegro
+   `(mop::class-slots mop::slot-definition-name mop:finalize-inheritance
+     mop::standard-direct-slot-definition mop::standard-effective-slot-definition
+     mop:direct-slot-definition-class mop:compute-effective-slot-definition
+     excl::compute-effective-slot-definition-initargs)
+   #+lispworks
+   `(clos:class-slots clos::slot-definition-name clos:finalize-inheritance
+     clos::standard-direct-slot-definition clos::standard-effective-slot-definition
+     clos:direct-slot-definition-class clos:compute-effective-slot-definition
+     clos::compute-effective-slot-definition-initargs)
+   #+sbcl 
+   `(sb-pcl:class-of sb-pcl:class-name sb-pcl:class-slots sb-pcl::standard-class
+     sb-pcl::slot-definition-name sb-pcl:finalize-inheritance
+     sb-pcl::standard-direct-slot-definition
+     sb-pcl::standard-effective-slot-definition sb-pcl::validate-superclass
+     sb-pcl:direct-slot-definition-class sb-pcl:compute-effective-slot-definition
+     sb-pcl::compute-effective-slot-definition-initargs)
+   #+cmu
+   `(pcl:class-of  pcl:class-name pcl:class-slots pcl::standard-class
+     pcl::slot-definition-name pcl:finalize-inheritance
+     pcl::standard-direct-slot-definition pcl::standard-effective-slot-definition
+     pcl::validate-superclass pcl:direct-slot-definition-class
+     pcl:compute-effective-slot-definition
+     pcl::compute-effective-slot-definition-initargs)
+   
+   :hyperobject))
 
-;; Utilities
-
-(defun portable-class-of (obj)
-  #-(or cmu sbcl) (class-of obj)
-  #+sbcl (sb-pcl:class-of obj)
-  #+cmu (pcl:class-of obj))
-
-(defun portable-class-name (obj)
-  #-(or cmu sbcl) (class-name obj)
-  #+sbcl (sb-pcl:class-name obj)
-  #+cmu (pcl:class-name obj))
 
 ;; Main class
 
-(defclass hyperobject-class (#-(or cmu sbcl) standard-class
-		      #+cmu pcl::standard-class
-		      #+sbcl sb-pcl::standard-class)
-  ((title :initarg :title :type string :reader ml-std-title
-	  :documentation 
-"Print Title for class")
-   (fields :initarg :fields :reader ml-std-fields
-	   :documentation
-"List of field lists for printing. Format is 
-   ((fieldname type optional-formatter) ... )")
-   (subobjects-lists 
-    :initarg :subobjects-lists :reader ml-std-subobjects-lists
-    :documentation 
-"List of fields that contain a list of subobjects objects.")
-   (ref-fields 
-    :initarg :ref-fields :type list :reader ml-std-ref-field
-    :documentation 
-    "List of fields that can be referred to by browsers. 
-Format is ((field-name field-lookup-func other-link-params) ...)")
-   
+(defclass hyperobject-class (standard-class)
+  ( ;; slots initialized in defclass
+   (title :initarg :title :type string :initform nil
+	  :documentation "Print Title for class")
+   (print-slots :initarg :print-slots :type list :initform nil
+		:documentation "List of slots to print")
+   (description :initarg :description :initform nil
+		:documentation "Class description")
+
    ;;; The remainder of these fields are calculated one time
    ;;; in finalize-inheritence.
-   (value-func :initform nil :type function :reader ml-std-value-func)
-   (xmlvalue-func :initform nil :type function :reader ml-std-xmlvalue-func)
-   (fmtstr-text :initform nil :type string :reader ml-std-fmtstr-text)
-   (fmtstr-html :initform nil :type string :reader ml-std-fmtstr-html)
-   (fmtstr-xml :initform nil :type string :reader ml-std-fmtstr-xml)
-   (fmtstr-text-labels :initform nil :type string :reader ml-std-fmtstr-text-labels)
-   (fmtstr-html-labels :initform nil :type string :reader ml-std-fmtstr-html-labels)
-   (fmtstr-xml-labels :initform nil :type string :reader ml-std-fmtstr-xml-labels)
-   (fmtstr-html-ref :initform nil :type string :reader ml-std-fmtstr-html-ref)
-   (fmtstr-xml-ref :initform nil :type string :reader ml-std-fmtstr-xml-ref)
-   (fmtstr-html-ref-labels :initform nil :type string :reader ml-std-fmtstr-html-ref-labels)
-   (fmtstr-xml-ref-labels :initform nil :type string :reader ml-std-fmtstr-xml-ref-labels)
+   
+   (subobjects :initform nil :documentation
+	       "List of fields that contain a list of subobjects objects.")
+   (references :type list :initform nil :documentation 
+	       "List of fields that have references")
+   
+   (value-func :initform nil :type function)
+   (xmlvalue-func :initform nil :type function)
+   (fmtstr-text :initform nil :type string)
+   (fmtstr-html :initform nil :type string)
+   (fmtstr-xml :initform nil :type string)
+   (fmtstr-text-labels :initform nil :type string)
+   (fmtstr-html-labels :initform nil :type string)
+   (fmtstr-xml-labels :initform nil :type string)
+   (fmtstr-html-ref :initform nil :type string)
+   (fmtstr-xml-ref :initform nil :type string)
+   (fmtstr-html-ref-labels :initform nil :type string)
+   (fmtstr-xml-ref-labels :initform nil :type string)
    )
-  (:default-initargs :title nil :fields nil :subobjects-lists nil :ref-fields nil)
   (:documentation "Metaclass for Markup Language classes."))
 
+(defclass subobject ()
+  ((name :type symbol :initform nil :initarg :name :reader name)
+   (reader :type function :initform nil :initarg :reader :reader reader)))
 
-#+cmu
-(defmethod pcl:finalize-inheritance :after ((cl hyperobject-class))
-  (init-hyperobject-class cl))
-
-#+scl
-(defmethod clos:finalize-inheritance :after ((cl hyperobject-class))
-  (init-hyperobject-class cl))
-
+(defmethod print-object ((obj subobject) (s stream))
+  (print-unreadable-object (obj s :type t :identity t)
+    (format s "~S" (name obj))))
 
-#+sbcl
-(defmethod sb-pcl:finalize-inheritance :after ((cl hyperobject-class))
-  (init-hyperobject-class cl))
+(defclass reference ()
+  ((name :type symbol :initform nil :initarg :name :reader name)
+   (lookup :type function :initform nil :initarg :lookup :reader lookup)
+   (link-parameters :type list :initform nil :initarg :link-parameters
+		    :reader link-parameters)))
 
+(defmethod print-object ((obj reference) (s stream))
+  (print-unreadable-object (obj s :type t :identity t)
+    (format s "~S" (name obj))))
 
-#+cmu
-(defmethod pcl:validate-superclass ((class hyperobject-class) (superclass pcl::standard-class))
+#+(or cmu scl sbcl)
+(defmethod validate-superclass ((class hyperobject-class) (superclass standard-class))
   t)
 
-#+scl
-(defmethod clos:validate-superclass ((class hyperobject-class) (superclass standard-class))
-  t)
+(defmethod finalize-inheritance :after ((cl hyperobject-class))
+  (init-hyperobject-class cl))
 
-#+sbcl
-(defmethod sb-pcl:validate-superclass ((class hyperobject-class) (superclass sb-pcl::standard-class))
-  t)
+;; Slot definitions
+(defmethod direct-slot-definition-class ((cl hyperobject-class) 
+					 #+allegro &rest
+						   iargs)
+  (find-class 'hyperobject-dsd))
+
+(defmacro define-class-option (slot-name &optional required)
+  #+lispworks
+  `(defmethod clos:process-a-class-option ((class hyperobject-class)
+					   (name (eql ,slot-name))
+					   value)
+    (when (and ,required (null value))
+      (error "hyperobject class slot ~A must have a value" name))
+    (if (null (cdr value))
+	`(name ,(car value))
+	`(name (quote value))))
+  #+(or allegro sbcl cmu scl)
+  (declare (ignore slot-name required))
+  )
 
-#+allegro
-(defmethod mop:finalize-inheritance :after ((cl hyperobject-class))
-  (init-hyperobject-class cl))
+(defmacro define-slot-option (slot-name)
+  #+lispworks
+  `(defmethod clos:process-a-slot-option ((class hyperobject-class)
+					  (option (eql ,slot-name))
+					  value
+					  already-processed-other-options
+					  slot)
+    (list option value))
+  #-lispworks
+  (declare (ignore slot-name))
+  )
 
-#+lispworks
-(defmethod clos:finalize-inheritance :after ((cl hyperobject-class))
-  (init-hyperobject-class cl))
+(define-class-option :title)
+(define-class-option :print-slots)
+(define-class-option :description)
+
+(define-slot-option :print-formatter)
+(define-slot-option :subobject)
+(define-slot-option :reference)
+(define-slot-option :description)
+
+;; Slot definitions
+
+(defclass hyperobject-dsd (standard-direct-slot-definition)
+  ((ho-type :initarg :ho-type)
+   (print-formatter :initarg :print-formatter)
+   (subobject :initarg :subobject :initarg nil)
+   (reference :initarg :reference :initarg nil)
+   (description :initarg :description :initarg nil)
+   ))
+
+(defclass hyperobject-esd (standard-effective-slot-definition)
+  ((ho-type :initarg :ho-type :accessor esd-ho-type)
+   (print-formatter :initarg :print-formatter :accessor esd-print-formatter)
+   (subobject :initarg :subobject :accessor esd-subobject)
+   (reference :initarg :reference :accessor esd-reference)
+   (description :initarg :description :accessor esd-description)
+  ))
+
+
+
+(defmethod compute-effective-slot-definition :around
+    ((cl hyperobject-class) #+(or allegro lispworks) name dsds)
+  #+allergo (declare (ignore name))
+  (let* ((dsd (car dsds))
+	 (ho-type (slot-value dsd 'type)))
+    (setf (slot-value dsd 'ho-type) ho-type)
+    (setf (slot-value dsd 'type) (convert-ho-type ho-type))
+    (let ((ia (compute-effective-slot-definition-initargs
+	       cl #+lispworks name dsds)))
+      (apply
+       #'make-instance 'hyperobject-esd 
+       :ho-type ho-type
+       :print-formatter (slot-value dsd 'print-formatter)
+       :subobject (slot-value dsd 'subobject)
+       :reference (slot-value dsd 'reference)
+       :description (slot-value dsd 'description)
+       ia)))
+  )
 
-#+lispworks
-(defmethod clos:process-a-class-option ((class hyperobject-class)
-					(name (eql :title))
-					value)
-  (unless value
-    (error "hyperobject-class title must have a value"))
-  (if (null (cdr value))
-      (list name (car value))
-    (list name `',value)))
-
-#+lispworks
-(defmethod clos:process-a-class-option ((class hyperobject-class)
-					(name (eql :fields))
-					value)
-  (unless value
-    (error "hyperobject-class fields must have a value"))
-  (list name `',value))
-
-#+lispworks
-(defmethod clos:process-a-class-option ((class hyperobject-class)
-					(name (eql :ref-fields))
-					value)
-  (unless value
-    (error "hyperobject-class ref-fields must have a value"))
-  (list name `',value))
-
-#+lispworks
-(defmethod clos:process-a-class-option ((class hyperobject-class)
-					(name (eql :subobjects-lists))
-					value)
-  (unless value
-    (error "hyperobject-class subobjects-lists must have a value"))
-  (list name `',value))
+(defun convert-ho-type (ho-type)
+  (check-type ho-type symbol)
+  (case (intern (symbol-name ho-type) (symbol-name :keyword))
+    (:string
+     'string)
+    (:fixnum
+     'fixnum)
+    (:boolean
+     'boolean)
+    (:integer
+     'integer)
+    (:cdata
+     'string)
+    (:float
+     'float)
+    (otherwise
+     ho-type)))
 
 ;;;; Class initialization function
-      
-(defun init-hyperobject-class (cl)
-    (let ((fmtstr-text "")
-	  (fmtstr-html "")
-	  (fmtstr-xml "")
-	  (fmtstr-text-labels "")
-	  (fmtstr-html-labels "")
-	  (fmtstr-xml-labels "")
-	  (fmtstr-html-ref "")
-	  (fmtstr-xml-ref "")
-	  (fmtstr-html-ref-labels "")
-	  (fmtstr-xml-ref-labels "")
-	  (first-field t)
-	  (value-func '())
-	  (xmlvalue-func '())
-	  (classname (class-name cl))
-	  (package (symbol-package (portable-class-name cl)))
-	  (ref-fields (slot-value cl 'ref-fields)))
-      (declare (ignore classname))
-      (dolist (f (slot-value cl 'fields))
-	(let ((name (car f))
-	      (namestr (symbol-name (car f)))
-	      (namestr-lower (string-downcase (symbol-name (car f))))
-	      (type (cadr f))
-	      (formatter (caddr f))
+
+(defun find-slot-by-name (cl name)
+  (find name (class-slots cl) :key #'slot-definition-name))
+
+
+(defun process-subobjects (cl)
+  "Process class subobjects slot"
+  (setf (slot-value cl 'subobjects)
+    (let ((subobjects '()))
+      (dolist (slot (class-slots cl))
+	(when (slot-value slot 'subobject)
+	  (push (make-instance 'subobject :name (slot-definition-name slot)
+			       :reader (if (eq t (esd-subobject slot))
+					   (slot-definition-name slot)
+					 (esd-subobject slot)))
+		subobjects)))
+      subobjects)))
+
+(defun process-documentation (cl)
+  "Calculate class documentation slot"
+  (awhen (slot-value cl 'title)
+	 (setf (slot-value cl 'title) (car it)))
+  (awhen (slot-value cl 'description)
+	 (setf (slot-value cl 'description) (car it)))
+  
+  (let ((*print-circle* nil))
+    (setf (documentation (class-name cl) 'class)
+      (format nil "Hyperobject~A~A~A~A"
+	      (aif (slot-value cl 'title)
+		   (format nil ": ~A" it ""))
+	      (aif (slot-value cl 'description)
+		   (format nil "~%Class description: ~A" it) "")
+	      (aif (slot-value cl 'subobjects)
+		   (format nil "~%Subobjects:~{ ~A~}" (mapcar #'name it)) "")
+	      (aif (slot-value cl 'print-slots)
+		   (format nil "~%Print-slots:~{ ~A~}" it) "")
+	      ))))
+
+(defun process-views (cl)
+  "Calculate all view slots for a hyperobject class"
+  (let ((fmtstr-text "")
+	(fmtstr-html "")
+	(fmtstr-xml "")
+	(fmtstr-text-labels "")
+	(fmtstr-html-labels "")
+	(fmtstr-xml-labels "")
+	(fmtstr-html-ref "")
+	(fmtstr-xml-ref "")
+	(fmtstr-html-ref-labels "")
+	(fmtstr-xml-ref-labels "")
+	(first-field t)
+	(value-func '())
+	(xmlvalue-func '())
+	(classname (class-name cl))
+	(package (symbol-package (class-name cl)))
+	(references nil))
+    (declare (ignore classname))
+    (dolist (slot-name (slot-value cl 'print-slots))
+      (let ((slot (find-slot-by-name cl slot-name)))
+	(unless slot
+	  (error "Slot ~A is not found in class ~S" slot-name cl))
+	(let ((name (slot-definition-name slot))
+	      (namestr (symbol-name (slot-definition-name slot)))
+	      (namestr-lower (string-downcase (symbol-name (slot-definition-name slot))))
+	      (type (slot-value slot 'ho-type))
+	      (print-formatter (slot-value slot 'print-formatter))
 	      (value-fmt "~a")
 	      (plain-value-func nil)
 	      html-str xml-str html-label-str xml-label-str)
@@ -178,25 +283,22 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
 	  (when (or (eql type :integer) (eql type :fixnum))
 	    (setq value-fmt "~d"))
 	  
-	  (when (eql type :commainteger)
-	    (setq value-fmt "~:d"))
-	  
 	  (when (eql type :boolean)
 	    (setq value-fmt "~a"))
-	    
+	  
 	  (if first-field
 	      (setq first-field nil)
-	    (progn
-	      (string-append fmtstr-text " ")
-	      (string-append fmtstr-html " ")
-	      (string-append fmtstr-xml " ")
-	      (string-append fmtstr-text-labels " ")
-	      (string-append fmtstr-html-labels " ")
-	      (string-append fmtstr-xml-labels " ")
-	      (string-append fmtstr-html-ref " ")
-	      (string-append fmtstr-xml-ref " ")
-	      (string-append fmtstr-html-ref-labels " ")
-	      (string-append fmtstr-xml-ref-labels " ")))
+	      (progn
+		(string-append fmtstr-text " ")
+		(string-append fmtstr-html " ")
+		(string-append fmtstr-xml " ")
+		(string-append fmtstr-text-labels " ")
+		(string-append fmtstr-html-labels " ")
+		(string-append fmtstr-xml-labels " ")
+		(string-append fmtstr-html-ref " ")
+		(string-append fmtstr-xml-ref " ")
+		(string-append fmtstr-html-ref-labels " ")
+		(string-append fmtstr-xml-ref-labels " ")))
 	  
 	  (setq html-str (concatenate 'string "<span class=\"" namestr-lower "\">" value-fmt "</span>"))
 	  (setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "</" namestr-lower ">"))
@@ -210,556 +312,113 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
 	  (string-append fmtstr-html-labels html-label-str)
 	  (string-append fmtstr-xml-labels xml-label-str)
 	  
-	  (if (find name ref-fields :key #'car)
-	    (progn
-	      (string-append fmtstr-html-ref "<~~a>" value-fmt "</~~a>")
-	      (string-append fmtstr-xml-ref "<~~a>" value-fmt "</~~a>")
-	      (string-append fmtstr-html-ref-labels "<span class=\"label\">" namestr-lower "</span> <~~a>" value-fmt "</~~a>")
-	      (string-append fmtstr-xml-ref-labels "<label>" namestr-lower "</label> <~~a>" value-fmt "</~~a>"))
-	    (progn
-	      (string-append fmtstr-html-ref html-str)
-	      (string-append fmtstr-xml-ref xml-str)
-	      (string-append fmtstr-html-ref-labels html-label-str)
-	      (string-append fmtstr-xml-ref-labels xml-label-str)))
+	  (if (esd-reference slot)
+	      (progn
+		(string-append fmtstr-html-ref "<~~a>" value-fmt "</~~a>")
+		(string-append fmtstr-xml-ref "<~~a>" value-fmt "</~~a>")
+		(string-append fmtstr-html-ref-labels "<span class=\"label\">" namestr-lower "</span> <~~a>" value-fmt "</~~a>")
+		(string-append fmtstr-xml-ref-labels "<label>" namestr-lower "</label> <~~a>" value-fmt "</~~a>")
+		(push (make-instance 'reference :name name :lookup (esd-reference slot))
+		      references))
+	      (progn
+		(string-append fmtstr-html-ref html-str)
+		(string-append fmtstr-xml-ref xml-str)
+		(string-append fmtstr-html-ref-labels html-label-str)
+		(string-append fmtstr-xml-ref-labels xml-label-str)))
 	  
-	  (if formatter
+	  (if print-formatter
+	      (setq plain-value-func 
+		    (list `(,print-formatter (,(intern namestr package) x))))
 	      (setq plain-value-func 
-		(list `(,formatter (,(intern namestr package) x))))
-	    (setq plain-value-func 
-	      (list `(,(intern namestr package) x))))
+		    (list `(,(intern namestr package) x))))
 	  (setq value-func (append value-func plain-value-func))
 	  
 	  (if (eql type :cdata)
 	      (setq xmlvalue-func (append xmlvalue-func (list `(xml-cdata ,@plain-value-func))))
-	    (setq xmlvalue-func (append xmlvalue-func plain-value-func)))
-	  ))
-      
-      (if value-func
-	  (setq value-func `(lambda (x) (values ,@value-func)))
+	      (setq xmlvalue-func (append xmlvalue-func plain-value-func)))
+	  )))
+    
+    (setf (slot-value cl 'references) references)
+    
+    (if value-func
+	(setq value-func `(lambda (x) (values ,@value-func)))
 	(setq value-func `(lambda () (values))))
-      (setq value-func (compile nil (eval value-func)))
-      
-      (if xmlvalue-func
-	  (setq xmlvalue-func `(lambda (x) (values ,@xmlvalue-func)))
+    (setq value-func (compile nil (eval value-func)))
+    
+    (if xmlvalue-func
+	(setq xmlvalue-func `(lambda (x) (values ,@xmlvalue-func)))
 	(setq xmlvalue-func `(lambda () (values))))
-      (setq xmlvalue-func (compile nil (eval xmlvalue-func)))
-
-      (setf (slot-value cl 'fmtstr-text) fmtstr-text)
-      (setf (slot-value cl 'fmtstr-html) fmtstr-html)
-      (setf (slot-value cl 'fmtstr-xml) fmtstr-xml)
-      (setf (slot-value cl 'fmtstr-text-labels) fmtstr-text-labels)
-      (setf (slot-value cl 'fmtstr-html-labels) fmtstr-html-labels)
-      (setf (slot-value cl 'fmtstr-xml-labels) fmtstr-xml-labels)
-      (setf (slot-value cl 'fmtstr-html-ref) fmtstr-html-ref)
-      (setf (slot-value cl 'fmtstr-xml-ref) fmtstr-xml-ref)
-      (setf (slot-value cl 'fmtstr-html-ref-labels) fmtstr-html-ref-labels)
-      (setf (slot-value cl 'fmtstr-xml-ref-labels) fmtstr-xml-ref-labels)
-      (setf (slot-value cl 'value-func) value-func)
-      (setf (slot-value cl 'xmlvalue-func) xmlvalue-func))
-    (values))
+    (setq xmlvalue-func (compile nil (eval xmlvalue-func)))
+    
+    (setf (slot-value cl 'fmtstr-text) fmtstr-text)
+    (setf (slot-value cl 'fmtstr-html) fmtstr-html)
+    (setf (slot-value cl 'fmtstr-xml) fmtstr-xml)
+    (setf (slot-value cl 'fmtstr-text-labels) fmtstr-text-labels)
+    (setf (slot-value cl 'fmtstr-html-labels) fmtstr-html-labels)
+    (setf (slot-value cl 'fmtstr-xml-labels) fmtstr-xml-labels)
+    (setf (slot-value cl 'fmtstr-html-ref) fmtstr-html-ref)
+    (setf (slot-value cl 'fmtstr-xml-ref) fmtstr-xml-ref)
+    (setf (slot-value cl 'fmtstr-html-ref-labels) fmtstr-html-ref-labels)
+    (setf (slot-value cl 'fmtstr-xml-ref-labels) fmtstr-xml-ref-labels)
+    (setf (slot-value cl 'value-func) value-func)
+    (setf (slot-value cl 'xmlvalue-func) xmlvalue-func))
+  (values))
 
+(defun init-hyperobject-class (cl)
+  "Initialize a hyperobject class. Calculates all class slots"
+  (process-subobjects cl)
+  (process-views cl)
+  (process-documentation cl))
 
 (defun hyperobject-class-fmtstr-text (obj)
-  (slot-value (portable-class-of obj) 'fmtstr-text))
+  (slot-value (class-of obj) 'fmtstr-text))
 
 (defun hyperobject-class-fmtstr-html (obj)
-  (slot-value (portable-class-of obj) 'fmtstr-html))
+  (slot-value (class-of obj) 'fmtstr-html))
 
 (defun hyperobject-class-fmtstr-xml (obj)
-  (slot-value (portable-class-of obj) 'fmtstr-xml))
+  (slot-value (class-of obj) 'fmtstr-xml))
 
 (defun hyperobject-class-fmtstr-text-labels (obj)
-  (slot-value (portable-class-of obj) 'fmtstr-text-labels))
+  (slot-value (class-of obj) 'fmtstr-text-labels))
 
 (defun hyperobject-class-fmtstr-html-labels (obj)
-  (slot-value (portable-class-of obj) 'fmtstr-html-labels))
+  (slot-value (class-of obj) 'fmtstr-html-labels))
 
 (defun hyperobject-class-fmtstr-xml-labels (obj)
-  (slot-value (portable-class-of obj) 'fmtstr-xml-labels))
+  (slot-value (class-of obj) 'fmtstr-xml-labels))
 
 (defun hyperobject-class-value-func (obj)
-  (slot-value (portable-class-of obj) 'value-func))
+  (slot-value (class-of obj) 'value-func))
 
 (defun hyperobject-class-xmlvalue-func (obj)
-  (slot-value (portable-class-of obj) 'xmlvalue-func))
+  (slot-value (class-of obj) 'xmlvalue-func))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
 (defun hyperobject-class-title (obj)
-  (awhen (slot-value (portable-class-of obj) 'title)
+  (awhen (slot-value (class-of obj) 'title)
 	    (if (consp it)
 		(car it)
 	      it))))
 
-(defun hyperobject-class-subobjects-lists (obj)
-  (slot-value (portable-class-of obj) 'subobjects-lists))
+(defun hyperobject-class-subobjects (obj)
+  (slot-value (class-of obj) 'subobjects))
 
-(defun hyperobject-class-ref-fields (obj)
-  (slot-value (portable-class-of obj) 'ref-fields))
+(defun hyperobject-class-references (obj)
+  (slot-value (class-of obj) 'references))
 
 (defun hyperobject-class-fields (obj)
-  (slot-value (portable-class-of obj) 'fields))
+  (class-slots (class-of obj)))
 
 (defun hyperobject-class-fmtstr-html-ref (obj)
-  (slot-value (portable-class-of obj) 'fmtstr-html-ref))
+  (slot-value (class-of obj) 'fmtstr-html-ref))
 
 (defun hyperobject-class-fmtstr-xml-ref (obj)
-  (slot-value (portable-class-of obj) 'fmtstr-xml-ref))
+  (slot-value (class-of obj) 'fmtstr-xml-ref))
 
 (defun hyperobject-class-fmtstr-html-ref-labels (obj)
-  (slot-value (portable-class-of obj) 'fmtstr-html-ref-labels))
+  (slot-value (class-of obj) 'fmtstr-html-ref-labels))
 
 (defun hyperobject-class-fmtstr-xml-ref-labels (obj)
-  (slot-value (portable-class-of obj) 'fmtstr-xml-ref-labels))
-
-;;; Class name functions
-
-(defgeneric hyperobject-class-stdname (x))
-(defmethod hyperobject-class-stdname ((name string))
-  (string-downcase (subseq name 1)))
-  
-(defmethod hyperobject-class-stdname ((cl standard-object))
-  (string-downcase (subseq (portable-class-name (portable-class-of cl)) 1)))
-  
-;;;; Generic Print functions
-
-(defparameter *default-textformat* nil)
-(defparameter *default-htmlformat* nil)
-(defparameter *default-htmlrefformat* nil)
-(defparameter *default-xhtmlformat* nil)
-(defparameter *default-xhtmlrefformat* nil)
-(defparameter *default-xmlformat* nil)
-(defparameter *default-xmlrefformat* nil)
-(defparameter *default-ie-xmlrefformat* nil)
-(defparameter *default-nullformat* nil)
-(defparameter *default-init-format?* nil)
-
-(defun make-format-instance (fmt)
-  (unless *default-init-format?*
-    (setq *default-textformat* (make-instance 'textformat))
-    (setq *default-htmlformat* (make-instance 'htmlformat))
-    (setq *default-htmlrefformat* (make-instance 'htmlrefformat))
-    (setq *default-xhtmlformat* (make-instance 'xhtmlformat))
-    (setq *default-xhtmlrefformat* (make-instance 'xhtmlrefformat))
-    (setq *default-xmlformat* (make-instance 'xmlformat))
-    (setq *default-xmlrefformat* (make-instance 'xmlrefformat))
-    (setq *default-ie-xmlrefformat* (make-instance 'ie-xmlrefformat))
-    (setq *default-nullformat* (make-instance 'nullformat))
-    (setq *default-init-format?* t))
-  
-  (case fmt
-      (:text *default-textformat*)
-      (:html *default-htmlformat*)
-      (:htmlref *default-htmlrefformat*)
-      (:xhtml  *default-xhtmlformat*)
-      (:xhtmlref *default-xhtmlrefformat*)
-      (:xml  *default-xmlformat*)
-      (:xmlref *default-xmlrefformat*)
-      (:ie-xmlref *default-ie-xmlrefformat*)
-      (:null *default-nullformat*)
-      (otherwise *default-textformat*)))
-    
-;;;; Output format classes for print hyperobject-classes
-
-(defclass dataformat ()
-  ((file-start-str :type string :initarg :file-start-str :reader file-start-str)
-   (file-end-str :type string :initarg :file-end-str :reader file-end-str)
-   (list-start-fmtstr :type string :initarg :list-start-fmtstr :reader list-start-fmtstr)
-   (list-start-value-func :type function :initarg :list-start-value-func :reader list-start-value-func)
-   (list-start-indent :initarg :list-start-indent :reader list-start-indent)
-   (list-end-fmtstr :type string :initarg :list-end-fmtstr :reader list-end-fmtstr)
-   (list-end-value-func :type function :initarg :list-end-value-func :reader list-end-value-func)
-   (list-end-indent :initarg :list-end-indent :reader list-end-indent)
-   (obj-start-fmtstr :type string :initarg :obj-start-fmtstr :reader obj-start-fmtstr)
-   (obj-start-value-func :initarg :obj-start-value-func :reader obj-start-value-func)
-   (obj-start-indent :initarg :obj-start-indent :reader obj-start-indent)
-   (obj-end-fmtstr :type string :initarg :obj-end-fmtstr :reader obj-end-fmtstr)
-   (obj-end-value-func :initarg :obj-end-value-func :reader obj-end-value-func)
-   (obj-end-indent :initarg :obj-end-indent :reader obj-end-indent)
-   (obj-data-indent :initarg :obj-data-indent :reader obj-data-indent)
-   (obj-data-fmtstr :initarg :obj-data-fmtstr :reader  obj-data-fmtstr)
-   (obj-data-fmtstr-labels :initarg :obj-data-fmtstr-labels :reader  obj-data-fmtstr-labels)
-   (obj-data-end-fmtstr :initarg :obj-data-end-fmtstr :reader obj-data-end-fmtstr)
-   (obj-data-value-func :initarg :obj-data-value-func :reader obj-data-value-func)
-   (link-ref :initarg :link-ref :reader link-ref))
-  (:default-initargs :file-start-str nil :file-end-str nil :list-start-fmtstr nil :list-start-value-func nil
-		     :list-start-indent nil :list-end-fmtstr nil :list-end-value-func nil :list-end-indent nil
-		     :obj-start-fmtstr nil :obj-start-value-func nil :obj-start-indent nil
-		     :obj-end-fmtstr nil :obj-end-value-func nil :obj-end-indent nil
-		     :obj-data-indent nil :obj-data-fmtstr nil :obj-data-fmtstr-labels nil :obj-data-end-fmtstr nil
-		     :obj-data-value-func nil :link-ref nil)
-  (:documentation "Parent for all dataformat objects"))
-
-(defclass binaryformat (dataformat)
-  ())
-
-(defclass nullformat (dataformat)
-  ())
-
-(defun text-list-start-value-func (obj nitems)
-  (values (hyperobject-class-title obj) nitems))
-
-(defclass textformat (dataformat) 
-  ()	
-  (:default-initargs :list-start-fmtstr "~a~P:~%"
-    :list-start-value-func #'text-list-start-value-func
-    :list-start-indent t
-    :obj-data-indent t
-    :obj-data-fmtstr #'hyperobject-class-fmtstr-text
-    :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-text-labels
-    :obj-data-end-fmtstr "~%"
-    :obj-data-value-func #'hyperobject-class-value-func))
-
-
-(defun class-name-of (obj)
-  (string-downcase (portable-class-name (portable-class-of obj))))
-
-(defun htmlformat-list-start-value-func (x nitems) 
-  (values (hyperobject-class-title x) nitems (class-name-of x)))
-
-(defclass htmlformat (textformat) 
-  ()
-  (:default-initargs :file-start-str "<html><body>~%"
-    :file-end-str "</body><html>~%"
-    :list-start-indent t
-    :list-start-fmtstr "<p><b>~a~p:</b></p><div class=\"~A\"><ul>~%"
-    :list-start-value-func #'htmlformat-list-start-value-func
-    :list-end-fmtstr "</ul></div>~%"
-    :list-end-indent t
-    :list-end-value-func #'identity
-    :obj-start-indent t
-    :obj-start-fmtstr "<li>"
-    :obj-start-value-func #'identity
-    :obj-end-indent  t
-    :obj-end-fmtstr  "</li>~%"
-    :obj-end-value-func #'identity
-    :obj-data-indent t
-    :obj-data-fmtstr #'hyperobject-class-fmtstr-html-labels
-    :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-html-labels
-    :obj-data-value-func #'hyperobject-class-value-func))
-
-(defclass xhtmlformat (textformat) 
-  ()
-  (:default-initargs :file-start-str "<html><body>~%"
-    :file-end-str "</body><html>~%"
-    :list-start-indent t
-    :list-start-fmtstr "<p><b>~a~p:</b></p><div class=\"~A\"><ul>~%"
-    :list-start-value-func #'htmlformat-list-start-value-func
-    :list-end-fmtstr "</ul></div>~%"
-    :list-end-indent t
-    :list-end-value-func #'identity
-    :obj-start-indent t
-    :obj-start-fmtstr "<li>"
-    :obj-start-value-func #'identity
-    :obj-end-indent  t
-    :obj-end-fmtstr  "</li>~%"
-    :obj-end-value-func #'identity
-    :obj-data-indent t
-    :obj-data-fmtstr #'hyperobject-class-fmtstr-html-labels
-    :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-html-labels
-    :obj-data-value-func #'hyperobject-class-xmlvalue-func))
-
-
-(defun xmlformat-list-end-value-func (x)
-  (format nil "~alist" (class-name-of x)))
-
-(defun xmlformat-list-start-value-func (x nitems) 
-  (values (format nil "~alist" (class-name-of x)) (hyperobject-class-title x) nitems))
-
-(defclass xmlformat (textformat) 
-  ()
-  (:default-initargs :file-start-str "" ; (std-xml-header)
-    :list-start-indent  t
-    :list-start-fmtstr "<~a><title>~a~p:</title> ~%"
-    :list-start-value-func #'xmlformat-list-start-value-func
-    :list-end-indent  t
-    :list-end-fmtstr "</~a>~%"
-    :list-end-value-func #'xmlformat-list-end-value-func
-    :obj-start-fmtstr "<~a>"
-    :obj-start-value-func #'class-name-of
-    :obj-start-indent t
-    :obj-end-fmtstr "</~a>~%"
-    :obj-end-value-func #'class-name-of
-    :obj-end-indent nil
-    :obj-data-indent nil
-    :obj-data-fmtstr #'hyperobject-class-fmtstr-xml
-    :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-xml-labels
-    :obj-data-value-func #'hyperobject-class-xmlvalue-func))
-
-(defclass link-ref ()
-  ((fmtstr :type function :initarg :fmtstr :accessor fmtstr)
-   (fmtstr-labels :type function :initarg :fmtstr-labels :accessor fmtstr-labels)
-   (page-name :type string :initarg :page-name :accessor page-name)
-   (href-head :type string :initarg :href-head :accessor href-head)
-   (href-end :type string :initarg :href-end :accessor href-end)
-   (ampersand :type string :initarg :ampersand :accessor ampersand))
-  (:default-initargs :fmtstr nil 
-    :fmtstr-labels nil 
-    :page-name "disp-func1" 
-    :href-head nil :href-end nil :ampersand nil)
-  (:documentation "Formatting for a linked reference"))
-
-(defclass html-link-ref (link-ref)
-  ()
-  (:default-initargs :fmtstr #'hyperobject-class-fmtstr-html-ref  
-    :fmtstr-labels #'hyperobject-class-fmtstr-html-ref-labels
-    :href-head "a href=" 
-    :href-end "a" 
-    :ampersand "&"))
-
-(defclass xhtml-link-ref (link-ref)
-  ()
-  (:default-initargs :fmtstr #'hyperobject-class-fmtstr-html-ref  
-    :fmtstr-labels #'hyperobject-class-fmtstr-html-ref-labels
-    :href-head "a href=" 
-    :href-end "a" 
-    :ampersand "&amp;"))
-
-(defclass xml-link-ref (link-ref)
-  ()
-  (:default-initargs :fmtstr #'hyperobject-class-fmtstr-xml-ref 
-		     :fmtstr-labels #'hyperobject-class-fmtstr-xml-ref-labels
-		     :href-head "xmllink xlink:type=\"simple\" xlink:href=" 
-		     :href-end "xmllink" 
-		     :ampersand "&amp;")
-  (:documentation "Mozilla's and W3's idea of a link with XML"))
-
-(defclass ie-xml-link-ref (xml-link-ref)
-  ()
-  (:default-initargs :href-head "html:a href=" 
-		     :href-end "html:a" )
-  (:documentation "Internet Explorer's idea of a link with XML"))
-
-
-(defclass htmlrefformat (htmlformat)
-  ()
-  (:default-initargs :link-ref (make-instance 'html-link-ref)))
-
-(defclass xhtmlrefformat (xhtmlformat)
-  ()
-  (:default-initargs :link-ref (make-instance 'xhtml-link-ref)))
-
-(defclass xmlrefformat (xmlformat)
-  ()
-  (:default-initargs :link-ref (make-instance 'xml-link-ref)))
-
-(defclass ie-xmlrefformat (xmlformat)
-  ()
-  (:default-initargs :link-ref (make-instance 'ie-xml-link-ref)))
-
-
-;;; File Start and Ends
-
-(defgeneric fmt-file-start (fmt s))
-(defmethod fmt-file-start ((fmt dataformat) (s stream)))
-
-(defmethod fmt-file-start ((fmt textformat) (s stream))
-  (aif (file-start-str fmt)
-      (format s it)))
-
-(defgeneric fmt-file-end (fmt s))
-(defmethod fmt-file-end ((fmt textformat) (s stream))
-  (aif (file-end-str fmt)
-	  (format s it)))
-
-;;; List Start and Ends
-
-(defgeneric fmt-list-start (obj fmt s &optional indent num-items))
-(defmethod fmt-list-start (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1))
-  (if (list-start-indent fmt)
-      (indent-spaces indent s))
-  (aif (list-start-fmtstr fmt)
-	  (apply #'format s it
-		 (multiple-value-list
-		  (funcall (list-start-value-func fmt) x num-items)))))
-
-(defgeneric fmt-list-end (obj fmt s &optional indent num-items))
-(defmethod fmt-list-end (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1))
-  (declare (ignore num-items))
-  (if (list-end-indent fmt)
-      (indent-spaces indent s))
-  (aif (list-end-fmtstr fmt)
-	  (apply #'format s it
-		 (multiple-value-list
-		  (funcall (list-end-value-func fmt) x)))))
-
-;;; Object Start and Ends
-
-(defgeneric fmt-obj-start (obj fmt s &optional indent))
-(defmethod fmt-obj-start (x (fmt textformat) (s stream) &optional (indent 0))
-  (if (obj-start-indent fmt)
-      (indent-spaces indent s))
-  (aif (obj-start-fmtstr fmt)
-	  (apply #'format s it
-		 (multiple-value-list
-		  (funcall (obj-start-value-func fmt) x)))))
-
-(defgeneric fmt-obj-end (obj fmt s &optional indent))
-(defmethod fmt-obj-end (x (fmt textformat) (s stream) &optional (indent 0))
-  (if (obj-end-indent fmt)
-      (indent-spaces indent s))
-  (aif (obj-end-fmtstr fmt)
-	  (apply #'format s it
-		 (multiple-value-list
-		  (funcall (obj-end-value-func fmt) x)))))
-  
-;;; Object Data 
-
-(defgeneric make-link-start (obj ref fieldname fieldfunc fieldvalue refvars))
-(defmethod make-link-start (obj (ref link-ref) fieldname fieldfunc fieldvalue refvars)
-  (declare (ignore obj fieldname))
-  (format nil "~a\"~a?func=~a~akey=~a~a\"" 
-	  (href-head ref) (make-url (page-name ref)) fieldfunc 
-	  (ampersand ref) fieldvalue
-	  (if refvars
-	      (let ((varstr ""))
-		(dolist (var refvars)
-		  (string-append varstr (format nil "~a~a=~a" 
-						(ampersand ref) (car var) (cadr var))))
-		varstr)
-	    "")))
-
-(defgeneric make-link-end (obj ref fieldname)) 
-(defmethod make-link-end (obj (ref link-ref) fieldname)
-  (declare (ignore obj fieldname))
-  (format nil "~a" (href-end ref))
-  )
-
-(defgeneric fmt-obj-data (obj fmt s &optional indent label refvars))
-(defmethod fmt-obj-data (x (fmt textformat) s
-			 &optional (indent 0) (label nil) (refvars nil))
-  (if (obj-data-indent fmt)
-      (indent-spaces indent s))
-  (if (link-ref fmt)
-      (fmt-obj-data-with-ref x fmt s label refvars)
-    (fmt-obj-data-plain x fmt s label))
-  (aif (obj-data-end-fmtstr fmt)
-       (format s it)))
-
-(defgeneric fmt-obj-data-plain (obj fmt s label))
-(defmethod fmt-obj-data-plain (x (fmt textformat) s label)
-  (if label
-      (apply #'format s
-	     (funcall (obj-data-fmtstr-labels fmt) x)
-	     (multiple-value-list 
-	      (funcall (funcall (obj-data-value-func fmt) x) x)))
-    (apply #'format s (funcall (obj-data-fmtstr fmt) x)
-	   (multiple-value-list
-	    (funcall (funcall (obj-data-value-func fmt) x) x)))))
-
-(defgeneric fmt-obj-data-with-ref (obj fmt s label refvars))
-(defmethod fmt-obj-data-with-ref (x (fmt textformat) s label refvars)
-  (let ((refstr (make-ref-data-str x fmt label))
-	(refvalues nil)
-	(field-values 
-	 (multiple-value-list
-	  (funcall (funcall (obj-data-value-func fmt) x) x))))
-    
-    ;; make list of reference link fields for printing to refstr template
-    (dolist (field (hyperobject-class-ref-fields x))
-      (let ((link-start 
-	     (make-link-start x (link-ref fmt) (car field) (cadr field)
-			      (nth (position (car field) (hyperobject-class-fields x) :key #'car) field-values)  
-			      (append (caddr field) refvars)))
-	    (link-end (make-link-end x (link-ref fmt) (car field))))
-	(push link-start refvalues)
-	(push link-end refvalues)))
-    (setq refvalues (nreverse refvalues))
-    
-    (apply #'format s refstr refvalues)))
-
-(defgeneric obj-data (obj))
-(defmethod obj-data (x)
-  "Returns the objects data as a string. Used by common-graphics outline function"
-  (let ((fmt (make-format-instance :text)))
-    (apply #'format nil (funcall (obj-data-fmtstr fmt) x)
-	   (multiple-value-list 
-	    (funcall (funcall (obj-data-value-func fmt) x) x)))))
-
-(defgeneric make-ref-data-str (obj fmt &optional label))
-(defmethod make-ref-data-str (x (fmt textformat) &optional (label nil))
-  "Return fmt string for that contains ~a slots for reference link start and end"
-  (unless (link-ref fmt)
-    (error "fmt does not contain a link-ref"))
-  (let ((refstr 
-	 (if label
-	     (apply #'format nil (funcall (fmtstr-labels (link-ref fmt)) x)
-		    (multiple-value-list
-		      (funcall (funcall (obj-data-value-func fmt) x) x)))
-	   (apply #'format nil (funcall (fmtstr (link-ref fmt)) x)
-		  (multiple-value-list (funcall (funcall (obj-data-value-func fmt) x) x))))))
-    refstr))
-  
-;;; Display method for objects
-
-
-(defgeneric load-all-subobjects (objs))
-(defmethod load-all-subobjects (objs)
-  "Load all subobjects if they have not already been loaded."
-  (when objs
-    (let ((objlist (mklist objs)))
-      (dolist (obj objlist)
-        (awhen (hyperobject-class-subobjects-lists obj)  ;; access list of functions
-          (dolist (child-obj it)   ;; for each child function
-            (awhen (funcall (car child-obj) obj)
-              (load-all-subobjects it))))))
-    objs))
-
-(defgeneric print-hyperobject-class (objs fmt strm
-				  &optional label english-only-function
-				  indent subobjects refvars))
-
-(defmethod print-hyperobject-class (objs (fmt dataformat) (strm stream) 
-				 &optional (label nil) (indent 0)
-				 (english-only-function nil)
-				 (subobjects nil) (refvars nil))
-"Display a single or list of hyperobject-class instances and their subobjects"
-  (when objs
-    (setq objs (mklist objs))
-    (let ((nobjs (length objs)))
-      (fmt-list-start (car objs) fmt strm indent nobjs)
-      (dolist (obj objs)
-        (unless (and english-only-function
-		  (multiple-value-bind (eng term) (funcall english-only-function obj)
-		    (and term (not eng))))
-          (fmt-obj-start obj fmt strm indent)
-          (fmt-obj-data obj fmt strm (1+ indent) label refvars)
-          (if subobjects
-              (awhen (hyperobject-class-subobjects-lists obj)  ;; access list of functions
-                        (dolist (child-obj it)   ;; for each child function
-                          (awhen (funcall (car child-obj) obj) ;; access set of child objects
-                                    (print-hyperobject-class it fmt strm label 
-                                                     (1+ indent) english-only-function
-						     subobjects refvars)))))
-          (fmt-obj-end obj fmt strm indent)))
-      (fmt-list-end (car objs) fmt strm indent nobjs))
-    t))
-
-
-
-(defun print-hyperobject (objs &key (os *standard-output*) (format :text)
-		      (label nil) (english-only-function nil)
-		      (subobjects nil) (file-wrapper t) (refvars nil))
-  "EXPORTED Function: prints hyperobject-class objects. Simplies call to print-hyperobject-class"
-  (let ((fmt (make-format-instance format)))
-    (if file-wrapper
-	(fmt-file-start fmt os))
-    (when objs
-      (print-hyperobject-class objs fmt os label 0 english-only-function subobjects refvars))
-    (if file-wrapper
-	(fmt-file-end fmt os)))
-  objs)
-
-
-(defclass hyperobject ()
-  ()
-  (:metaclass hyperobject-class))
-
-
-(defmethod print-object ((obj hyperobject) (s stream))
-  (print-unreadable-object (obj s :type t :identity t)
-    (let ((fmt (make-instance 'hyperobject::textformat)))
-      (apply #'format 
-	     s (funcall (hyperobject::obj-data-fmtstr fmt) obj)
-	     (multiple-value-list 
-	      (funcall (funcall (hyperobject::obj-data-value-func fmt) obj) obj))))))
+  (slot-value (class-of obj) 'fmtstr-xml-ref-labels))