From: Kevin M. Rosenberg Date: Mon, 14 Oct 2002 15:25:15 +0000 (+0000) Subject: r3019: *** empty log message *** X-Git-Tag: v1.96~324 X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=commitdiff_plain;h=c555c542d6703f47ed6140955dd9e92471422859 r3019: *** empty log message *** --- diff --git a/debian/changelog b/debian/changelog index 5703dd9..3f9903a 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +cl-kmrcl (1.8-1) unstable; urgency=low + + * ml-class.lisp: Add defgeneric for generic functions + + -- Kevin M. Rosenberg Mon, 14 Oct 2002 09:11:08 -0600 + cl-kmrcl (1.7-1) unstable; urgency=low * Push :kmrcl onto features diff --git a/ml-class.lisp b/ml-class.lisp index f32a974..bab9ca6 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.9 2002/10/14 15:01:17 kevin Exp $ +;;;; $Id: ml-class.lisp,v 1.10 2002/10/14 15:25:11 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -227,9 +227,14 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (setq xmlvalue-func (append xmlvalue-func plain-value-func))) )) - (setq value-func `(lambda () (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 () (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,6 +306,7 @@ 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))) @@ -479,18 +485,21 @@ Format is ((field-name field-lookup-func other-link-params) ...)") ;;; 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 +508,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 +520,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 +529,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 +540,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 +554,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 +571,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 +582,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 +602,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 +611,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 +628,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 +640,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))