1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: Markup Language Class
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Sep 2002
10 ;;;; This class defines functions for classes to allow display
11 ;;;; in Text, HTML, and XML formats. This includes hyperlinking
12 ;;;; capability and sub-objects. This is a re-write of ml-class.lisp
13 ;;; which used fairly difficult to port metaclass features.
15 ;;;; $Id: ml.lisp,v 1.2 2002/10/13 19:02:35 kevin Exp $
17 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
19 ;;;; KMRCL users are granted the rights to distribute and use this software
20 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
21 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
22 ;;;; *************************************************************************
25 (:use #:kmrcl #:common-lisp))
28 (in-package :kmrcl.ml)
30 (declaim (optimize (speed 3) (safety 1) (debug 3) (compilation-speed 0)))
33 ;;; ml-class hold all formatting information for an object
35 ;;; When a class is definited with the def-ml-class macro, a formatting
36 ;;; object named _<name>-ml-fmt_ is created. Then, when a ml-class object
37 ;;; is to be printed, the formatting object is referenced.
39 (defun initargs-def (fields)
40 (loop for field in fields
41 collect (intern (concatenate 'string ":" (symbol-name (car field))))
44 (defun ml-fmt-name (name)
45 (intern (concatenate 'string "_" (symbol-name name) "-ml-fmt_")))
47 (defun ml-fmt-def (name field-defs title types linked-fields subobjects)
49 (defclass ,(ml-fmt-name name) (ml-fmt-class)
51 (:default-initargs ,@(ml-fmt-initargs name field-defs title types linked-fields subobjects)))
52 (make-instance ,(ml-fmt-name name))))
54 (defmacro def-ml-class (name (parent) field-defs &key title types linked-fields subobjects documentation)
55 (let ((ml-fmt-name (ml-fmt-name name))
56 (ml-fmt-def (ml-fmt-def name field-defs title types linked-fields subobjects))
57 (initargs (initargs-def field-defs)))
61 (defclass ,name (,parent)
63 (:default-initargs ,initargs)
64 ,@(and documentation (list (list :documentation documentation)))
69 (def-ml-class urank (umlsclass)
70 ((rank :type fixnum :initarg :rank :reader rank)
71 (sab :type string :initarg :sab :reader sab)
72 (tty :type string :initarg :tty :reader tty)
73 (supres :type string :initarg :supres :reader supres))
75 :types ((rank :fixnum) (sab :string) (tty :string) (supres :string)))
79 (defclass ml-fmt-class ()
80 ((title :initarg :title :type string :reader title
82 "Print Title for class")
83 (fields :initarg :fields :reader fields
85 "List of field lists for printing. Format is
86 ((fieldname type optional-formatter) ... )")
88 :initarg :subobjects-lists :reader subobjects-lists
90 "List of fields that contain a list of subobjects objects.")
92 :initarg :ref-fields :type list :reader ref-field
94 "List of fields that can be referred to by browsers.
95 Format is ((field-name field-lookup-func other-link-params) ...)")
97 ;;; The remainder of these fields are calculated one time
98 ;;; in finalize-inheritence.
99 (value-func :initform nil :type function :reader value-func)
100 (xmlvalue-func :initform nil :type function :reader xmlvalue-func)
101 (fmtstr-text :initform nil :type string :reader fmtstr-text)
102 (fmtstr-html :initform nil :type string :reader fmtstr-html)
103 (fmtstr-xml :initform nil :type string :reader fmtstr-xml)
104 (fmtstr-text-labels :initform nil :type string :reader fmtstr-text-labels)
105 (fmtstr-html-labels :initform nil :type string :reader fmtstr-html-labels)
106 (fmtstr-xml-labels :initform nil :type string :reader fmtstr-xml-labels)
107 (fmtstr-html-ref :initform nil :type string :reader fmtstr-html-ref)
108 (fmtstr-xml-ref :initform nil :type string :reader fmtstr-xml-ref)
109 (fmtstr-html-ref-labels :initform nil :type string :reader fmtstr-html-ref-labels)
110 (fmtstr-xml-ref-labels :initform nil :type string :reader fmtstr-xml-ref-labels)
112 (:default-initargs :title nil :fields nil :subobjects-lists nil :ref-fields nil)
113 (:documentation "Class for Markup Language formatting objects."))
116 ;;;; Class initialization function
118 (defun ml-fmt-initargs (name field-defs title types linked-fields subobjects)
119 (let ((fmtstr-text "")
122 (fmtstr-text-labels "")
123 (fmtstr-html-labels "")
124 (fmtstr-xml-labels "")
127 (fmtstr-html-ref-labels "")
128 (fmtstr-xml-ref-labels "")
133 (linked-fields linked-fields))
134 (declare (ignore classname))
137 (namestr (symbol-name (car f)))
138 (namestr-lower (string-downcase (symbol-name (car f))))
140 (formatter (caddr f))
142 (plain-value-func nil)
143 html-str xml-str html-label-str xml-label-str)
145 (when (or (eql type :integer) (eql type :fixnum))
146 (setq value-fmt "~d"))
148 (when (eql type :commainteger)
149 (setq value-fmt "~:d"))
151 (when (eql type :boolean)
152 (setq value-fmt "~a"))
155 (setq first-field nil)
157 (string-append fmtstr-text " ")
158 (string-append fmtstr-html " ")
159 (string-append fmtstr-xml " ")
160 (string-append fmtstr-text-labels " ")
161 (string-append fmtstr-html-labels " ")
162 (string-append fmtstr-xml-labels " ")
163 (string-append fmtstr-html-ref " ")
164 (string-append fmtstr-xml-ref " ")
165 (string-append fmtstr-html-ref-labels " ")
166 (string-append fmtstr-xml-ref-labels " ")))
168 (setq html-str value-fmt)
169 (setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "</" namestr-lower ">"))
170 (setq html-label-str (concatenate 'string "<i>" namestr-lower "</i> " value-fmt))
171 (setq xml-label-str (concatenate 'string "<label>" namestr-lower "</label> <" namestr-lower ">" value-fmt "</" namestr-lower ">"))
173 (string-append fmtstr-text value-fmt)
174 (string-append fmtstr-html html-str)
175 (string-append fmtstr-xml xml-str)
176 (string-append fmtstr-text-labels namestr-lower " " value-fmt)
177 (string-append fmtstr-html-labels html-label-str)
178 (string-append fmtstr-xml-labels xml-label-str)
180 (if (find name linked-fields :key #'car)
182 (string-append fmtstr-html-ref "<~~a>" value-fmt "</~~a>")
183 (string-append fmtstr-xml-ref "<~~a>" value-fmt "</~~a>")
184 (string-append fmtstr-html-ref-labels "<i>" namestr-lower "</i> <~~a>" value-fmt "</~~a>")
185 (string-append fmtstr-xml-ref-labels "<label>" namestr-lower "</label> <~~a>" value-fmt "</~~a>"))
187 (string-append fmtstr-html-ref html-str)
188 (string-append fmtstr-xml-ref xml-str)
189 (string-append fmtstr-html-ref-labels html-label-str)
190 (string-append fmtstr-xml-ref-labels xml-label-str)))
193 (setq plain-value-func
194 (list `(,formatter (,(concat-symbol-pkg
195 :umlisp namestr) x))))
196 (setq plain-value-func
197 (list `(,(concat-symbol-pkg
198 :umlisp namestr) x))))
199 (setq value-func (append value-func plain-value-func))
201 (if (eql type :cdata)
202 (setq xmlvalue-func (append xmlvalue-func (list `(xml-cdata ,@plain-value-func))))
203 (setq xmlvalue-func (append xmlvalue-func plain-value-func)))
206 (setq value-func `(lambda (x) (values ,@value-func)))
207 (setq value-func (compile nil (eval value-func)))
208 (setq xmlvalue-func `(lambda (x) (values ,@xmlvalue-func)))
209 (setq xmlvalue-func (compile nil (eval xmlvalue-func)))
212 :fmtstr-text ,fmtstr-text :fmtstr-html ,fmtstr-html
213 :fmtstr-xml ,fmtstr-xml :fmtstr-text-labels ,fmtstr-text-labels
214 :fmtstr-html-labels ,fmtstr-html-labels
215 :fmtstr-xml-labels ,fmtstr-xml-labels
216 :fmtstr-html-ref ,fmtstr-html-ref
217 :fmtstr-xml-ref ,fmtstr-xml-ref
218 :fmtstr-html-ref-labels ,fmtstr-html-ref-labels
219 :fmtstr-xml-ref-labels ,fmtstr-xml-ref-labels
220 :value-func ,value-func
221 :xmlvalue-func ,xmlvalue-func)))
224 (defun %class-of (obj)
225 #-(or cmu sbcl) (class-of obj)
226 #+sbcl (sb-pcl:class-of obj)
227 #+cmu (pcl:class-of obj))
230 (defun ml-class-fmtstr-text (obj)
231 (slot-value (%class-of obj) 'fmtstr-text))
233 (defun ml-class-fmtstr-html (obj)
234 (slot-value (%class-of obj) 'fmtstr-html))
236 (defun ml-class-fmtstr-xml (obj)
237 (slot-value (%class-of obj) 'fmtstr-xml))
239 (defun ml-class-fmtstr-text-labels (obj)
240 (slot-value (%class-of obj) 'fmtstr-text-labels))
242 (defun ml-class-fmtstr-html-labels (obj)
243 (slot-value (%class-of obj) 'fmtstr-html-labels))
245 (defun ml-class-fmtstr-xml-labels (obj)
246 (slot-value (%class-of obj) 'fmtstr-xml-labels))
248 (defun ml-class-value-func (obj)
249 (slot-value (%class-of obj) 'value-func))
251 (defun ml-class-xmlvalue-func (obj)
252 (slot-value (%class-of obj) 'xmlvalue-func))
254 (eval-when (:compile-toplevel :load-toplevel :execute)
255 (defun ml-class-title (obj)
256 (awhen (slot-value (%class-of obj) 'title)
261 (defun ml-class-subobjects-lists (obj)
262 (slot-value (%class-of obj) 'subobjects-lists))
264 (defun ml-class-linked-fields (obj)
265 (slot-value (%class-of obj) 'linked-fields))
267 (defun ml-class-fields (obj)
268 (slot-value (%class-of obj) 'fields))
270 (defun ml-class-fmtstr-html-ref (obj)
271 (slot-value (%class-of obj) 'fmtstr-html-ref))
273 (defun ml-class-fmtstr-xml-ref (obj)
274 (slot-value (%class-of obj) 'fmtstr-xml-ref))
276 (defun ml-class-fmtstr-html-ref-labels (obj)
277 (slot-value (%class-of obj) 'fmtstr-html-ref-labels))
279 (defun ml-class-fmtstr-xml-ref-labels (obj)
280 (slot-value (%class-of obj) 'fmtstr-xml-ref-labels))
282 ;;; Class name functions
284 (defmethod ml-class-stdname ((name string))
285 (string-downcase (subseq name :start 1)))
287 (defmethod ml-class-stdname ((cl standard-object))
288 (string-downcase (subseq (class-name (%class-of cl)) :start 1)))
290 ;;;; Generic Print functions
292 (defparameter *default-textformat* nil)
293 (defparameter *default-htmlformat* nil)
294 (defparameter *default-htmlrefformat* nil)
295 (defparameter *default-xmlformat* nil)
296 (defparameter *default-xmlrefformat* nil)
297 (defparameter *default-nullformat* nil)
298 (defparameter *default-init-format?* nil)
300 (defun make-format-instance (fmt)
301 (unless *default-init-format?*
302 (setq *default-textformat* (make-instance 'textformat))
303 (setq *default-htmlformat* (make-instance 'htmlformat))
304 (setq *default-htmlrefformat* (make-instance 'htmlrefformat))
305 (setq *default-xmlformat* (make-instance 'xmlformat))
306 (setq *default-xmlrefformat* (make-instance 'xmlrefformat))
307 (setq *default-nullformat* (make-instance 'nullformat))
308 (setq *default-init-format?* t))
311 (:text *default-textformat*)
312 (:html *default-htmlformat*)
313 (:htmlref *default-htmlrefformat*)
314 (:xml *default-xmlformat*)
315 (:xmlref *default-xmlrefformat*)
316 (:null *default-nullformat*)
317 (otherwise *default-textformat*)))
319 ;;;; Output format classes for print ml-classes
321 (defclass dataformat ()
322 ((file-start-str :type string :initarg :file-start-str :reader file-start-str)
323 (file-end-str :type string :initarg :file-end-str :reader file-end-str)
324 (list-start-fmtstr :type string :initarg :list-start-fmtstr :reader list-start-fmtstr)
325 (list-start-value-func :type function :initarg :list-start-value-func :reader list-start-value-func)
326 (list-start-indent :initarg :list-start-indent :reader list-start-indent)
327 (list-end-fmtstr :type string :initarg :list-end-fmtstr :reader list-end-fmtstr)
328 (list-end-value-func :type function :initarg :list-end-value-func :reader list-end-value-func)
329 (list-end-indent :initarg :list-end-indent :reader list-end-indent)
330 (obj-start-fmtstr :type string :initarg :obj-start-fmtstr :reader obj-start-fmtstr)
331 (obj-start-value-func :initarg :obj-start-value-func :reader obj-start-value-func)
332 (obj-start-indent :initarg :obj-start-indent :reader obj-start-indent)
333 (obj-end-fmtstr :type string :initarg :obj-end-fmtstr :reader obj-end-fmtstr)
334 (obj-end-value-func :initarg :obj-end-value-func :reader obj-end-value-func)
335 (obj-end-indent :initarg :obj-end-indent :reader obj-end-indent)
336 (obj-data-indent :initarg :obj-data-indent :reader obj-data-indent)
337 (obj-data-fmtstr :initarg :obj-data-fmtstr :reader obj-data-fmtstr)
338 (obj-data-fmtstr-labels :initarg :obj-data-fmtstr-labels :reader obj-data-fmtstr-labels)
339 (obj-data-end-fmtstr :initarg :obj-data-end-fmtstr :reader obj-data-end-fmtstr)
340 (obj-data-value-func :initarg :obj-data-value-func :reader obj-data-value-func)
341 (link-ref :initarg :link-ref :reader link-ref))
342 (:default-initargs :file-start-str nil :file-end-str nil :list-start-fmtstr nil :list-start-value-func nil
343 :list-start-indent nil :list-end-fmtstr nil :list-end-value-func nil :list-end-indent nil
344 :obj-start-fmtstr nil :obj-start-value-func nil :obj-start-indent nil
345 :obj-end-fmtstr nil :obj-end-value-func nil :obj-end-indent nil
346 :obj-data-indent nil :obj-data-fmtstr nil :obj-data-fmtstr-labels nil :obj-data-end-fmtstr nil
347 :obj-data-value-func nil :link-ref nil)
348 (:documentation "Parent for all dataformat objects"))
350 (defclass binaryformat (dataformat)
353 (defclass nullformat (dataformat)
356 (defun text-list-start-value-func (obj nitems)
357 (values (ml-class-title obj) nitems))
359 (defclass textformat (dataformat)
361 (:default-initargs :list-start-fmtstr "~a~P:~%"
362 :list-start-value-func #'text-list-start-value-func
365 :obj-data-fmtstr #'ml-class-fmtstr-text
366 :obj-data-fmtstr-labels #'ml-class-fmtstr-text-labels
367 :obj-data-end-fmtstr "~%"
368 :obj-data-value-func #'ml-class-value-func))
370 (defclass htmlformat (textformat)
372 (:default-initargs :file-start-str "<html><body>~%"
373 :file-end-str "</body><html>~%"
375 :list-start-fmtstr "<p><b>~a~P:</b></p><ul>~%"
376 :list-start-value-func #'text-list-start-value-func
377 :list-end-fmtstr "</ul>~%"
379 :list-end-value-func #'identity
381 :obj-start-fmtstr "<li>"
382 :obj-start-value-func #'identity
384 :obj-end-fmtstr "</li>~%"
385 :obj-end-value-func #'identity
387 :obj-data-fmtstr #'ml-class-fmtstr-html-labels
388 :obj-data-fmtstr-labels #'ml-class-fmtstr-html-labels
389 :obj-data-value-func #'ml-class-value-func))
392 (defun class-name-of (obj)
393 (string-downcase (class-name (%class-of obj))))
395 (defun xmlformat-list-end-value-func (x)
396 (format nil "~alist" (string-downcase (class-name (%class-of x)))))
398 (defun xmlformat-list-start-value-func (x nitems)
399 (values (format nil "~alist" (string-downcase (class-name (%class-of x)))) (ml-class-title x) nitems))
401 (defclass xmlformat (textformat)
403 (:default-initargs :file-start-str "" ; (std-xml-header)
405 :list-start-fmtstr "<~a><title>~a~p:</title> ~%"
406 :list-start-value-func #'xmlformat-list-start-value-func
408 :list-end-fmtstr "</~a>~%"
409 :list-end-value-func #'xmlformat-list-end-value-func
410 :obj-start-fmtstr "<~a>"
411 :obj-start-value-func #'class-name-of
413 :obj-end-fmtstr "</~a>~%"
414 :obj-end-value-func #'class-name-of
417 :obj-data-fmtstr #'ml-class-fmtstr-xml
418 :obj-data-fmtstr-labels #'ml-class-fmtstr-xml-labels
419 :obj-data-value-func #'ml-class-xmlvalue-func))
421 (defclass link-ref ()
422 ((fmtstr :type function :initarg :fmtstr :accessor fmtstr)
423 (fmtstr-labels :type function :initarg :fmtstr-labels :accessor fmtstr-labels)
424 (page-name :type string :initarg :page-name :accessor page-name)
425 (href-head :type string :initarg :href-head :accessor href-head)
426 (href-end :type string :initarg :href-end :accessor href-end)
427 (ampersand :type string :initarg :ampersand :accessor ampersand))
428 (:default-initargs :fmtstr nil
430 :page-name "disp-func1"
431 :href-head nil :href-end nil :ampersand nil)
432 (:documentation "Formatting for a linked reference"))
434 (defclass html-link-ref (link-ref)
436 (:default-initargs :fmtstr #'ml-class-fmtstr-html-ref
437 :fmtstr-labels #'ml-class-fmtstr-html-ref-labels
442 (defclass xml-link-ref (link-ref)
444 (:default-initargs :fmtstr #'ml-class-fmtstr-xml-ref
445 :fmtstr-labels #'ml-class-fmtstr-xml-ref-labels
446 :href-head "xmllink xlink:type=\"simple\" xlink:href="
451 (defclass htmlrefformat (htmlformat)
453 (:default-initargs :link-ref (make-instance 'html-link-ref)))
455 (defclass xmlrefformat (xmlformat)
457 (:default-initargs :link-ref (make-instance 'xml-link-ref)))
460 ;;; File Start and Ends
462 (defmethod fmt-file-start ((fmt dataformat) (s stream)))
464 (defmethod fmt-file-start ((fmt textformat) (s stream))
465 (aif (file-start-str fmt)
468 (defmethod fmt-file-end ((fmt textformat) (s stream))
469 (aif (file-end-str fmt)
472 ;;; List Start and Ends
474 (defmethod fmt-list-start (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1))
475 (if (list-start-indent fmt)
476 (indent-spaces indent s))
477 (aif (list-start-fmtstr fmt)
480 (funcall (list-start-value-func fmt) x num-items)))))
482 (defmethod fmt-list-end (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1))
483 (declare (ignore num-items))
484 (if (list-end-indent fmt)
485 (indent-spaces indent s))
486 (aif (list-end-fmtstr fmt)
489 (funcall (list-end-value-func fmt) x)))))
491 ;;; Object Start and Ends
493 (defmethod fmt-obj-start (x (fmt textformat) (s stream) &optional (indent 0))
494 (if (obj-start-indent fmt)
495 (indent-spaces indent s))
496 (aif (obj-start-fmtstr fmt)
499 (funcall (obj-start-value-func fmt) x)))))
501 (defmethod fmt-obj-end (x (fmt textformat) (s stream) &optional (indent 0))
502 (if (obj-end-indent fmt)
503 (indent-spaces indent s))
504 (aif (obj-end-fmtstr fmt)
507 (funcall (obj-end-value-func fmt) x)))))
511 (defmethod make-link-start (obj (ref link-ref) fieldname fieldfunc fieldvalue refvars)
512 (declare (ignore obj fieldname))
513 (format nil "~a\"~a?func=~a~akey=~a~a\""
514 (href-head ref) (make-url (page-name ref)) fieldfunc
515 (ampersand ref) fieldvalue
518 (dolist (var refvars)
519 (string-append varstr (format nil "~a~a=~a"
520 (ampersand ref) (car var) (cadr var))))
524 (defmethod make-link-end (obj (ref link-ref) fieldname)
525 (declare (ignore obj fieldname))
526 (format nil "~a" (href-end ref))
529 (defmethod fmt-obj-data (x (fmt textformat) s
530 &optional (indent 0) (label nil) (refvars nil))
531 (if (obj-data-indent fmt)
532 (indent-spaces indent s))
534 (fmt-obj-data-with-ref x fmt s label refvars)
535 (fmt-obj-data-plain x fmt s label))
536 (aif (obj-data-end-fmtstr fmt)
539 (defmethod fmt-obj-data-plain (x (fmt textformat) s label)
542 (funcall (obj-data-fmtstr-labels fmt) x)
544 (funcall (funcall (obj-data-value-func fmt) x) x)))
545 (apply #'format s (funcall (obj-data-fmtstr fmt) x)
547 (funcall (funcall (obj-data-value-func fmt) x) x)))))
549 (defmethod fmt-obj-data-with-ref (x (fmt textformat) s label refvars)
550 (let ((refstr (make-ref-data-str x fmt label))
554 (funcall (funcall (obj-data-value-func fmt) x) x))))
556 ;; make list of reference link fields for printing to refstr template
557 (dolist (field (ml-class-linked-fields x))
559 (make-link-start x (link-ref fmt) (car field) (cadr field)
560 (nth (position (car field) (ml-class-fields x) :key #'car) field-values)
561 (append (caddr field) refvars)))
562 (link-end (make-link-end x (link-ref fmt) (car field))))
563 (push link-start refvalues)
564 (push link-end refvalues)))
565 (setq refvalues (nreverse refvalues))
567 (apply #'format s refstr refvalues)))
569 (defmethod obj-data (x)
570 "Returns the objects data as a string. Used by common-graphics outline function"
571 (let ((fmt (make-format-instance :text)))
572 (apply #'format nil (funcall (obj-data-fmtstr fmt) x)
574 (funcall (funcall (obj-data-value-func fmt) x) x)))))
576 (defmethod make-ref-data-str (x (fmt textformat) &optional (label nil))
577 "Return fmt string for that contains ~a slots for reference link start and end"
578 (unless (link-ref fmt)
579 (error "fmt does not contain a link-ref"))
582 (apply #'format nil (funcall (fmtstr-labels (link-ref fmt)) x)
584 (funcall (funcall (obj-data-value-func fmt) x) x)))
585 (apply #'format nil (funcall (fmtstr (link-ref fmt)) x)
586 (multiple-value-list (funcall (funcall (obj-data-value-func fmt) x) x))))))
589 ;;; Display method for objects
592 (defmethod load-all-subobjects (objs)
593 "Load all subobjects if they have not already been loaded."
595 (let ((objlist (mklist objs)))
596 (dolist (obj objlist)
597 (awhen (ml-class-subobjects-lists obj) ;; access list of functions
598 (dolist (child-obj it) ;; for each child function
599 (awhen (funcall (car child-obj) obj)
600 (load-all-subobjects it))))))
603 (defmethod output-ml-class (objs (fmt dataformat) (strm stream)
604 &optional (label nil) (english-only-function nil)
605 (indent 0) (subobjects nil) (refvars nil))
606 "Display a single or list of ml-class instances and their subobjects"
608 (setq objs (mklist objs))
609 (let ((nobjs (length objs)))
610 (fmt-list-start (car objs) fmt strm indent nobjs)
612 (unless (and english-only-function (not (funcall english-only-function obj)))
613 (fmt-obj-start obj fmt strm indent)
614 (fmt-obj-data obj fmt strm (1+ indent) label refvars)
616 (awhen (ml-class-subobjects-lists obj) ;; access list of functions
617 (dolist (child-obj it) ;; for each child function
618 (awhen (funcall (car child-obj) obj) ;; access set of child objects
619 (output-ml-class it fmt strm label
620 english-only-function
621 (1+ indent) subobjects refvars)))))
622 (fmt-obj-end obj fmt strm indent)))
623 (fmt-list-end (car objs) fmt strm indent nobjs))
626 (defun display-ml-class (objs &key (os *standard-output*) (format :text)
627 (label nil) (english-only-function nil) (subobjects nil)
628 (file-wrapper t) (refvars nil))
629 "EXPORTED Function: displays a ml-class. Simplies call to output-ml-class"
630 (let ((fmt (make-format-instance format)))
632 (fmt-file-start fmt os))
634 (output-ml-class objs fmt os label english-only-function 0 subobjects refvars))
636 (fmt-file-end fmt os)))