From: Kevin M. Rosenberg Date: Sun, 13 Oct 2002 19:02:35 +0000 (+0000) Subject: r2992: *** empty log message *** X-Git-Tag: v1.96~329 X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=commitdiff_plain;h=fa5bcb8e115b595b8d277bd1cd4f5daa4e776397 r2992: *** empty log message *** --- diff --git a/ml.lisp b/ml.lisp index ebfd76c..4d854bd 100644 --- a/ml.lisp +++ b/ml.lisp @@ -2,16 +2,17 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Name: ml-class.lisp -;;;; Purpose: Markup Language Metaclass +;;;; Name: ml.lisp +;;;; Purpose: Markup Language Class ;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Apr 2000 +;;;; Date Started: Sep 2002 ;;;; -;;;; This metaclass as functions to classes to allow display +;;;; This class defines functions for classes to allow display ;;;; in Text, HTML, and XML formats. This includes hyperlinking -;;;; capability and sub-objects. +;;;; capability and sub-objects. This is a re-write of ml-class.lisp +;;; which used fairly difficult to port metaclass features. ;;;; -;;;; $Id: ml.lisp,v 1.1 2002/10/13 17:39:50 kevin Exp $ +;;;; $Id: ml.lisp,v 1.2 2002/10/13 19:02:35 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -19,8 +20,12 @@ ;;;; as governed by the terms of the Lisp Lesser GNU Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* - -(in-package :kmrcl) + +(defpackage :kmrcl.ml + (:use #:kmrcl #:common-lisp)) + + +(in-package :kmrcl.ml) (declaim (optimize (speed 3) (safety 1) (debug 3) (compilation-speed 0))) @@ -31,28 +36,47 @@ ;;; object named _-ml-fmt_ is created. Then, when a ml-class object ;;; is to be printed, the formatting object is referenced. -(defmacro def-ml-class (name (parent) field-defs &key title types linked-fields subobjects documentaton) - (let ((ml-fmt-def ,(ml-fmt-def name field-defs title types linked-fields subobjects)) - (initargs (initargs-def field-defs))) - `(progn - ,ml-fmt-def - - (defclass ,name (,parent) - ,field-defs - (:default-initargs ,initargs) - @,(and documentation '((:documentation ,documentation)))) - ) +(defun initargs-def (fields) + (loop for field in fields + collect (intern (concatenate 'string ":" (symbol-name (car field)))) + collect nil)) + +(defun ml-fmt-name (name) + (intern (concatenate 'string "_" (symbol-name name) "-ml-fmt_"))) - (def-ml-class urank (umlsclass) +(defun ml-fmt-def (name field-defs title types linked-fields subobjects) + `(progn + (defclass ,(ml-fmt-name name) (ml-fmt-class) + () + (:default-initargs ,@(ml-fmt-initargs name field-defs title types linked-fields subobjects))) + (make-instance ,(ml-fmt-name name)))) + +(defmacro def-ml-class (name (parent) field-defs &key title types linked-fields subobjects documentation) + (let ((ml-fmt-name (ml-fmt-name name)) + (ml-fmt-def (ml-fmt-def name field-defs title types linked-fields subobjects)) + (initargs (initargs-def field-defs))) + `(progn + ,ml-fmt-def + + (defclass ,name (,parent) + ,field-defs + (:default-initargs ,initargs) + ,@(and documentation (list (list :documentation documentation))) + ) + ))) + +#+ignore +(def-ml-class urank (umlsclass) ((rank :type fixnum :initarg :rank :reader rank) (sab :type string :initarg :sab :reader sab) (tty :type string :initarg :tty :reader tty) (supres :type string :initarg :supres :reader supres)) :title "Rank" - :types (rank :fixnum) (sab :string) (tty :string) (supres :string)) + :types ((rank :fixnum) (sab :string) (tty :string) (supres :string))) + -(defclass ml-class () +(defclass ml-fmt-class () ((title :initarg :title :type string :reader title :documentation "Print Title for class") @@ -86,117 +110,116 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (fmtstr-xml-ref-labels :initform nil :type string :reader fmtstr-xml-ref-labels) ) (:default-initargs :title nil :fields nil :subobjects-lists nil :ref-fields nil) - (:documentation "Metaclass for Markup Language classes.")) + (:documentation "Class for Markup Language formatting objects.")) ;;;; Class initialization function - -(defun init-ml-class-fmt (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)) - (ref-fields (slot-value cl 'ref-fields))) - (declare (ignore classname)) - (dolist (f (slot-value cl 'fields)) - (let ((name (car f)) - (namestr (symbol-name (car f))) - (namestr-lower (string-downcase (symbol-name (car f)))) - (type (cadr f)) - (formatter (caddr f)) - (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 :commainteger) - (setq value-fmt "~:d")) + +(defun ml-fmt-initargs (name field-defs title types linked-fields subobjects) + (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 name) + (linked-fields linked-fields)) + (declare (ignore classname)) + (dolist (f fields) + (let ((name (car f)) + (namestr (symbol-name (car f))) + (namestr-lower (string-downcase (symbol-name (car f)))) + (type (cadr f)) + (formatter (caddr f)) + (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 :commainteger) + (setq value-fmt "~:d")) - (when (eql type :boolean) - (setq value-fmt "~a")) - - (if first-field + (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 value-fmt) - (setq xml-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) - (string-append fmtstr-html html-str) - (string-append fmtstr-xml xml-str) - (string-append fmtstr-text-labels namestr-lower " " value-fmt) - (string-append fmtstr-html-labels html-label-str) - (string-append fmtstr-xml-labels xml-label-str) - - (if (find name ref-fields :key #'car) + (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 value-fmt) + (setq xml-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) + (string-append fmtstr-html html-str) + (string-append fmtstr-xml xml-str) + (string-append fmtstr-text-labels namestr-lower " " value-fmt) + (string-append fmtstr-html-labels html-label-str) + (string-append fmtstr-xml-labels xml-label-str) + + (if (find name linked-fields :key #'car) (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-xml-ref-labels " <~~a>" value-fmt "")) - (progn - (string-append fmtstr-html-ref html-str) - (string-append fmtstr-xml-ref xml-str) - (string-append fmtstr-html-ref-labels html-label-str) - (string-append fmtstr-xml-ref-labels xml-label-str))) - - (if formatter - (setq plain-value-func - (list `(,formatter (,(concat-symbol-pkg - :umlisp namestr) x)))) + (progn + (string-append fmtstr-html-ref html-str) + (string-append fmtstr-xml-ref xml-str) + (string-append fmtstr-html-ref-labels html-label-str) + (string-append fmtstr-xml-ref-labels xml-label-str))) + + (if formatter (setq plain-value-func - (list `(,(concat-symbol-pkg - :umlisp namestr) x)))) - (setq value-func (append value-func plain-value-func)) - - (if (eql type :cdata) - (setq xmlvalue-func (append xmlvalue-func (list `(xml-cdata ,@plain-value-func)))) - (setq xmlvalue-func (append xmlvalue-func plain-value-func))) - )) - + (list `(,formatter (,(concat-symbol-pkg + :umlisp namestr) x)))) + (setq plain-value-func + (list `(,(concat-symbol-pkg + :umlisp namestr) x)))) + (setq value-func (append value-func plain-value-func)) + + (if (eql type :cdata) + (setq xmlvalue-func (append xmlvalue-func (list `(xml-cdata ,@plain-value-func)))) + (setq xmlvalue-func (append xmlvalue-func plain-value-func))) + )) + (setq value-func `(lambda (x) (values ,@value-func))) (setq value-func (compile nil (eval value-func))) (setq xmlvalue-func `(lambda (x) (values ,@xmlvalue-func))) (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)) + `(:title ,title + :fmtstr-text ,fmtstr-text :fmtstr-html ,fmtstr-html + :fmtstr-xml ,fmtstr-xml :fmtstr-text-labels ,fmtstr-text-labels + :fmtstr-html-labels ,fmtstr-html-labels + :fmtstr-xml-labels ,fmtstr-xml-labels + :fmtstr-html-ref ,fmtstr-html-ref + :fmtstr-xml-ref ,fmtstr-xml-ref + :fmtstr-html-ref-labels ,fmtstr-html-ref-labels + :fmtstr-xml-ref-labels ,fmtstr-xml-ref-labels + :value-func ,value-func + :xmlvalue-func ,xmlvalue-func))) + (defun %class-of (obj) #-(or cmu sbcl) (class-of obj) @@ -238,8 +261,8 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (defun ml-class-subobjects-lists (obj) (slot-value (%class-of obj) 'subobjects-lists)) -(defun ml-class-ref-fields (obj) - (slot-value (%class-of obj) 'ref-fields)) +(defun ml-class-linked-fields (obj) + (slot-value (%class-of obj) 'linked-fields)) (defun ml-class-fields (obj) (slot-value (%class-of obj) 'fields)) @@ -531,7 +554,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (funcall (funcall (obj-data-value-func fmt) x) x)))) ;; make list of reference link fields for printing to refstr template - (dolist (field (ml-class-ref-fields x)) + (dolist (field (ml-class-linked-fields x)) (let ((link-start (make-link-start x (link-ref fmt) (car field) (cadr field) (nth (position (car field) (ml-class-fields x) :key #'car) field-values)