X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=ml-class.lisp;h=6be17c146cca41866ee0f314f1fb36b13270459b;hb=fd834629ba860f91bda943a94a363a650079dff8;hp=ab41de8463afc67f436e4d06bdb974911b3f4f52;hpb=2993ec50b4caae9675631edc03b5298610a67372;p=kmrcl.git diff --git a/ml-class.lisp b/ml-class.lisp index ab41de8..6be17c1 100644 --- a/ml-class.lisp +++ b/ml-class.lisp @@ -11,7 +11,7 @@ ;;;; in Text, HTML, and XML formats. This includes hyperlinking ;;;; capability and sub-objects. ;;;; -;;;; $Id: ml-class.lisp,v 1.8 2002/10/14 07:07:30 kevin Exp $ +;;;; $Id: ml-class.lisp,v 1.15 2002/10/16 16:18:27 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -29,6 +29,11 @@ #+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) @@ -154,6 +159,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (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)) @@ -189,9 +195,9 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (string-append fmtstr-html-ref-labels " ") (string-append fmtstr-xml-ref-labels " "))) - (setq html-str value-fmt) + (setq html-str (concatenate 'string "" value-fmt "")) (setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "")) - (setq html-label-str (concatenate 'string "" namestr-lower " " value-fmt)) + (setq html-label-str (concatenate 'string "" namestr-lower " " value-fmt)) (setq xml-label-str (concatenate 'string " <" namestr-lower ">" value-fmt "")) (string-append fmtstr-text value-fmt) @@ -205,7 +211,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (progn (string-append fmtstr-html-ref "<~~a>" value-fmt "") (string-append fmtstr-xml-ref "<~~a>" value-fmt "") - (string-append fmtstr-html-ref-labels "" namestr-lower " <~~a>" value-fmt "") + (string-append fmtstr-html-ref-labels "" namestr-lower " <~~a>" value-fmt "") (string-append fmtstr-xml-ref-labels " <~~a>" value-fmt "")) (progn (string-append fmtstr-html-ref html-str) @@ -215,11 +221,9 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (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) @@ -227,9 +231,14 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (setq xmlvalue-func (append xmlvalue-func plain-value-func))) )) - (setq value-func `(lambda (x) (values ,@value-func))) + (if value-func + (setq value-func `(lambda (x) (values ,@value-func))) + (setq value-func `(lambda () (values)))) (setq value-func (compile nil (eval value-func))) - (setq xmlvalue-func `(lambda (x) (values ,@xmlvalue-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) @@ -301,11 +310,12 @@ Format is ((field-name field-lookup-func other-link-params) ...)") ;;; Class name functions +(defgeneric ml-class-stdname (x)) (defmethod ml-class-stdname ((name string)) (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 @@ -314,6 +324,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (defparameter *default-htmlrefformat* nil) (defparameter *default-xmlformat* nil) (defparameter *default-xmlrefformat* nil) +(defparameter *default-ie-xmlrefformat* nil) (defparameter *default-nullformat* nil) (defparameter *default-init-format?* nil) @@ -324,6 +335,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (setq *default-htmlrefformat* (make-instance 'htmlrefformat)) (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)) @@ -332,7 +344,9 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (:html *default-htmlformat*) (:htmlref *default-htmlrefformat*) (:xml *default-xmlformat*) + (:xml *default-xmlformat*) (:xmlref *default-xmlrefformat*) + (:ie-xmlref *default-ie-xmlrefformat*) (:null *default-nullformat*) (otherwise *default-textformat*))) @@ -410,13 +424,13 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (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) () @@ -462,10 +476,17 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (defclass xml-link-ref (link-ref) () (:default-initargs :fmtstr #'ml-class-fmtstr-xml-ref - :fmtstr-labels #'ml-class-fmtstr-xml-ref-labels - :href-head "xmllink xlink:type=\"simple\" xlink:href=" - :href-end "xmllink" - :ampersand "&")) + :fmtstr-labels #'ml-class-fmtstr-xml-ref-labels + :href-head "xmllink xlink:type=\"simple\" xlink:href=" + :href-end "xmllink" + :ampersand "&") + (: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) @@ -476,21 +497,28 @@ Format is ((field-name field-lookup-func other-link-params) ...)") () (: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)) @@ -499,6 +527,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (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) @@ -510,6 +539,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") ;;; 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)) @@ -518,6 +548,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (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)) @@ -528,6 +559,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") ;;; 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\"" @@ -541,11 +573,13 @@ Format is ((field-name field-lookup-func other-link-params) ...)") 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) @@ -556,6 +590,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (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 @@ -566,6 +601,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (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) @@ -585,7 +621,8 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (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))) @@ -593,6 +630,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (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) @@ -609,6 +647,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") ;;; 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 @@ -620,6 +659,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (load-all-subobjects it)))))) objs)) +(defgeneric output-ml-class (objs fmt strm &optional label english-only-function indent subobjects refvars)) (defmethod output-ml-class (objs (fmt dataformat) (strm stream) &optional (label nil) (english-only-function nil) (indent 0) (subobjects nil) (refvars nil))