;;;; in Text, HTML, and XML formats. This includes hyperlinking
;;;; capability and sub-objects.
;;;;
-;;;; $Id: ml-class.lisp,v 1.10 2002/10/14 15:25:11 kevin Exp $
+;;;; $Id: ml-class.lisp,v 1.12 2002/10/14 20:55:12 kevin Exp $
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
#+sbcl (sb-pcl:class-of obj)
#+cmu (pcl:class-of obj))
+(defun ml-class-name (obj)
+ #-(or cmu sbcl) (class-name obj)
+ #+sbcl (sb-pcl:class-name obj)
+ #+cmu (pcl:class-name obj))
+
(defclass ml-class (#-(or cmu sbcl) standard-class
#+cmu pcl::standard-class
#+sbcl sb-pcl::standard-class)
(value-func '())
(xmlvalue-func '())
(classname (class-name cl))
+ (package (symbol-package (ml-class-name cl)))
(ref-fields (slot-value cl 'ref-fields)))
(declare (ignore classname))
(dolist (f (slot-value cl 'fields))
(if formatter
(setq plain-value-func
- (list `(,formatter (,(concat-symbol-pkg
- :umlisp namestr) x))))
+ (list `(,formatter (,(intern namestr package) x))))
(setq plain-value-func
- (list `(,(concat-symbol-pkg
- :umlisp namestr) x))))
+ (list `(,(intern namestr package) x))))
(setq value-func (append value-func plain-value-func))
(if (eql type :cdata)
(string-downcase (subseq name 1)))
(defmethod ml-class-stdname ((cl standard-object))
- (string-downcase (subseq (class-name (ml-class-of cl)) 1)))
+ (string-downcase (subseq (ml-class-name (ml-class-of cl)) 1)))
;;;; Generic Print functions
(defun class-name-of (obj)
- (string-downcase (class-name (ml-class-of obj))))
+ (string-downcase (ml-class-name (ml-class-of obj))))
(defun xmlformat-list-end-value-func (x)
- (format nil "~alist" (string-downcase (class-name (ml-class-of x)))))
+ (format nil "~alist" (string-downcase (ml-class-name (ml-class-of x)))))
(defun xmlformat-list-start-value-func (x nitems)
- (values (format nil "~alist" (string-downcase (class-name (ml-class-of x)))) (ml-class-title x) nitems))
+ (values (format nil "~alist" (string-downcase (ml-class-name (ml-class-of x)))) (ml-class-title x) nitems))
(defclass xmlformat (textformat)
()