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

diff --git a/hyperobject.lisp b/hyperobject.lisp
index 454e57f..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.11 2002/11/23 22:19:17 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
 ;;;;
@@ -22,69 +22,55 @@
 (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))
 
-(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)
-#+(or cmu scl)
-`(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)
-
-;; Slot definitions
-
-
-(defclass hyperobject-dsd (standard-direct-slot-definition)
-  ((ho-type :initarg :ho-type :initform nil :accessor dsd-ho-type)
-   (print-formatter :initarg :print-formatter :initform nil :accessor dsd-print-formatter)
-   (subobject :initarg :subobject :initform nil :accessor dsd-subobject)
-   (reference :initarg :reference :initform nil :accessor dsd-reference)
-   ))
-
-(defclass hyperobject-esd (standard-effective-slot-definition)
-  ((ho-type :initarg :ho-type :initform nil :accessor esd-ho-type)
-   (print-formatter :initarg :print-formatter :initform nil :accessor esd-print-formatter)
-   (subobject :initarg :subobject :initform nil :accessor esd-subobject)
-   (reference :initarg :reference :initform nil :accessor esd-reference)
-  ))
 
 ;; Main class
 
 (defclass hyperobject-class (standard-class)
-  ((title :initarg :title :type string :initform nil
+  ( ;; 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")
-   (subobjects
-    :initarg :subobjects :initform nil
-    :documentation "List of fields that contain a list of subobjects objects.")
-   (references
-    :initarg :references :type list :initform nil
-    :documentation 
-    "List of fields that can be referred to by browsers. 
-Format is ((field-name field-lookup-func other-link-params) ...)")
-   
+		: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.
+   
+   (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)
@@ -127,44 +113,81 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
 
 ;; Slot definitions
 (defmethod direct-slot-definition-class ((cl hyperobject-class) 
-					      &rest iargs)
+					 #+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))
+  )
+
+(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))
+  )
 
+(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)
+  ))
 
-#+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 :print-slots))
-					value)
-  (if (null (cdr value))
-      (list name (car value))
-      (list name `',value)))
 
 (defmethod compute-effective-slot-definition :around
-    ((cl hyperobject-class) #+(or allegro lispworks) slot dsds)
-  (declare (ignorable slot))
+    ((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 slot dsds)))
+	       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)))
   )
 
@@ -190,72 +213,98 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
 
 (defun find-slot-by-name (cl name)
   (find name (class-slots cl) :key #'slot-definition-name))
-		
-(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 (class-name cl)))
-	  (references nil)
-	  (subobjects nil))
-      (declare (ignore classname))
+
+
+(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)))
+					 (esd-subobject slot)))
 		subobjects)))
-      (setf (slot-value cl 'subobjects) subobjects)
-      (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)
-	      
-	      (when (or (eql type :integer) (eql type :fixnum))
-		(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 " ")))
-	      
-	      (setq html-str (concatenate 'string "<span class=\"" namestr-lower "\">" value-fmt "</span>"))
-	      (setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "</" namestr-lower ">"))
-	      (setq html-label-str (concatenate 'string "<span class=\"label\">" namestr-lower "</span> <span class=\"" namestr-lower "\">" value-fmt "</span>"))
-	      (setq xml-label-str (concatenate 'string "<label>" namestr-lower "</label> <" namestr-lower ">" value-fmt "</" namestr-lower ">"))
-	      
+      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)
+	  
+	  (when (or (eql type :integer) (eql type :fixnum))
+	    (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 " ")))
+	  
+	  (setq html-str (concatenate 'string "<span class=\"" namestr-lower "\">" value-fmt "</span>"))
+	  (setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "</" namestr-lower ">"))
+	  (setq html-label-str (concatenate 'string "<span class=\"label\">" namestr-lower "</span> <span class=\"" namestr-lower "\">" value-fmt "</span>"))
+	  (setq xml-label-str (concatenate 'string "<label>" namestr-lower "</label> <" namestr-lower ">" value-fmt "</" namestr-lower ">"))
+	  
 	  (string-append fmtstr-text value-fmt)
 	  (string-append fmtstr-html html-str)
 	  (string-append fmtstr-xml xml-str)
@@ -288,33 +337,38 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
 	      (setq xmlvalue-func (append xmlvalue-func (list `(xml-cdata ,@plain-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)))
+    
+    (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 (class-of obj) 'fmtstr-text))
@@ -368,450 +422,3 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
 (defun hyperobject-class-fmtstr-xml-ref-labels (obj)
   (slot-value (class-of obj) 'fmtstr-xml-ref-labels))
 
-;;;; 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 (class-name (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 (ref (hyperobject-class-references x))
-      (let ((link-start 
-	     (make-link-start x (link-ref fmt) (name ref) (lookup ref)
-			      (nth (position (name ref)
-					     (hyperobject-class-fields x)
-					     :key #'(lambda (x)
-						      (slot-definition-name x)))
-				   field-values)  
-			      (append (link-parameters ref) refvars)))
-	    (link-end (make-link-end x (link-ref fmt) (name ref))))
-	(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 obj)  ;; access list of functions
-          (dolist (child-obj it)   ;; for each child function
-            (awhen (funcall (reader 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 obj)  ;; access list of functions
-                        (dolist (child-obj it)   ;; for each child function
-                          (awhen (funcall (reader 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 (obj-data-fmtstr fmt) obj)
-	     (multiple-value-list 
-	      (funcall (funcall (obj-data-value-func fmt) obj) obj))))))
-