X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=ml-class.lisp;h=6be17c146cca41866ee0f314f1fb36b13270459b;hb=fd834629ba860f91bda943a94a363a650079dff8;hp=b36905507e566d12699aea3f1a6086b112aafd73;hpb=cf40a72efe98c7a0b5cafba7c3c854879fcfeef2;p=kmrcl.git diff --git a/ml-class.lisp b/ml-class.lisp index b369055..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.6 2002/10/13 17:39:50 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,7 +29,14 @@ #+sbcl (sb-pcl:class-of obj) #+cmu (pcl:class-of obj)) -(defclass ml-class (standard-class) +(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) ((title :initarg :title :type string :reader ml-std-title :documentation "Print Title for class") @@ -66,19 +73,21 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (:documentation "Metaclass for Markup Language classes.")) #+cmu -(defmethod pcl:validate-superclass ((class ml-class) (superclass pcl::standard-class)) - t) +(defmethod pcl:finalize-inheritance :after ((cl ml-class)) + (init-ml-class cl)) + #+sbcl -(defmethod sb-pcl:validate-superclass ((class ml-class) (superclass sb-pcl::standard-class)) - t) +(defmethod sb-pcl:finalize-inheritance :after ((cl ml-class)) + (init-ml-class cl)) + #+cmu -(defmethod pcl:validate-superclass ((class pcl::standard-class) (superclass ml-class)) +(defmethod pcl:validate-superclass ((class ml-class) (superclass pcl::standard-class)) t) #+sbcl -(defmethod sb-pcl:validate-superclass ((class sb-pcl::standard-class) (superclass ml-class)) +(defmethod sb-pcl:validate-superclass ((class ml-class) (superclass sb-pcl::standard-class)) t) #+allegro @@ -89,13 +98,15 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (defmethod clos:finalize-inheritance :after ((cl ml-class)) (init-ml-class cl)) -#+cmu -(defmethod pcl:finalize-inheritance :after ((cl ml-class)) - (init-ml-class cl)) +;;#+cmu +;;(defmethod pcl::class-finalized-p ((cl ml-class)) +;; (and (not (null (slot-value cl 'pcl::wrapper))) +;; (not (null (slot-value cl 'fmtstr-text))))) -#+sbcl -(defmethod sb-pcl:finalize-inheritance :after ((cl ml-class)) - (init-ml-class cl)) +;;#+sbcl +;;(defmethod sb-pcl::class-finalized-p ((cl ml-class)) +;; (and (not (null (slot-value cl 'sb-pcl::wrapper))) +;; (not (null (slot-value cl 'fmtstr-text))))) #+lispworks (defmethod clos:process-a-class-option ((class ml-class) @@ -148,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)) @@ -183,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) @@ -199,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) @@ -209,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) @@ -221,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) @@ -295,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 :start 1))) + (string-downcase (subseq name 1))) (defmethod ml-class-stdname ((cl standard-object)) - (string-downcase (subseq (class-name (ml-class-of cl)) :start 1))) + (string-downcase (subseq (ml-class-name (ml-class-of cl)) 1))) ;;;; Generic Print functions @@ -308,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) @@ -318,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)) @@ -326,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*))) @@ -404,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) () @@ -456,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) @@ -470,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)) @@ -493,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) @@ -504,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)) @@ -512,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)) @@ -522,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\"" @@ -535,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) @@ -550,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 @@ -560,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) @@ -579,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))) @@ -587,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) @@ -603,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 @@ -614,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))