1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: ml-class.lisp
6 ;;;; Purpose: Markup Language Metaclass
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Apr 2000
10 ;;;; This metaclass as functions to classes to allow display
11 ;;;; in Text, HTML, and XML formats. This includes hyperlinking
12 ;;;; capability and sub-objects.
14 ;;;; $Id: ml-class.lisp,v 1.3 2002/10/06 13:35:30 kevin Exp $
16 ;;;; This file, part of Kmrcl, is Copyright (c) 2002 by Kevin M. Rosenberg
18 ;;;; Kmrcl users are granted the rights to distribute and use this software
19 ;;;; as governed by the terms of the GNU General Public License.
20 ;;;; *************************************************************************
24 (declaim (optimize (speed 3) (safety 1)))
27 (defclass ml-class (standard-class)
28 ((title :initarg :title :type string :reader ml-std-title
30 "Print Title for class")
31 (fields :initarg :fields :reader ml-std-fields
33 "List of field lists for printing. Format is
34 ((fieldname type optional-formatter) ... )")
36 :initarg :subobjects-lists :reader ml-std-subobjects-lists
38 "List of fields that contain a list of subobjects objects.")
40 :initarg :ref-fields :type list :reader ml-std-ref-field
42 "List of fields that can be referred to by browsers.
43 Format is ((field-name field-lookup-func other-link-params) ...)")
45 ;;; The remainder of these fields are calculated one time
46 ;;; in finalize-inheritence.
47 (value-func :initform nil :type function :reader ml-std-value-func)
48 (xmlvalue-func :initform nil :type function :reader ml-std-xmlvalue-func)
49 (fmtstr-text :initform nil :type string :reader ml-std-fmtstr-text)
50 (fmtstr-html :initform nil :type string :reader ml-std-fmtstr-html)
51 (fmtstr-xml :initform nil :type string :reader ml-std-fmtstr-xml)
52 (fmtstr-text-labels :initform nil :type string :reader ml-std-fmtstr-text-labels)
53 (fmtstr-html-labels :initform nil :type string :reader ml-std-fmtstr-html-labels)
54 (fmtstr-xml-labels :initform nil :type string :reader ml-std-fmtstr-xml-labels)
55 (fmtstr-html-ref :initform nil :type string :reader ml-std-fmtstr-html-ref)
56 (fmtstr-xml-ref :initform nil :type string :reader ml-std-fmtstr-xml-ref)
57 (fmtstr-html-ref-labels :initform nil :type string :reader ml-std-fmtstr-html-ref-labels)
58 (fmtstr-xml-ref-labels :initform nil :type string :reader ml-std-fmtstr-xml-ref-labels)
60 (:default-initargs :title nil :fields nil :subobjects-lists nil :ref-fields nil)
61 (:documentation "Metaclass for Markup Language classes."))
65 (defmethod mop:finalize-inheritance :after ((cl ml-class))
69 (defmethod clos:finalize-inheritance :after ((cl ml-class))
73 (defmethod pcl:finalize-inheritance :after ((cl ml-class))
77 (defmethod clos:process-a-class-option ((class ml-class)
81 (error "ml-class title must have a value"))
82 (if (null (cdr value))
83 (list name (car value))
84 (list name `',value)))
87 (defmethod clos:process-a-class-option ((class ml-class)
91 (error "ml-class fields must have a value"))
95 (defmethod clos:process-a-class-option ((class ml-class)
96 (name (eql :ref-fields))
99 (error "ml-class ref-fields must have a value"))
100 (list name `',value))
103 (defmethod clos:process-a-class-option ((class ml-class)
104 (name (eql :subobjects-lists))
107 (error "ml-class subobjects-lists must have a value"))
108 (list name `',value))
110 ;;;; Class initialization function
112 (defun init-ml-class (cl)
113 (let ((fmtstr-text "")
116 (fmtstr-text-labels "")
117 (fmtstr-html-labels "")
118 (fmtstr-xml-labels "")
121 (fmtstr-html-ref-labels "")
122 (fmtstr-xml-ref-labels "")
126 (classname (class-name cl))
127 (ref-fields (slot-value cl 'ref-fields)))
128 (declare (ignore classname))
129 (dolist (f (slot-value cl 'fields))
131 (namestr (symbol-name (car f)))
132 (namestr-lower (string-downcase (symbol-name (car f))))
134 (formatter (caddr f))
136 (plain-value-func nil)
137 html-str xml-str html-label-str xml-label-str)
139 (when (or (eql type :integer) (eql type :fixnum))
140 (setq value-fmt "~d"))
142 (when (eql type :commainteger)
143 (setq value-fmt "~:d"))
145 (when (eql type :boolean)
146 (setq value-fmt "~a"))
149 (setq first-field nil)
151 (string-append fmtstr-text " ")
152 (string-append fmtstr-html " ")
153 (string-append fmtstr-xml " ")
154 (string-append fmtstr-text-labels " ")
155 (string-append fmtstr-html-labels " ")
156 (string-append fmtstr-xml-labels " ")
157 (string-append fmtstr-html-ref " ")
158 (string-append fmtstr-xml-ref " ")
159 (string-append fmtstr-html-ref-labels " ")
160 (string-append fmtstr-xml-ref-labels " ")))
162 (setq html-str value-fmt)
163 (setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "</" namestr-lower ">"))
164 (setq html-label-str (concatenate 'string "<i>" namestr-lower "</i> " value-fmt))
165 (setq xml-label-str (concatenate 'string "<label>" namestr-lower "</label> <" namestr-lower ">" value-fmt "</" namestr-lower ">"))
167 (string-append fmtstr-text value-fmt)
168 (string-append fmtstr-html html-str)
169 (string-append fmtstr-xml xml-str)
170 (string-append fmtstr-text-labels namestr-lower " " value-fmt)
171 (string-append fmtstr-html-labels html-label-str)
172 (string-append fmtstr-xml-labels xml-label-str)
174 (if (find name ref-fields :key #'car)
176 (string-append fmtstr-html-ref "<~~a>" value-fmt "</~~a>")
177 (string-append fmtstr-xml-ref "<~~a>" value-fmt "</~~a>")
178 (string-append fmtstr-html-ref-labels "<i>" namestr-lower "</i> <~~a>" value-fmt "</~~a>")
179 (string-append fmtstr-xml-ref-labels "<label>" namestr-lower "</label> <~~a>" value-fmt "</~~a>"))
181 (string-append fmtstr-html-ref html-str)
182 (string-append fmtstr-xml-ref xml-str)
183 (string-append fmtstr-html-ref-labels html-label-str)
184 (string-append fmtstr-xml-ref-labels xml-label-str)))
187 (setq plain-value-func
188 (list `(,formatter (,(concat-symbol-pkg
189 :umlisp namestr) x))))
190 (setq plain-value-func
191 (list `(,(concat-symbol-pkg
192 :umlisp namestr) x))))
193 (setq value-func (append value-func plain-value-func))
195 (if (eql type :cdata)
196 (setq xmlvalue-func (append xmlvalue-func (list `(xml-cdata ,@plain-value-func))))
197 (setq xmlvalue-func (append xmlvalue-func plain-value-func)))
200 (setq value-func `(lambda (x) (values ,@value-func)))
201 (setq value-func (compile nil (eval value-func)))
202 (setq xmlvalue-func `(lambda (x) (values ,@xmlvalue-func)))
203 (setq xmlvalue-func (compile nil (eval xmlvalue-func)))
205 (setf (slot-value cl 'fmtstr-text) fmtstr-text)
206 (setf (slot-value cl 'fmtstr-html) fmtstr-html)
207 (setf (slot-value cl 'fmtstr-xml) fmtstr-xml)
208 (setf (slot-value cl 'fmtstr-text-labels) fmtstr-text-labels)
209 (setf (slot-value cl 'fmtstr-html-labels) fmtstr-html-labels)
210 (setf (slot-value cl 'fmtstr-xml-labels) fmtstr-xml-labels)
211 (setf (slot-value cl 'fmtstr-html-ref) fmtstr-html-ref)
212 (setf (slot-value cl 'fmtstr-xml-ref) fmtstr-xml-ref)
213 (setf (slot-value cl 'fmtstr-html-ref-labels) fmtstr-html-ref-labels)
214 (setf (slot-value cl 'fmtstr-xml-ref-labels) fmtstr-xml-ref-labels)
215 (setf (slot-value cl 'value-func) value-func)
216 (setf (slot-value cl 'xmlvalue-func) xmlvalue-func))
220 (defun ml-class-fmtstr-text (obj)
221 (slot-value (class-of obj) 'fmtstr-text))
223 (defun ml-class-fmtstr-html (obj)
224 (slot-value (class-of obj) 'fmtstr-html))
226 (defun ml-class-fmtstr-xml (obj)
227 (slot-value (class-of obj) 'fmtstr-xml))
229 (defun ml-class-fmtstr-text-labels (obj)
230 (slot-value (class-of obj) 'fmtstr-text-labels))
232 (defun ml-class-fmtstr-html-labels (obj)
233 (slot-value (class-of obj) 'fmtstr-html-labels))
235 (defun ml-class-fmtstr-xml-labels (obj)
236 (slot-value (class-of obj) 'fmtstr-xml-labels))
238 (defun ml-class-value-func (obj)
239 (slot-value (class-of obj) 'value-func))
241 (defun ml-class-xmlvalue-func (obj)
242 (slot-value (class-of obj) 'xmlvalue-func))
244 (eval-when (:compile-toplevel :load-toplevel :execute)
245 (defun ml-class-title (obj)
246 (awhen (slot-value (class-of obj) 'title)
251 (defun ml-class-subobjects-lists (obj)
252 (slot-value (class-of obj) 'subobjects-lists))
254 (defun ml-class-ref-fields (obj)
255 (slot-value (class-of obj) 'ref-fields))
257 (defun ml-class-fields (obj)
258 (slot-value (class-of obj) 'fields))
260 (defun ml-class-fmtstr-html-ref (obj)
261 (slot-value (class-of obj) 'fmtstr-html-ref))
263 (defun ml-class-fmtstr-xml-ref (obj)
264 (slot-value (class-of obj) 'fmtstr-xml-ref))
266 (defun ml-class-fmtstr-html-ref-labels (obj)
267 (slot-value (class-of obj) 'fmtstr-html-ref-labels))
269 (defun ml-class-fmtstr-xml-ref-labels (obj)
270 (slot-value (class-of obj) 'fmtstr-xml-ref-labels))
272 ;;; Class name functions
274 (defmethod ml-class-stdname ((name string))
275 (string-downcase (subseq name :start 1)))
277 (defmethod ml-class-stdname ((cl standard-object))
278 (string-downcase (subseq (class-name (class-of cl)) :start 1)))
280 ;;;; Generic Print functions
282 (defparameter *default-textformat* nil)
283 (defparameter *default-htmlformat* nil)
284 (defparameter *default-htmlrefformat* nil)
285 (defparameter *default-xmlformat* nil)
286 (defparameter *default-xmlrefformat* nil)
287 (defparameter *default-nullformat* nil)
288 (defparameter *default-init-format?* nil)
290 (defun make-format-instance (fmt)
291 (unless *default-init-format?*
292 (setq *default-textformat* (make-instance 'textformat))
293 (setq *default-htmlformat* (make-instance 'htmlformat))
294 (setq *default-htmlrefformat* (make-instance 'htmlrefformat))
295 (setq *default-xmlformat* (make-instance 'xmlformat))
296 (setq *default-xmlrefformat* (make-instance 'xmlrefformat))
297 (setq *default-nullformat* (make-instance 'nullformat))
298 (setq *default-init-format?* t))
301 (:text *default-textformat*)
302 (:html *default-htmlformat*)
303 (:htmlref *default-htmlrefformat*)
304 (:xml *default-xmlformat*)
305 (:xmlref *default-xmlrefformat*)
306 (:null *default-nullformat*)
307 (otherwise *default-textformat*)))
309 ;;;; Output format classes for print ml-classes
311 (defclass dataformat ()
312 ((file-start-str :type string :initarg :file-start-str :reader file-start-str)
313 (file-end-str :type string :initarg :file-end-str :reader file-end-str)
314 (list-start-fmtstr :type string :initarg :list-start-fmtstr :reader list-start-fmtstr)
315 (list-start-value-func :type function :initarg :list-start-value-func :reader list-start-value-func)
316 (list-start-indent :initarg :list-start-indent :reader list-start-indent)
317 (list-end-fmtstr :type string :initarg :list-end-fmtstr :reader list-end-fmtstr)
318 (list-end-value-func :type function :initarg :list-end-value-func :reader list-end-value-func)
319 (list-end-indent :initarg :list-end-indent :reader list-end-indent)
320 (obj-start-fmtstr :type string :initarg :obj-start-fmtstr :reader obj-start-fmtstr)
321 (obj-start-value-func :initarg :obj-start-value-func :reader obj-start-value-func)
322 (obj-start-indent :initarg :obj-start-indent :reader obj-start-indent)
323 (obj-end-fmtstr :type string :initarg :obj-end-fmtstr :reader obj-end-fmtstr)
324 (obj-end-value-func :initarg :obj-end-value-func :reader obj-end-value-func)
325 (obj-end-indent :initarg :obj-end-indent :reader obj-end-indent)
326 (obj-data-indent :initarg :obj-data-indent :reader obj-data-indent)
327 (obj-data-fmtstr :initarg :obj-data-fmtstr :reader obj-data-fmtstr)
328 (obj-data-fmtstr-labels :initarg :obj-data-fmtstr-labels :reader obj-data-fmtstr-labels)
329 (obj-data-end-fmtstr :initarg :obj-data-end-fmtstr :reader obj-data-end-fmtstr)
330 (obj-data-value-func :initarg :obj-data-value-func :reader obj-data-value-func)
331 (link-ref :initarg :link-ref :reader link-ref))
332 (:default-initargs :file-start-str nil :file-end-str nil :list-start-fmtstr nil :list-start-value-func nil
333 :list-start-indent nil :list-end-fmtstr nil :list-end-value-func nil :list-end-indent nil
334 :obj-start-fmtstr nil :obj-start-value-func nil :obj-start-indent nil
335 :obj-end-fmtstr nil :obj-end-value-func nil :obj-end-indent nil
336 :obj-data-indent nil :obj-data-fmtstr nil :obj-data-fmtstr-labels nil :obj-data-end-fmtstr nil
337 :obj-data-value-func nil :link-ref nil)
338 (:documentation "Parent for all dataformat objects"))
340 (defclass binaryformat (dataformat)
343 (defclass nullformat (dataformat)
346 (defun text-list-start-value-func (obj nitems)
347 (values (ml-class-title obj) nitems))
349 (defclass textformat (dataformat)
351 (:default-initargs :list-start-fmtstr "~a~P:~%"
352 :list-start-value-func #'text-list-start-value-func
355 :obj-data-fmtstr #'ml-class-fmtstr-text
356 :obj-data-fmtstr-labels #'ml-class-fmtstr-text-labels
357 :obj-data-end-fmtstr "~%"
358 :obj-data-value-func #'ml-class-value-func))
360 (defclass htmlformat (textformat)
362 (:default-initargs :file-start-str "<html><body>~%"
363 :file-end-str "</body><html>~%"
365 :list-start-fmtstr "<p><b>~a~P:</b></p><ul>~%"
366 :list-start-value-func #'text-list-start-value-func
367 :list-end-fmtstr "</ul>~%"
369 :list-end-value-func #'identity
371 :obj-start-fmtstr "<li>"
372 :obj-start-value-func #'identity
374 :obj-end-fmtstr "</li>~%"
375 :obj-end-value-func #'identity
377 :obj-data-fmtstr #'ml-class-fmtstr-html-labels
378 :obj-data-fmtstr-labels #'ml-class-fmtstr-html-labels
379 :obj-data-value-func #'ml-class-value-func))
381 (defclass htmlrefformat (htmlformat)
383 (:default-initargs :link-ref (make-instance 'html-link-ref)))
385 (defun class-name-of (obj)
386 (string-downcase (class-name (class-of obj))))
388 (defun xmlformat-list-end-value-func (x)
389 (format nil "~alist" (string-downcase (class-name (class-of x)))))
391 (defun xmlformat-list-start-value-func (x nitems)
392 (values (format nil "~alist" (string-downcase (class-name (class-of x)))) (ml-class-title x) nitems))
394 (defclass xmlformat (textformat)
396 (:default-initargs :file-start-str "" ; (std-xml-header)
398 :list-start-fmtstr "<~a><title>~a~p:</title> ~%"
399 :list-start-value-func #'xmlformat-list-start-value-func
401 :list-end-fmtstr "</~a>~%"
402 :list-end-value-func #'xmlformat-list-end-value-func
403 :obj-start-fmtstr "<~a>"
404 :obj-start-value-func #'class-name-of
406 :obj-end-fmtstr "</~a>~%"
407 :obj-end-value-func #'class-name-of
410 :obj-data-fmtstr #'ml-class-fmtstr-xml
411 :obj-data-fmtstr-labels #'ml-class-fmtstr-xml-labels
412 :obj-data-value-func #'ml-class-xmlvalue-func))
414 (defclass xmlrefformat (xmlformat)
416 (:default-initargs :link-ref (make-instance 'xml-link-ref)))
418 (defclass link-ref ()
419 ((fmtstr :type function :initarg :fmtstr :accessor fmtstr)
420 (fmtstr-labels :type function :initarg :fmtstr-labels :accessor fmtstr-labels)
421 (page-name :type string :initarg :page-name :accessor page-name)
422 (href-head :type string :initarg :href-head :accessor href-head)
423 (href-end :type string :initarg :href-end :accessor href-end)
424 (ampersand :type string :initarg :ampersand :accessor ampersand))
425 (:default-initargs :fmtstr nil
427 :page-name "disp-func1"
428 :href-head nil :href-end nil :ampersand nil)
429 (:documentation "Formatting for a linked reference"))
431 (defclass html-link-ref (link-ref)
433 (:default-initargs :fmtstr #'ml-class-fmtstr-html-ref
434 :fmtstr-labels #'ml-class-fmtstr-html-ref-labels
439 (defclass xml-link-ref (link-ref)
441 (:default-initargs :fmtstr #'ml-class-fmtstr-xml-ref
442 :fmtstr-labels #'ml-class-fmtstr-xml-ref-labels
443 :href-head "xmllink xlink:type=\"simple\" xlink:href="
448 ;;; File Start and Ends
450 (defmethod fmt-file-start ((fmt dataformat) (s stream)))
452 (defmethod fmt-file-start ((fmt textformat) (s stream))
453 (aif (file-start-str fmt)
456 (defmethod fmt-file-end ((fmt textformat) (s stream))
457 (aif (file-end-str fmt)
460 ;;; List Start and Ends
462 (defmethod fmt-list-start (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1))
463 (if (list-start-indent fmt)
464 (indent-spaces indent s))
465 (aif (list-start-fmtstr fmt)
468 (funcall (list-start-value-func fmt) x num-items)))))
470 (defmethod fmt-list-end (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1))
471 (declare (ignore num-items))
472 (if (list-end-indent fmt)
473 (indent-spaces indent s))
474 (aif (list-end-fmtstr fmt)
477 (funcall (list-end-value-func fmt) x)))))
479 ;;; Object Start and Ends
481 (defmethod fmt-obj-start (x (fmt textformat) (s stream) &optional (indent 0))
482 (if (obj-start-indent fmt)
483 (indent-spaces indent s))
484 (aif (obj-start-fmtstr fmt)
487 (funcall (obj-start-value-func fmt) x)))))
489 (defmethod fmt-obj-end (x (fmt textformat) (s stream) &optional (indent 0))
490 (if (obj-end-indent fmt)
491 (indent-spaces indent s))
492 (aif (obj-end-fmtstr fmt)
495 (funcall (obj-end-value-func fmt) x)))))
499 (defmethod make-link-start (obj (ref link-ref) fieldname fieldfunc fieldvalue refvars)
500 (declare (ignore obj fieldname))
501 (format nil "~a\"~a?func=~a~akey=~a~a\""
502 (href-head ref) (make-url (page-name ref)) fieldfunc
503 (ampersand ref) fieldvalue
506 (dolist (var refvars)
507 (string-append varstr (format nil "~a~a=~a"
508 (ampersand ref) (car var) (cadr var))))
512 (defmethod make-link-end (obj (ref link-ref) fieldname)
513 (declare (ignore obj fieldname))
514 (format nil "~a" (href-end ref))
517 (defmethod fmt-obj-data (x (fmt textformat) s
518 &optional (indent 0) (label nil) (refvars nil))
519 (if (obj-data-indent fmt)
520 (indent-spaces indent s))
522 (fmt-obj-data-with-ref x fmt s label refvars)
523 (fmt-obj-data-plain x fmt s label))
524 (aif (obj-data-end-fmtstr fmt)
527 (defmethod fmt-obj-data-plain (x (fmt textformat) s label)
530 (funcall (obj-data-fmtstr-labels fmt) x)
532 (funcall (funcall (obj-data-value-func fmt) x) x)))
533 (apply #'format s (funcall (obj-data-fmtstr fmt) x)
535 (funcall (funcall (obj-data-value-func fmt) x) x)))))
537 (defmethod fmt-obj-data-with-ref (x (fmt textformat) s label refvars)
538 (let ((refstr (make-ref-data-str x fmt label))
542 (funcall (funcall (obj-data-value-func fmt) x) x))))
544 ;; make list of reference link fields for printing to refstr template
545 (dolist (field (ml-class-ref-fields x))
547 (make-link-start x (link-ref fmt) (car field) (cadr field)
548 (nth (position (car field) (ml-class-fields x) :key #'car) field-values)
549 (append (caddr field) refvars)))
550 (link-end (make-link-end x (link-ref fmt) (car field))))
551 (push link-start refvalues)
552 (push link-end refvalues)))
553 (setq refvalues (nreverse refvalues))
555 (apply #'format s refstr refvalues)))
557 (defmethod obj-data (x)
558 "Returns the objects data as a string. Used by common-graphics outline function"
559 (let ((fmt (make-format-instance :text)))
560 (apply #'format nil (funcall (obj-data-fmtstr fmt) x)
562 (funcall (funcall (obj-data-value-func fmt) x) x)))))
564 (defmethod make-ref-data-str (x (fmt textformat) &optional (label nil))
565 "Return fmt string for that contains ~a slots for reference link start and end"
566 (unless (link-ref fmt)
567 (error "fmt does not contain a link-ref"))
570 (apply #'format nil (funcall (fmtstr-labels (link-ref fmt)) x)
572 (funcall (funcall (obj-data-value-func fmt) x) x)))
573 (apply #'format nil (funcall (fmtstr (link-ref fmt)) x)
574 (multiple-value-list (funcall (funcall (obj-data-value-func fmt) x) x))))))
577 ;;; Display method for objects
580 (defmethod load-all-subobjects (objs)
581 "Load all subobjects if they have not already been loaded."
583 (let ((objlist (mklist objs)))
584 (dolist (obj objlist)
585 (awhen (ml-class-subobjects-lists obj) ;; access list of functions
586 (dolist (child-obj it) ;; for each child function
587 (awhen (funcall (car child-obj) obj)
588 (load-all-subobjects it))))))
591 (defmethod output-ml-class (objs (fmt dataformat) (strm stream)
592 &optional (label nil) (english-only-function nil)
593 (indent 0) (subobjects nil) (refvars nil))
594 "Display a single or list of ml-class instances and their subobjects"
596 (setq objs (mklist objs))
597 (let ((nobjs (length objs)))
598 (fmt-list-start (car objs) fmt strm indent nobjs)
600 (unless (and english-only-function (not (funcall english-only-function obj)))
601 (fmt-obj-start obj fmt strm indent)
602 (fmt-obj-data obj fmt strm (1+ indent) label refvars)
604 (awhen (ml-class-subobjects-lists obj) ;; access list of functions
605 (dolist (child-obj it) ;; for each child function
606 (awhen (funcall (car child-obj) obj) ;; access set of child objects
607 (output-ml-class it fmt strm label
608 english-only-function
609 (1+ indent) subobjects refvars)))))
610 (fmt-obj-end obj fmt strm indent)))
611 (fmt-list-end (car objs) fmt strm indent nobjs))
614 (defun display-ml-class (objs &key (os *standard-output*) (format :text)
615 (label nil) (english-only-function nil) (subobjects nil)
616 (file-wrapper t) (refvars nil))
617 "EXPORTED Function: displays a ml-class. Simplies call to output-ml-class"
618 (let ((fmt (make-format-instance format)))
620 (fmt-file-start fmt os))
622 (output-ml-class objs fmt os label english-only-function 0 subobjects refvars))
624 (fmt-file-end fmt os)))