1 ;; -*- mode: common-lisp; package: lml2 -*-
3 ;; $Id: htmlgen.lisp,v 1.18 2003/07/21 16:36:22 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
15 ;; - Convert some comments to function doc strings
17 ;; This code is free software; you can redistribute it and/or
18 ;; modify it under the terms of the version 2.1 of
19 ;; the GNU Lesser General Public License as published by
20 ;; the Free Software Foundation, as clarified by the LLGPL
26 (defstruct (html-process (:type list) (:constructor
27 make-html-process (key has-inverse
32 key ; keyword naming this tag
33 has-inverse ; t if the / form is used
34 macro ; the macro to define this
35 special ; if true then call this to process the keyword and return
37 print ; function used to handle this in html-print
38 name-attr ; attribute symbols which can name this object for subst purposes
42 (defparameter *html-process-table*
43 (make-hash-table :test #'equal) ; #'eq is accurate but want to avoid rehashes
46 (defmacro html (&rest forms &environment env)
47 (post-process-html-forms
48 (process-html-forms forms env)))
50 (defun post-process-html-forms (input-forms)
51 "KMR: Walk through forms and combine write-strings"
52 (let (res strs last-stream)
53 (flet ((flush-strings ()
55 (push `(write-string ,strs ,last-stream) res)
57 (setq last-stream nil))))
58 (do* ((forms input-forms (cdr forms))
59 (form (car forms) (car forms)))
69 ((and (eq (car form) 'cl:write-string)
70 (stringp (cadr form)))
72 (if (eq last-stream (third form))
73 (setq strs (concatenate 'string strs (second form)))
76 (setq strs (second form))
77 (setq last-stream (third form))))
79 (setq strs (second form))
80 (setq last-stream (third form)))))
83 (push form res)))))))))
86 (defmacro html-out-stream-check (stream)
87 ;; ensure that a real stream is passed to this function
91 (error "html-stream must be passed a stream object, not ~s" ,s))
95 (defmacro html-stream (stream &rest forms)
96 ;; set output stream and emit html
97 `(let ((*html-stream* (html-out-stream-check ,stream))) (html ,@forms)))
100 (defun process-html-forms (forms env)
102 (flet ((do-ent (ent args argsp body)
103 ;; ent is an html-process object associated with the
104 ;; html tag we're processing
105 ;; args is the list of values after the tag in the form
106 ;; ((:tag &rest args) ....)
107 ;; argsp is true if this isn't a singleton tag (i.e. it has
108 ;; a body) .. (:tag ...) or ((:tag ...) ...)
109 ;; body is the body if any of the form
113 ((setq spec (html-process-special ent))
114 ;; do something different
115 (push (funcall spec ent args argsp body) res))
117 ;; singleton tag, just do the set
118 (push `(,(html-process-macro ent) :set) res)
121 (cond ((equal args '(:unset))
122 ;; ((:tag :unset)) is a special case.
123 ;; that allows us to close off singleton tags
125 (push `(,(html-process-macro ent) :unset) res)
129 (push `(,(html-process-macro ent)
131 ,(process-html-forms body env))
136 (do* ((xforms forms (cdr xforms))
137 (form (car xforms) (car xforms)))
140 (setq form (macroexpand form env))
145 (let ((ent (gethash form *html-process-table*)))
147 (error "unknown html keyword ~s" form)
148 (do-ent ent nil nil nil))))
150 ;; turn into a print of it
151 (push `(write-string ,form *html-stream*) res))
154 (let ((first (car form)))
157 ;; (:xxx . body) form
158 (let ((ent (gethash first
159 *html-process-table*)))
161 (error "unknown html keyword ~s" form)
162 (do-ent ent nil t (cdr form)))))
163 ((and (consp first) (keywordp (car first)))
164 ;; ((:xxx args ) . body)
165 (let ((ent (gethash (car first)
166 *html-process-table*)))
168 (error "unknown html keyword ~s" form)
169 (do-ent ent (cdr first) t (cdr form)))))
171 (push form res)))))))
172 `(progn ,@(nreverse res))))
175 (defun html-atom-check (args open close body)
176 (when (and args (atom args))
177 (let ((ans (case args
178 (:set `(write-string ,open *html-stream*))
179 (:unset `(write-string ,close *html-stream*))
180 (t (error "illegal arg ~s to ~s" args open)))))
182 (error "can't have a body form with this arg: ~s" args)
185 (defun html-body-form (open close body)
186 ;; used when args don't matter
187 `(progn (write-string ,open *html-stream*)
189 (write-string ,close *html-stream*)))
192 (defun attribute-name-string (name)
194 (symbol (string-downcase (symbol-name name)))
197 (defun process-attributes (args)
198 (flet ((write-attribute-name-forms (name)
199 `((write-char #\space *html-stream*)
200 (write-string ,(attribute-name-string name)
202 (write-separator-forms ()
203 '((write-char #\= *html-stream*)
204 (write-char #\" *html-stream*))))
205 (do* ((xx args (cddr xx))
207 (name (first xx) (first xx))
208 (value (second xx) (second xx)))
213 (unless (and (listp value)
214 (>= (length value) 2))
215 (error ":fformat must be given a list at least 2 elements"))
216 (mapcar (lambda (f) (push f res))
217 (write-attribute-name-forms (first value)))
218 (mapcar (lambda (f) (push f res))
219 (write-separator-forms))
220 (push `(fformat *html-stream* ,(second value) ,@(cddr value))
222 (push `(write-char #\" *html-stream*) res))
224 (unless (and (listp value) (>= (length value) 2))
225 (error ":format must be given a list at least 2 elements"))
226 (mapcar (lambda (f) (push f res))
227 (write-attribute-name-forms (first value)))
228 (push `(prin1-safe-http-string
229 (format nil ,(second value) ,@(cddr value)))
232 (let ((eval-if (gensym "EVAL-IF-")))
233 (push `(let ((,eval-if ,(second value)))
235 ,@(write-attribute-name-forms (first value))
236 (prin1-safe-http-string ,eval-if)))
239 (unless (and (listp value)
240 (>= (length value) 3)
241 (<= (length value) 4))
242 (error ":if must be given a list with 3 and 4 elements"))
243 (let ((eval-if (gensym "EVAL-IF-")))
244 (push `(let ((,eval-if ,(second value)))
245 ,@(write-attribute-name-forms (first value))
246 (prin1-safe-http-string
252 (unless (and (listp value)
253 (= (length value) 3))
254 (error ":when must be given a list with 3 elements"))
255 (push `(when ,(second value)
256 ,@(write-attribute-name-forms (first value))
257 (prin1-safe-http-string ,(third value)))
260 (mapcar (lambda (f) (push f res))
261 (write-attribute-name-forms name))
262 (push `(prin1-safe-http-string ,value) res))))))
264 (defun html-body-key-form (string-code has-inv args body)
265 ;; do what's needed to handle given keywords in the args
267 (when (and args (atom args))
269 (return-from html-body-key-form
272 `(write-string ,(format nil "<~a>" string-code)
274 `(write-string ,(format nil "<~a />" string-code)
276 (:unset (when has-inv
277 `(write-string ,(format nil "</~a>" string-code)
279 (t (error "illegal arg ~s to ~s" args string-code)))))
281 (unless (evenp (length args))
282 (warn "arg list ~s isn't even" args))
286 `(progn (write-string ,(format nil "<~a" string-code)
289 ,@(process-attributes args)
291 ,(unless has-inv `(write-string " /" *html-stream*))
292 (write-string ">" *html-stream*)
294 ,(when (and body has-inv)
295 `(write-string ,(format nil "</~a>" string-code)
298 `(progn (write-string ,(format nil "<~a>" string-code)
302 `(write-string ,(format nil "</~a>" string-code)
304 `(progn (write-string ,(format nil "<~a />" string-code)
309 (defun princ-http (val)
310 ;; print the given value to the http stream using ~a
311 (format *html-stream* "~a" val))
313 (defun prin1-http (val)
314 ;; print the given value to the http stream using ~s
315 (format *html-stream* "~s" val))
318 (defun princ-safe-http (val)
319 (emit-safe *html-stream* (format nil "~a" val)))
321 (defun prin1-safe-http (val)
322 (emit-safe *html-stream* (format nil "~s" val)))
325 (defun prin1-safe-http-string (val)
326 ;; used only in a parameter value situation
328 ;; if the parameter value is the symbol with the empty print name
329 ;; then turn this into a singleton object. Thus || is differnent
332 ;; print the contents inside a string double quotes (which should
333 ;; not be turned into "'s
334 ;; symbols are turned into their name
336 ;; non-string and non-symbols are written to a string and quoted
338 (unless (and (symbolp val)
339 (equal "" (symbol-name val)))
340 (write-char #\= *html-stream*)
341 (when (not (or (stringp val)
343 (setq val (write-to-string val)))
344 (if (or (stringp val)
346 (setq val (string-downcase
347 (symbol-name val)))))
349 (write-char #\" *html-stream*)
350 (emit-safe *html-stream* val)
351 (write-char #\" *html-stream*))
352 (prin1-safe-http val))))
355 (defun emit-safe (stream string)
356 "Send the string to the http response stream watching out for
357 special html characters and encoding them appropriately."
360 (end (length string)))
363 (write-sequence string stream :start start :end i)))
365 (let* ((ch (schar string i))
372 ;; must do a conversion, emit previous chars first
374 (write-sequence string stream :start start :end i))
375 (write-string cvt stream)
376 (setq start (1+ i))))))
380 (defun html-print-list (list-of-forms stream &key unknown)
381 ;; html print a list of forms
382 (dolist (x list-of-forms)
383 (html-print-subst x nil stream unknown)))
386 (defun html-print-list-subst (list-of-forms subst stream &key unknown)
387 ;; html print a list of forms
388 (dolist (x list-of-forms)
389 (html-print-subst x subst stream unknown)))
392 (defun html-print (form stream &key unknown)
393 (html-print-subst form nil stream unknown))
396 (defun html-print-subst (form subst stream unknown)
397 ;; Print the given lhtml form to the given stream
398 (assert (streamp stream))
407 (setq attrs (cdar form))
412 (when (keywordp possible-kwd)
413 (if (null (setq ent (gethash possible-kwd *html-process-table*)))
415 (return-from html-print-subst
416 (funcall unknown form stream))
417 (error "unknown html tag: ~s" possible-kwd))
418 ;; see if we should subst
421 (setq attr-name (html-process-name-attr ent))
422 (setq name (getf attrs attr-name))
423 (setq attrs (html-find-value name subst)))
424 (return-from html-print-subst
425 (if (functionp (cdr attrs))
426 (funcall (cdr attrs) stream)
434 (html-process-print ent)))
440 (funcall print-handler ent :set nil nil nil nil stream))
442 (write-string form stream))
444 (princ form stream))))
446 (funcall print-handler
449 (when (consp (car form)) (cdr (car form)))
455 (error "Illegal form: ~s" form)))))
458 (defun html-find-value (key subst)
459 ; find the (key . value) object in the subst list.
460 ; A subst list is an assoc list ((key . value) ....)
461 ; but instead of a (key . value) cons you may have an assoc list
463 (let ((to-process nil)
466 (do* ((entlist alist (cdr entlist))
467 (ent (car entlist) (car entlist)))
468 ((null entlist) (setq alist nil))
471 ;; this is another alist
473 (push (cdr entlist) to-process))
476 ((equal key (car ent))
477 (return-from html-find-value ent))))
480 ;; we need to find a new alist to process
482 (setq alist (pop to-process))
485 (defun html-standard-print (ent cmd args form subst unknown stream)
486 ;; the print handler for the normal html operators
488 (:set ; just turn it on
489 (format stream "<~a>" (html-process-key ent)))
490 (:full ; set, do body and then unset
494 ((and (setq iter (getf args :iter))
495 (setq iter (html-find-value iter subst)))
496 ;; remove the iter and pre
497 (setq args (copy-list args))
500 (cons (cons (caar form)
505 (return-from html-standard-print))
507 (format stream "<~a" (html-process-key ent))
508 (do ((xx args (cddr xx)))
510 ; assume that the arg is already escaped
513 (format stream " ~a=\"~a\"" (car xx) (cadr xx)))
514 (format stream ">")))
515 (format stream "<~a>" (html-process-key ent)))
516 (dolist (ff (cdr form))
517 (html-print-subst ff subst stream unknown)))
518 (when (html-process-has-inverse ent)
520 (format stream "</~a>" (html-process-key ent))))))
529 ;; -- defining how html tags are handled. --
531 ;; most tags are handled in a standard way and the def-std-html
532 ;; macro is used to define such tags
534 ;; Some tags need special treatment and def-special-html defines
535 ;; how these are handled. The tags requiring special treatment
536 ;; are the pseudo tags we added to control operations
537 ;; in the html generator.
540 ;; tags can be found in three ways:
541 ;; :br - singleton, no attributes, no body
542 ;; (:b "foo") - no attributes but with a body
543 ;; ((:a href="foo") "balh") - attributes and body
548 (defmacro def-special-html (kwd fcn print-fcn)
549 ;; kwd - the tag we're defining behavior for.
550 ;; fcn - function to compute the macroexpansion of a use of this
551 ;; tag. args to fcn are:
552 ;; ent - html-process object holding info on this tag
553 ;; args - list of attribute-values following tag
554 ;; argsp - true if there is a body in this use of the tag
555 ;; body - list of body forms.
556 ;; print-fcn - function to print an lhtml form with this tag
558 ;; ent - html-process object holding info on this tag
559 ;; cmd - one of :set, :unset, :full
560 ;; args - list of attribute-value pairs
561 ;; subst - subsitution list
562 ;; unknown - function to call for unknown tags
563 ;; stream - stream to write to
565 `(setf (gethash ,kwd *html-process-table*)
566 (make-html-process ,kwd nil nil ,fcn ,print-fcn nil)))
569 (defmacro named-function (name &body body)
570 (declare (ignore name))
574 (def-special-html :newline
575 (named-function html-newline-function
576 (lambda (ent args argsp body)
577 (declare (ignore ent args argsp))
579 (error "can't have a body with :newline -- body is ~s" body))
580 `(terpri *html-stream*)))
582 (named-function html-newline-print-function
583 (lambda (ent cmd args form subst unknown stream)
584 (declare (ignore args ent unknown subst))
587 (error ":newline in an illegal place: ~s" form)))))
589 (def-special-html :princ
590 (named-function html-princ-function
591 (lambda (ent args argsp body)
592 (declare (ignore ent args argsp))
593 `(progn ,@(mapcar #'(lambda (bod)
597 (named-function html-princ-print-function
598 (lambda (ent cmd args form subst unknown stream)
599 (declare (ignore args ent unknown subst))
600 (assert (eql 2 (length form)))
602 (format stream "~a" (cadr form))
603 (error ":princ must be given an argument")))))
605 (def-special-html :princ-safe
606 (named-function html-princ-safe-function
607 (lambda (ent args argsp body)
608 (declare (ignore ent args argsp))
609 `(progn ,@(mapcar #'(lambda (bod)
610 `(princ-safe-http ,bod))
612 (named-function html-princ-safe-print-function
613 (lambda (ent cmd args form subst unknown stream)
614 (declare (ignore args ent unknown subst))
615 (assert (eql 2 (length form)))
617 (emit-safe stream (format nil "~a" (cadr form)))
618 (error ":princ-safe must be given an argument")))))
620 (def-special-html :prin1
621 (named-function html-prin1-function
622 (lambda (ent args argsp body)
623 (declare (ignore ent args argsp))
624 `(progn ,@(mapcar #'(lambda (bod)
627 (named-function html-prin1-print-function
628 (lambda (ent cmd args form subst unknown stream)
629 (declare (ignore ent args unknown subst))
630 (assert (eql 2 (length form)))
632 (format stream "~s" (cadr form))
633 (error ":prin1 must be given an argument")))))
635 (def-special-html :prin1-safe
636 (named-function html-prin1-safe-function
637 (lambda (ent args argsp body)
638 (declare (ignore ent args argsp))
639 `(progn ,@(mapcar #'(lambda (bod)
640 `(prin1-safe-http ,bod))
642 (named-function html-prin1-safe-print-function
643 (lambda (ent cmd args form subst unknown stream)
644 (declare (ignore args ent subst unknown))
645 (assert (eql 2 (length form)))
647 (emit-safe stream (format nil "~s" (cadr form)))
648 (error ":prin1-safe must be given an argument")))))
650 (def-special-html :comment
651 (named-function html-comment-function
652 (lambda (ent args argsp body)
653 ;; must use <!-- --> syntax
654 (declare (ignore ent args argsp))
655 `(progn (write-string "<!--" *html-stream*)
657 (write-string "-->" *html-stream*))))
658 (named-function html-comment-print-function
659 (lambda (ent cmd args form subst unknown stream)
660 (declare (ignore ent cmd args subst unknown))
661 (format stream "<!--~a-->" (cadr form)))))
665 (defmacro def-std-html (kwd has-inverse name-attrs)
666 (let ((mac-name (intern (format nil "~a-~a" :with-html kwd)))
667 (string-code (string-downcase (string kwd))))
668 `(progn (setf (gethash ,kwd *html-process-table*)
669 (make-html-process ,kwd ,has-inverse
672 #'html-standard-print
674 (defmacro ,mac-name (args &rest body)
675 (html-body-key-form ,string-code ,has-inverse args body)))))
679 (def-std-html :a t nil)
680 (def-std-html :abbr t nil)
681 (def-std-html :acronym t nil)
682 (def-std-html :address t nil)
683 (def-std-html :applet t nil)
684 (def-std-html :area nil nil)
686 (def-std-html :b t nil)
687 (def-std-html :base nil nil)
688 (def-std-html :basefont nil nil)
689 (def-std-html :bdo t nil)
690 (def-std-html :bgsound nil nil)
691 (def-std-html :big t nil)
692 (def-std-html :blink t nil)
693 (def-std-html :blockquote t nil)
694 (def-std-html :body t nil)
695 (def-std-html :br nil nil)
696 (def-std-html :button nil nil)
698 (def-std-html :caption t nil)
699 (def-std-html :center t nil)
700 (def-std-html :cite t nil)
701 (def-std-html :code t nil)
702 (def-std-html :col nil nil)
703 (def-std-html :colgroup nil nil)
705 (def-std-html :dd t nil)
706 (def-std-html :del t nil)
707 (def-std-html :dfn t nil)
708 (def-std-html :dir t nil)
709 (def-std-html :div t nil)
710 (def-std-html :dl t nil)
711 (def-std-html :dt t nil)
713 (def-std-html :em t nil)
714 (def-std-html :embed t nil)
716 (def-std-html :fieldset t nil)
717 (def-std-html :font t nil)
718 (def-std-html :form t :name)
719 (def-std-html :frame t nil)
720 (def-std-html :frameset t nil)
722 (def-std-html :h1 t nil)
723 (def-std-html :h2 t nil)
724 (def-std-html :h3 t nil)
725 (def-std-html :h4 t nil)
726 (def-std-html :h5 t nil)
727 (def-std-html :h6 t nil)
728 (def-std-html :head t nil)
729 (def-std-html :hr nil nil)
730 (def-std-html :html t nil)
732 (def-std-html :i t nil)
733 (def-std-html :iframe t nil)
734 (def-std-html :ilayer t nil)
735 (def-std-html :img nil :id)
736 (def-std-html :input nil nil)
737 (def-std-html :ins t nil)
738 (def-std-html :isindex nil nil)
740 (def-std-html :kbd t nil)
741 (def-std-html :keygen nil nil)
743 (def-std-html :label t nil)
744 (def-std-html :layer t nil)
745 (def-std-html :legend t nil)
746 (def-std-html :li t nil)
747 (def-std-html :link nil nil)
748 (def-std-html :listing t nil)
750 (def-std-html :map t nil)
751 (def-std-html :marquee t nil)
752 (def-std-html :menu t nil)
753 (def-std-html :meta nil nil)
754 (def-std-html :multicol t nil)
756 (def-std-html :nobr t nil)
757 (def-std-html :noembed t nil)
758 (def-std-html :noframes t nil)
759 (def-std-html :noscript t nil)
761 (def-std-html :object t nil)
762 (def-std-html :ol t nil)
763 (def-std-html :optgroup t nil)
764 (def-std-html :option t nil)
766 (def-std-html :p t nil)
767 (def-std-html :param t nil)
768 (def-std-html :plaintext nil nil)
769 (def-std-html :pre t nil)
771 (def-std-html :q t nil)
773 (def-std-html :s t nil)
774 (def-std-html :samp t nil)
775 (def-std-html :script t nil)
776 (def-std-html :select t nil)
777 (def-std-html :server t nil)
778 (def-std-html :small t nil)
779 (def-std-html :spacer nil nil)
780 (def-std-html :span t :id)
781 (def-std-html :strike t nil)
782 (def-std-html :strong t nil)
783 (def-std-html :style t nil)
784 (def-std-html :sub t nil)
785 (def-std-html :sup t nil)
787 (def-std-html :table t :name)
788 (def-std-html :tbody t nil)
789 (def-std-html :td t nil)
790 (def-std-html :textarea t nil)
791 (def-std-html :tfoot t nil)
792 (def-std-html :th t nil)
793 (def-std-html :thead t nil)
794 (def-std-html :title t nil)
795 (def-std-html :tr t nil)
796 (def-std-html :tt t nil)
798 (def-std-html :u t nil)
799 (def-std-html :ul t nil)
801 (def-std-html :var t nil)
803 (def-std-html :wbr nil nil)
805 (def-std-html :xmp t nil)
810 ;;; KMR Local Additions
812 (def-special-html :jscript
813 (named-function html-comment-function
814 (lambda (ent args argsp body)
815 ;; must use <!-- --> syntax
816 (declare (ignore ent args argsp))
818 (write-string "<script language=\"JavaScript\" type=\"text/javascript\">" *html-stream*)
819 (write-char #\newline *html-stream*)
820 (write-string "//![CDATA[" *html-stream*)
821 (write-char #\newline *html-stream*)
823 (write-char #\newline *html-stream*)
824 (write-string "//]]>" *html-stream*)
825 (write-char #\newline *html-stream*)
826 (write-string "</script>" *html-stream*))))
827 (named-function html-comment-print-function
828 (lambda (ent cmd args form subst unknown stream)
829 (declare (ignore ent cmd args subst unknown))
830 (format stream "<script language=\"JavaScript\" type=\"text/javascript\">~%//![CDATA[~%~A~%//]]>~%</script>"
833 (def-special-html :nbsp
834 (named-function html-nbsp-function
835 (lambda (ent args argsp body)
836 (declare (ignore ent args argsp))
838 (error "can't have a body with :nbsp -- body is ~s" body))
839 `(write-string " " *html-stream*)))
841 (named-function html-nbsp-print-function
842 (lambda (ent cmd args form subst unknown stream)
843 (declare (ignore args ent unknown subst))
845 (write-string " " stream)
846 (error ":nbsp in an illegal place: ~s" form)))))
849 (def-special-html :load-file
850 (named-function html-nbsp-function
851 (lambda (ent args argsp body)
852 (declare (ignore ent args argsp))
854 (error "must have a body with :load-file"))
855 `(progn ,@(mapcar #'(lambda (bod)
859 (named-function html-nbsp-print-function
860 (lambda (ent cmd args form subst unknown stream)
861 (declare (ignore ent unknown subst stream args))
862 (assert (eql 2 (length form)))
864 (lml-load (cadr form))
865 (error ":load-file must be given an argument")))))
867 (def-special-html :insert-file
868 (named-function html-nbsp-function
869 (lambda (ent args argsp body)
870 (declare (ignore ent args argsp))
872 (error "must have a body with :insert-file"))
873 `(progn ,@(mapcar #'(lambda (bod)
877 (named-function html-nbsp-print-function
878 (lambda (ent cmd args form subst unknown stream)
879 (declare (ignore ent unknown subst stream args))
880 (assert (eql 2 (length form)))
882 (insert-file (cadr form))
883 (error ":insert-file must be given an argument")))))
885 (def-special-html :write-string
886 (named-function html-write-string-function
887 (lambda (ent args argsp body)
888 (declare (ignore ent args argsp))
889 (if (= (length body) 1)
890 `(write-string ,(car body) *html-stream*)
891 `(progn ,@(mapcar #'(lambda (bod)
892 `(write-string ,bod *html-stream*))
895 (named-function html-write-string-print-function
896 (lambda (ent cmd args form subst unknown stream)
897 (declare (ignore args ent unknown subst))
898 (assert (eql 2 (length form)))
900 (write-string (cadr form) stream)
901 (error ":write-string must be given an argument")))))
903 (def-special-html :write-char
904 (named-function html-write-char-function
905 (lambda (ent args argsp body)
906 (declare (ignore ent args argsp))
907 `(progn ,@(mapcar #'(lambda (bod)
908 `(write-char ,bod *html-stream*))
911 (named-function html-write-char-print-function
912 (lambda (ent cmd args form subst unknown stream)
913 (declare (ignore args ent unknown subst))
914 (assert (eql 2 (length form)))
916 (write-char (cadr form) stream)
917 (error ":write-char must be given an argument")))))
920 (def-special-html :fformat
921 (named-function html-write-char-function
922 (lambda (ent args argsp body)
923 (declare (ignore ent args argsp))
924 `(progn ,@(mapcar #'(lambda (bod)
926 (format *html-stream* " ~(~A~)=\"" (car ,bod))
927 (apply #'format *html-stream* (cdr ,bod))
928 (write-char #\" *html-stream*)))
931 (named-function html-write-char-print-function
932 (lambda (ent cmd args form subst unknown stream)
933 (declare (ignore args ent unknown subst))
934 (assert (eql 2 (length form)))
937 (format stream " ~(~A~)=\"" (car form))
938 (apply #'format stream (cdr form))
939 (write-char #\" stream))
940 (error ":fformat must be given an argument")))))