1 ;; -*- mode: common-lisp; package: lml2 -*-
3 ;; $Id: htmlgen.lisp,v 1.15 2003/07/15 19:25:28 kevin Exp $
5 ;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA
6 ;; copyright (c) 2003 Kevin Rosenberg
8 ;; Main changes from Allegro version:
9 ;; - Support XHTML end tags
10 ;; - lowercase symbol names for attributes
11 ;; - Add custom tags such as :jscript, :insert-file, :load-file, :nbsp
12 ;; - removal of if* macro
13 ;; - Add attribute conditions
14 ;; - Automatic conversion to strings for attribute values
16 ;; This code is free software; you can redistribute it and/or
17 ;; modify it under the terms of the version 2.1 of
18 ;; the GNU Lesser General Public License as published by
19 ;; the Free Software Foundation, as clarified by the LLGPL
25 (defstruct (html-process (:type list) (:constructor
26 make-html-process (key has-inverse
31 key ; keyword naming this tag
32 has-inverse ; t if the / form is used
33 macro ; the macro to define this
34 special ; if true then call this to process the keyword and return
36 print ; function used to handle this in html-print
37 name-attr ; attribute symbols which can name this object for subst purposes
41 (defparameter *html-process-table*
42 (make-hash-table :test #'equal) ; #'eq is accurate but want to avoid rehashes
45 (defmacro html (&rest forms &environment env)
46 ;; just emit html to the current stream
47 (process-html-forms forms env))
49 (defmacro html-out-stream-check (stream)
50 ;; ensure that a real stream is passed to this function
54 (error "html-stream must be passed a stream object, not ~s" ,s))
58 (defmacro html-stream (stream &rest forms)
59 ;; set output stream and emit html
60 `(let ((*html-stream* (html-out-stream-check ,stream))) (html ,@forms)))
63 (defun process-html-forms (forms env)
65 (flet ((do-ent (ent args argsp body)
66 ;; ent is an html-process object associated with the
67 ;; html tag we're processing
68 ;; args is the list of values after the tag in the form
69 ;; ((:tag &rest args) ....)
70 ;; argsp is true if this isn't a singleton tag (i.e. it has
71 ;; a body) .. (:tag ...) or ((:tag ...) ...)
72 ;; body is the body if any of the form
76 ((setq spec (html-process-special ent))
77 ;; do something different
78 (push (funcall spec ent args argsp body) res))
80 ;; singleton tag, just do the set
81 (push `(,(html-process-macro ent) :set) res)
84 (cond ((equal args '(:unset))
85 ;; ((:tag :unset)) is a special case.
86 ;; that allows us to close off singleton tags
88 (push `(,(html-process-macro ent) :unset) res)
92 (push `(,(html-process-macro ent)
94 ,(process-html-forms body env))
99 (do* ((xforms forms (cdr xforms))
100 (form (car xforms) (car xforms)))
103 (setq form (macroexpand form env))
108 (let ((ent (gethash form *html-process-table*)))
110 (error "unknown html keyword ~s" form)
111 (do-ent ent nil nil nil))))
113 ;; turn into a print of it
114 (push `(write-string ,form *html-stream*) res))
117 (let ((first (car form)))
120 ;; (:xxx . body) form
121 (let ((ent (gethash first
122 *html-process-table*)))
124 (error "unknown html keyword ~s" form)
125 (do-ent ent nil t (cdr form)))))
126 ((and (consp first) (keywordp (car first)))
127 ;; ((:xxx args ) . body)
128 (let ((ent (gethash (car first)
129 *html-process-table*)))
131 (error "unknown html keyword ~s" form)
132 (do-ent ent (cdr first) t (cdr form)))))
134 (push form res)))))))
135 `(progn ,@(nreverse res))))
138 (defun html-atom-check (args open close body)
139 (when (and args (atom args))
140 (let ((ans (case args
141 (:set `(write-string ,open *html-stream*))
142 (:unset `(write-string ,close *html-stream*))
143 (t (error "illegal arg ~s to ~s" args open)))))
145 (error "can't have a body form with this arg: ~s" args)
148 (defun html-body-form (open close body)
149 ;; used when args don't matter
150 `(progn (write-string ,open *html-stream*)
152 (write-string ,close *html-stream*)))
155 (defun process-attributes (args)
156 (do* ((xx args (cddr xx))
158 (name (first xx) (first xx))
159 (value (second xx) (second xx)))
164 (unless (and (listp value)
165 (>= (length value) 2))
166 (error ":fformat must be given a list at least 2 elements"))
168 ,(format nil " ~(~a~)=\"" (first value))
171 `(fformat *html-stream* ,(second value) ,@(cddr value)) res)
172 (push `(write-char #\" *html-stream*) res))
174 (unless (and (listp value) (>= (length value) 2))
175 (error ":format must be given a list at least 2 elements"))
176 (push `(write-string ,(format nil " ~(~a~)" (first value))
178 (push `(prin1-safe-http-string
179 (fformat nil ,(second value) ,@(cddr value)))
182 (let ((eval-if (gensym "EVAL-IF-")))
183 (push `(let ((,eval-if ,(second value)))
186 ,(format nil " ~(~a~)" (first value))
188 (prin1-safe-http-string ,eval-if)))
191 (unless (and (listp value)
192 (>= (length value) 3)
193 (<= (length value) 4))
194 (error ":if must be given a list with 3 and 4 elements"))
195 (let ((eval-if (gensym "EVAL-IF-")))
196 (push `(let ((,eval-if ,(second value)))
197 (write-string ,(format nil " ~(~a~)" (first value)) *html-stream*)
198 (prin1-safe-http-string
204 (unless (and (listp value)
205 (= (length value) 3))
206 (error ":when must be given a list with 3 elements"))
207 (push `(when ,(second value)
208 (write-string ,(format nil " ~(~a~)" (first value))
210 (prin1-safe-http-string ,(third value)))
213 (push `(write-string ,(format nil " ~(~a~)" name) *html-stream*)
215 (push `(prin1-safe-http-string ,value) res)))))
217 (defun html-body-key-form (string-code has-inv args body)
218 ;; do what's needed to handle given keywords in the args
220 (when (and args (atom args))
222 (return-from html-body-key-form
225 `(write-string ,(format nil "<~a>" string-code)
227 `(write-string ,(format nil "<~a />" string-code)
229 (:unset (when has-inv
230 `(write-string ,(format nil "</~a>" string-code)
232 (t (error "illegal arg ~s to ~s" args string-code)))))
234 (unless (evenp (length args))
235 (warn "arg list ~s isn't even" args))
239 `(progn (write-string ,(format nil "<~a" string-code)
241 ,@(process-attributes args)
243 ,(unless has-inv `(write-string " /" *html-stream*))
244 (write-string ">" *html-stream*)
246 ,(when (and body has-inv)
247 `(write-string ,(format nil "</~a>" string-code)
250 `(progn (write-string ,(format nil "<~a>" string-code)
254 `(write-string ,(format nil "</~a>" string-code)
256 `(progn (write-string ,(format nil "<~a />" string-code)
261 (defun princ-http (val)
262 ;; print the given value to the http stream using ~a
263 (format *html-stream* "~a" val))
265 (defun prin1-http (val)
266 ;; print the given value to the http stream using ~s
267 (format *html-stream* "~s" val))
270 (defun princ-safe-http (val)
271 (emit-safe *html-stream* (format nil "~a" val)))
273 (defun prin1-safe-http (val)
274 (emit-safe *html-stream* (format nil "~s" val)))
277 (defun prin1-safe-http-string (val)
278 ;; used only in a parameter value situation
280 ;; if the parameter value is the symbol with the empty print name
281 ;; then turn this into a singleton object. Thus || is differnent
284 ;; print the contents inside a string double quotes (which should
285 ;; not be turned into "'s
286 ;; symbols are turned into their name
288 ;; non-string and non-symbols are written to a string and quoted
290 (unless (and (symbolp val)
291 (equal "" (symbol-name val)))
292 (write-char #\= *html-stream*)
293 (when (not (or (stringp val)
295 (setq val (write-to-string val)))
296 (if (or (stringp val)
298 (setq val (string-downcase
299 (symbol-name val)))))
301 (write-char #\" *html-stream*)
302 (emit-safe *html-stream* val)
303 (write-char #\" *html-stream*))
304 (prin1-safe-http val))))
307 (defun emit-safe (stream string)
308 ;; send the string to the http response stream watching out for
309 ;; special html characters and encoding them appropriately
312 (end (length string)))
315 (write-sequence string stream :start start :end i)))
317 (let* ((ch (schar string i))
324 ;; must do a conversion, emit previous chars first
326 (write-sequence string stream :start start :end i))
327 (write-string cvt stream)
328 (setq start (1+ i))))))
332 (defun html-print-list (list-of-forms stream &key unknown)
333 ;; html print a list of forms
334 (dolist (x list-of-forms)
335 (html-print-subst x nil stream unknown)))
338 (defun html-print-list-subst (list-of-forms subst stream &key unknown)
339 ;; html print a list of forms
340 (dolist (x list-of-forms)
341 (html-print-subst x subst stream unknown)))
344 (defun html-print (form stream &key unknown)
345 (html-print-subst form nil stream unknown))
348 (defun html-print-subst (form subst stream unknown)
349 ;; Print the given lhtml form to the given stream
350 (assert (streamp stream))
359 (setq attrs (cdar form))
364 (when (keywordp possible-kwd)
365 (if (null (setq ent (gethash possible-kwd *html-process-table*)))
367 (return-from html-print-subst
368 (funcall unknown form stream))
369 (error "unknown html tag: ~s" possible-kwd))
370 ;; see if we should subst
373 (setq attr-name (html-process-name-attr ent))
374 (setq name (getf attrs attr-name))
375 (setq attrs (html-find-value name subst)))
376 (return-from html-print-subst
377 (if (functionp (cdr attrs))
378 (funcall (cdr attrs) stream)
386 (html-process-print ent)))
392 (funcall print-handler ent :set nil nil nil nil stream))
394 (write-string form stream))
396 (princ form stream))))
398 (funcall print-handler
401 (when (consp (car form)) (cdr (car form)))
407 (error "Illegal form: ~s" form)))))
410 (defun html-find-value (key subst)
411 ; find the (key . value) object in the subst list.
412 ; A subst list is an assoc list ((key . value) ....)
413 ; but instead of a (key . value) cons you may have an assoc list
415 (let ((to-process nil)
418 (do* ((entlist alist (cdr entlist))
419 (ent (car entlist) (car entlist)))
420 ((null entlist) (setq alist nil))
423 ;; this is another alist
425 (push (cdr entlist) to-process))
428 ((equal key (car ent))
429 (return-from html-find-value ent))))
432 ;; we need to find a new alist to process
434 (setq alist (pop to-process))
437 (defun html-standard-print (ent cmd args form subst unknown stream)
438 ;; the print handler for the normal html operators
440 (:set ; just turn it on
441 (format stream "<~a>" (html-process-key ent)))
442 (:full ; set, do body and then unset
446 ((and (setq iter (getf args :iter))
447 (setq iter (html-find-value iter subst)))
448 ;; remove the iter and pre
449 (setq args (copy-list args))
452 (cons (cons (caar form)
457 (return-from html-standard-print))
459 (format stream "<~a" (html-process-key ent))
460 (do ((xx args (cddr xx)))
462 ; assume that the arg is already escaped
465 (format stream " ~a=\"~a\"" (car xx) (cadr xx)))
466 (format stream ">")))
467 (format stream "<~a>" (html-process-key ent)))
468 (dolist (ff (cdr form))
469 (html-print-subst ff subst stream unknown)))
470 (when (html-process-has-inverse ent)
472 (format stream "</~a>" (html-process-key ent))))))
481 ;; -- defining how html tags are handled. --
483 ;; most tags are handled in a standard way and the def-std-html
484 ;; macro is used to define such tags
486 ;; Some tags need special treatment and def-special-html defines
487 ;; how these are handled. The tags requiring special treatment
488 ;; are the pseudo tags we added to control operations
489 ;; in the html generator.
492 ;; tags can be found in three ways:
493 ;; :br - singleton, no attributes, no body
494 ;; (:b "foo") - no attributes but with a body
495 ;; ((:a href="foo") "balh") - attributes and body
500 (defmacro def-special-html (kwd fcn print-fcn)
501 ;; kwd - the tag we're defining behavior for.
502 ;; fcn - function to compute the macroexpansion of a use of this
503 ;; tag. args to fcn are:
504 ;; ent - html-process object holding info on this tag
505 ;; args - list of attribute-values following tag
506 ;; argsp - true if there is a body in this use of the tag
507 ;; body - list of body forms.
508 ;; print-fcn - function to print an lhtml form with this tag
510 ;; ent - html-process object holding info on this tag
511 ;; cmd - one of :set, :unset, :full
512 ;; args - list of attribute-value pairs
513 ;; subst - subsitution list
514 ;; unknown - function to call for unknown tags
515 ;; stream - stream to write to
517 `(setf (gethash ,kwd *html-process-table*)
518 (make-html-process ,kwd nil nil ,fcn ,print-fcn nil)))
521 (defmacro named-function (name &body body)
522 (declare (ignore name))
526 (def-special-html :newline
527 (named-function html-newline-function
528 (lambda (ent args argsp body)
529 (declare (ignore ent args argsp))
531 (error "can't have a body with :newline -- body is ~s" body))
532 `(terpri *html-stream*)))
534 (named-function html-newline-print-function
535 (lambda (ent cmd args form subst unknown stream)
536 (declare (ignore args ent unknown subst))
539 (error ":newline in an illegal place: ~s" form)))))
541 (def-special-html :princ
542 (named-function html-princ-function
543 (lambda (ent args argsp body)
544 (declare (ignore ent args argsp))
545 `(progn ,@(mapcar #'(lambda (bod)
549 (named-function html-princ-print-function
550 (lambda (ent cmd args form subst unknown stream)
551 (declare (ignore args ent unknown subst))
552 (assert (eql 2 (length form)))
554 (format stream "~a" (cadr form))
555 (error ":princ must be given an argument")))))
557 (def-special-html :princ-safe
558 (named-function html-princ-safe-function
559 (lambda (ent args argsp body)
560 (declare (ignore ent args argsp))
561 `(progn ,@(mapcar #'(lambda (bod)
562 `(princ-safe-http ,bod))
564 (named-function html-princ-safe-print-function
565 (lambda (ent cmd args form subst unknown stream)
566 (declare (ignore args ent unknown subst))
567 (assert (eql 2 (length form)))
569 (emit-safe stream (format nil "~a" (cadr form)))
570 (error ":princ-safe must be given an argument")))))
572 (def-special-html :prin1
573 (named-function html-prin1-function
574 (lambda (ent args argsp body)
575 (declare (ignore ent args argsp))
576 `(progn ,@(mapcar #'(lambda (bod)
579 (named-function html-prin1-print-function
580 (lambda (ent cmd args form subst unknown stream)
581 (declare (ignore ent args unknown subst))
582 (assert (eql 2 (length form)))
584 (format stream "~s" (cadr form))
585 (error ":prin1 must be given an argument")))))
587 (def-special-html :prin1-safe
588 (named-function html-prin1-safe-function
589 (lambda (ent args argsp body)
590 (declare (ignore ent args argsp))
591 `(progn ,@(mapcar #'(lambda (bod)
592 `(prin1-safe-http ,bod))
594 (named-function html-prin1-safe-print-function
595 (lambda (ent cmd args form subst unknown stream)
596 (declare (ignore args ent subst unknown))
597 (assert (eql 2 (length form)))
599 (emit-safe stream (format nil "~s" (cadr form)))
600 (error ":prin1-safe must be given an argument")))))
602 (def-special-html :comment
603 (named-function html-comment-function
604 (lambda (ent args argsp body)
605 ;; must use <!-- --> syntax
606 (declare (ignore ent args argsp))
607 `(progn (write-string "<!--" *html-stream*)
609 (write-string "-->" *html-stream*))))
610 (named-function html-comment-print-function
611 (lambda (ent cmd args form subst unknown stream)
612 (declare (ignore ent cmd args subst unknown))
613 (format stream "<!--~a-->" (cadr form)))))
617 (defmacro def-std-html (kwd has-inverse name-attrs)
618 (let ((mac-name (intern (format nil "~a-~a" :with-html kwd)))
619 (string-code (string-downcase (string kwd))))
620 `(progn (setf (gethash ,kwd *html-process-table*)
621 (make-html-process ,kwd ,has-inverse
624 #'html-standard-print
626 (defmacro ,mac-name (args &rest body)
627 (html-body-key-form ,string-code ,has-inverse args body)))))
631 (def-std-html :a t nil)
632 (def-std-html :abbr t nil)
633 (def-std-html :acronym t nil)
634 (def-std-html :address t nil)
635 (def-std-html :applet t nil)
636 (def-std-html :area nil nil)
638 (def-std-html :b t nil)
639 (def-std-html :base nil nil)
640 (def-std-html :basefont nil nil)
641 (def-std-html :bdo t nil)
642 (def-std-html :bgsound nil nil)
643 (def-std-html :big t nil)
644 (def-std-html :blink t nil)
645 (def-std-html :blockquote t nil)
646 (def-std-html :body t nil)
647 (def-std-html :br nil nil)
648 (def-std-html :button nil nil)
650 (def-std-html :caption t nil)
651 (def-std-html :center t nil)
652 (def-std-html :cite t nil)
653 (def-std-html :code t nil)
654 (def-std-html :col nil nil)
655 (def-std-html :colgroup nil nil)
657 (def-std-html :dd t nil)
658 (def-std-html :del t nil)
659 (def-std-html :dfn t nil)
660 (def-std-html :dir t nil)
661 (def-std-html :div t nil)
662 (def-std-html :dl t nil)
663 (def-std-html :dt t nil)
665 (def-std-html :em t nil)
666 (def-std-html :embed t nil)
668 (def-std-html :fieldset t nil)
669 (def-std-html :font t nil)
670 (def-std-html :form t :name)
671 (def-std-html :frame t nil)
672 (def-std-html :frameset t nil)
674 (def-std-html :h1 t nil)
675 (def-std-html :h2 t nil)
676 (def-std-html :h3 t nil)
677 (def-std-html :h4 t nil)
678 (def-std-html :h5 t nil)
679 (def-std-html :h6 t nil)
680 (def-std-html :head t nil)
681 (def-std-html :hr nil nil)
682 (def-std-html :html t nil)
684 (def-std-html :i t nil)
685 (def-std-html :iframe t nil)
686 (def-std-html :ilayer t nil)
687 (def-std-html :img nil :id)
688 (def-std-html :input nil nil)
689 (def-std-html :ins t nil)
690 (def-std-html :isindex nil nil)
692 (def-std-html :kbd t nil)
693 (def-std-html :keygen nil nil)
695 (def-std-html :label t nil)
696 (def-std-html :layer t nil)
697 (def-std-html :legend t nil)
698 (def-std-html :li t nil)
699 (def-std-html :link nil nil)
700 (def-std-html :listing t nil)
702 (def-std-html :map t nil)
703 (def-std-html :marquee t nil)
704 (def-std-html :menu t nil)
705 (def-std-html :meta nil nil)
706 (def-std-html :multicol t nil)
708 (def-std-html :nobr t nil)
709 (def-std-html :noembed t nil)
710 (def-std-html :noframes t nil)
711 (def-std-html :noscript t nil)
713 (def-std-html :object t nil)
714 (def-std-html :ol t nil)
715 (def-std-html :optgroup t nil)
716 (def-std-html :option t nil)
718 (def-std-html :p t nil)
719 (def-std-html :param t nil)
720 (def-std-html :plaintext nil nil)
721 (def-std-html :pre t nil)
723 (def-std-html :q t nil)
725 (def-std-html :s t nil)
726 (def-std-html :samp t nil)
727 (def-std-html :script t nil)
728 (def-std-html :select t nil)
729 (def-std-html :server t nil)
730 (def-std-html :small t nil)
731 (def-std-html :spacer nil nil)
732 (def-std-html :span t :id)
733 (def-std-html :strike t nil)
734 (def-std-html :strong t nil)
735 (def-std-html :style t nil)
736 (def-std-html :sub t nil)
737 (def-std-html :sup t nil)
739 (def-std-html :table t :name)
740 (def-std-html :tbody t nil)
741 (def-std-html :td t nil)
742 (def-std-html :textarea t nil)
743 (def-std-html :tfoot t nil)
744 (def-std-html :th t nil)
745 (def-std-html :thead t nil)
746 (def-std-html :title t nil)
747 (def-std-html :tr t nil)
748 (def-std-html :tt t nil)
750 (def-std-html :u t nil)
751 (def-std-html :ul t nil)
753 (def-std-html :var t nil)
755 (def-std-html :wbr nil nil)
757 (def-std-html :xmp t nil)
762 ;;; KMR Local Additions
764 (def-special-html :jscript
765 (named-function html-comment-function
766 (lambda (ent args argsp body)
767 ;; must use <!-- --> syntax
768 (declare (ignore ent args argsp))
770 (write-string "<script language=\"JavaScript\" type=\"text/javascript\">" *html-stream*)
771 (write-char #\newline *html-stream*)
772 (write-string "//![CDATA[" *html-stream*)
773 (write-char #\newline *html-stream*)
775 (write-char #\newline *html-stream*)
776 (write-string "//]]>" *html-stream*)
777 (write-char #\newline *html-stream*)
778 (write-string "</script>" *html-stream*))))
779 (named-function html-comment-print-function
780 (lambda (ent cmd args form subst unknown stream)
781 (declare (ignore ent cmd args subst unknown))
782 (format stream "<script language=\"JavaScript\" type=\"text/javascript\">~%//![CDATA[~%~A~%//]]>~%</script>"
785 (def-special-html :nbsp
786 (named-function html-nbsp-function
787 (lambda (ent args argsp body)
788 (declare (ignore ent args argsp))
790 (error "can't have a body with :nbsp -- body is ~s" body))
791 `(write-string " " *html-stream*)))
793 (named-function html-nbsp-print-function
794 (lambda (ent cmd args form subst unknown stream)
795 (declare (ignore args ent unknown subst))
797 (write-string " " stream)
798 (error ":nbsp in an illegal place: ~s" form)))))
801 (def-special-html :load-file
802 (named-function html-nbsp-function
803 (lambda (ent args argsp body)
804 (declare (ignore ent args argsp))
806 (error "must have a body with :load-file"))
807 `(progn ,@(mapcar #'(lambda (bod)
811 (named-function html-nbsp-print-function
812 (lambda (ent cmd args form subst unknown stream)
813 (declare (ignore ent unknown subst stream args))
814 (assert (eql 2 (length form)))
816 (lml-load (cadr form))
817 (error ":load-file must be given an argument")))))
819 (def-special-html :insert-file
820 (named-function html-nbsp-function
821 (lambda (ent args argsp body)
822 (declare (ignore ent args argsp))
824 (error "must have a body with :insert-file"))
825 `(progn ,@(mapcar #'(lambda (bod)
829 (named-function html-nbsp-print-function
830 (lambda (ent cmd args form subst unknown stream)
831 (declare (ignore ent unknown subst stream args))
832 (assert (eql 2 (length form)))
834 (insert-file (cadr form))
835 (error ":insert-file must be given an argument")))))
837 (def-special-html :write-string
838 (named-function html-write-string-function
839 (lambda (ent args argsp body)
840 (declare (ignore ent args argsp))
841 `(progn ,@(mapcar #'(lambda (bod)
842 `(write-string ,bod *html-stream*))
845 (named-function html-write-string-print-function
846 (lambda (ent cmd args form subst unknown stream)
847 (declare (ignore args ent unknown subst))
848 (assert (eql 2 (length form)))
850 (write-string (cadr form) stream)
851 (error ":write-string must be given an argument")))))
853 (def-special-html :write-char
854 (named-function html-write-char-function
855 (lambda (ent args argsp body)
856 (declare (ignore ent args argsp))
857 `(progn ,@(mapcar #'(lambda (bod)
858 `(write-char ,bod *html-stream*))
861 (named-function html-write-char-print-function
862 (lambda (ent cmd args form subst unknown stream)
863 (declare (ignore args ent unknown subst))
864 (assert (eql 2 (length form)))
866 (write-char (cadr form) stream)
867 (error ":write-char must be given an argument")))))
870 (def-special-html :fformat
871 (named-function html-write-char-function
872 (lambda (ent args argsp body)
873 (declare (ignore ent args argsp))
874 `(progn ,@(mapcar #'(lambda (bod)
876 (format *html-stream* " ~(~A~)=\"" (car ,bod))
877 (apply #'format *html-stream* (cdr ,bod))
878 (write-char #\" *html-stream*)))
881 (named-function html-write-char-print-function
882 (lambda (ent cmd args form subst unknown stream)
883 (declare (ignore args ent unknown subst))
884 (assert (eql 2 (length form)))
887 (format stream " ~(~A~)=\"" (car form))
888 (apply #'format stream (cdr form))
889 (write-char #\" stream))
890 (error ":fformat must be given an argument")))))