;; -*- mode: common-lisp; package: lml2 -*-
;;
;; $Id: htmlgen.lisp 8446 2004-01-01 14:30:56Z kevin $
;;
;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA 
;; copyright (c) 2003 Kevin Rosenberg
;;
;; Main changes from Allegro version:
;;    - Support XHTML end tags
;;    - lowercase symbol names for attributes
;;    - Add custom tags such as :jscript, :insert-file, :load-file, :nbsp
;;    - removal of if* macro
;;    - Add attribute conditions 
;;    - Automatic conversion to strings for attribute values
;;    - Convert some comments to function doc strings
;;
;; This code is free software; you can redistribute it and/or
;; modify it under the terms of the version 2.1 of
;; the GNU Lesser General Public License as published by 
;; the Free Software Foundation, as clarified by the LLGPL


(in-package #:lml2)


(defstruct (html-process (:type list) (:constructor
				       make-html-process (key has-inverse
							      macro special
							      print
							      name-attr
							      )))
  key		; keyword naming this tag
  has-inverse	; t if the / form is used
  macro  	; the macro to define this
  special       ; if true then call this to process the keyword and return
                ; the macroexpansion
  print         ; function used to handle this in html-print
  name-attr     ; attribute symbols which can name this object for subst purposes
  )


(defparameter *html-process-table* 
    (make-hash-table :test #'equal) ; #'eq is accurate but want to avoid rehashes
  )

(defmacro html (&rest forms &environment env)
  (post-process-html-forms
   (process-html-forms forms env)))

(defun post-process-html-forms (input-forms)
  "KMR: Walk through forms and combine write-strings"
  (let (res strs last-stream)
    (flet ((flush-strings ()
	     (when strs
	       (push `(write-string ,strs ,last-stream) res)
	       (setq strs nil)
	       (setq last-stream nil))))	     
      (do* ((forms input-forms (cdr forms))
	    (form (car forms) (car forms)))
	   ((null forms)
	    (flush-strings)
	    (nreverse res))
	(cond
	  ((atom form)
	   (flush-strings)
	   (push form res))
	  ((and (eq (car form) 'cl:write-string)
		(stringp (cadr form)))
	   (if strs
	       (if (eq last-stream (third form))
		   (setq strs (concatenate 'string strs (second form)))
		   (progn
		     (flush-strings)
		     (setq strs (second form))
		     (setq last-stream (third form))))
	       (progn
		 (setq strs (second form))
		 (setq last-stream (third form)))))
	  (t
	   (flush-strings)
	   (push (post-process-html-forms form) res)))))))
  

(defmacro html-out-stream-check (stream)
  ;; ensure that a real stream is passed to this function
  (let ((s (gensym)))
  `(let ((,s ,stream))
     (unless (streamp ,s)
       (error "html-stream must be passed a stream object, not ~s" ,s))
    ,s)))


(defmacro html-stream (stream &rest forms)
  ;; set output stream and emit html
  `(let ((*html-stream* (html-out-stream-check ,stream))) (html ,@forms)))


(defun process-html-forms (forms env)
  (let (res)
    (flet ((do-ent (ent args argsp body)
	     ;; ent is an html-process object associated with the 
	     ;;	    html tag we're processing
	     ;; args is the list of values after the tag in the form
	     ;;     ((:tag &rest args) ....)
	     ;; argsp is true if this isn't a singleton tag  (i.e. it has
	     ;;     a body) .. (:tag ...) or ((:tag ...) ...)
	     ;; body is the body if any of the form
	     ;;
	     (let (spec)
	       (cond
		((setq spec (html-process-special ent))
		 ;; do something different
		 (push (funcall spec ent args argsp body) res))
		((null argsp)
		 ;; singleton tag, just do the set
		 (push `(,(html-process-macro ent) :set) res)
		 nil)
		(t
		 (cond ((equal args '(:unset))
			;; ((:tag :unset)) is a special case.
			;; that allows us to close off singleton tags
			;; printed earlier.
			(push `(,(html-process-macro ent) :unset) res)
			nil)
		       (t
			;; some args
			(push `(,(html-process-macro ent)
				,args
				,(process-html-forms body env))
			      res)
			nil)))))))
		    

      (do* ((xforms forms (cdr xforms))
	    (form (car xforms) (car xforms)))
	  ((null xforms))

	(setq form (macroexpand form env))
	
	(if (atom form)
	    (cond
	     ((keywordp form)
	      (let ((ent (gethash form *html-process-table*)))
		(if (null ent)
		    (error "unknown html keyword ~s" form)
		  (do-ent ent nil nil nil))))
	     ((stringp form)
	      ;; turn into a print of it
	      (push `(write-string ,form *html-stream*) res))
	     (t
	      (push form res)))
	  (let ((first (car form)))
	    (cond
	     ((keywordp first)
	      ;; (:xxx . body) form
	      (let ((ent (gethash first
				  *html-process-table*)))
		(if (null ent)
		    (error "unknown html keyword ~s" form)
		  (do-ent ent nil t (cdr form)))))
	     ((and (consp first) (keywordp (car first)))
	      ;; ((:xxx args ) . body)
	      (let ((ent (gethash (car first)
				  *html-process-table*)))
		(if (null ent)
		    (error "unknown html keyword ~s" form)
		  (do-ent ent (cdr first) t (cdr form)))))
	     (t
	      (push form res)))))))
    `(progn ,@(nreverse res))))


(defun html-atom-check (args open close body)
  (when (and args (atom args))
    (let ((ans (case args
		 (:set `(write-string  ,open *html-stream*))
		 (:unset `(write-string  ,close *html-stream*))
		 (t (error "illegal arg ~s to ~s" args open)))))
      (if (and ans body)
	  (error "can't have a body form with this arg: ~s" args)
	ans))))

(defun html-body-form (open close body)
  ;; used when args don't matter
  `(progn (write-string  ,open *html-stream*)
	  ,@body
	  (write-string  ,close *html-stream*)))


(defun attribute-name-string (name)
  (etypecase name
    (symbol (string-downcase (symbol-name name)))
    (string name)))

(defun process-attributes (args)
  (flet ((write-attribute-name-forms (name)
	   `((write-char #\space *html-stream*)
	     (write-string ,(attribute-name-string name)
			   *html-stream*)))
	 (write-separator-forms ()
	   '((write-char #\= *html-stream*)
	     (write-char #\" *html-stream*))))
    (do* ((xx args (cddr xx))
	  (res)
	  (name (first xx) (first xx))
	  (value (second xx) (second xx)))
	((null xx)
	 (nreverse res))
      (case name
	(:fformat
	 (unless (and (listp value)
		      (>= (length value) 2))
	   (error ":fformat must be given a list at least 2 elements"))
	 (mapcar (lambda (f) (push f res))
		 (write-attribute-name-forms (first value)))
	 (mapcar (lambda (f) (push f res))
		 (write-separator-forms))
	 (push `(fformat *html-stream* ,(second value) ,@(cddr value)) 
	       res)
	 (push `(write-char #\" *html-stream*) res))
      (:format
       (unless (and (listp value) (>= (length value) 2))
	 (error ":format must be given a list at least 2 elements"))
       (mapcar (lambda (f) (push f res))
	       (write-attribute-name-forms (first value)))
       (push `(prin1-safe-http-string
	       (format nil ,(second value) ,@(cddr value)))
	     res))
      (:optional
       (let ((eval-if (gensym "EVAL-IF-")))
	 (push `(let ((,eval-if ,(second value)))
		  (when ,eval-if
		     ,@(write-attribute-name-forms (first value))
		     (prin1-safe-http-string ,eval-if)))
	       res)))
      (:if
	  (unless (and (listp value)
		       (>= (length value) 3)
		       (<= (length value) 4))
	    (error ":if must be given a list with 3 and 4 elements"))
	  (let ((eval-if (gensym "EVAL-IF-")))
	    (push `(let ((,eval-if ,(second value)))
		     ,@(write-attribute-name-forms (first value))
		     (prin1-safe-http-string 
		      (if ,eval-if
			  ,(third value)
			,(fourth value))))
		  res)))
      (:when
	  (unless (and (listp value)
		       (= (length value) 3))
	    (error ":when must be given a list with 3 elements"))
	(push `(when ,(second value)
		 ,@(write-attribute-name-forms (first value))
		 (prin1-safe-http-string ,(third value)))
	      res))
      (t
       (mapcar (lambda (f) (push f res))
	       (write-attribute-name-forms name))
       (push `(prin1-safe-http-string ,value) res))))))

(defun html-body-key-form (string-code has-inv args body)
  ;; do what's needed to handle given keywords in the args
  ;; then do the body
  (when (and args (atom args))
    ;; single arg 
    (return-from html-body-key-form
      (case args
	(:set (if has-inv
		  `(write-string  ,(format nil "<~a>" string-code)
				  *html-stream*)
		`(write-string  ,(format nil "<~a />" string-code)
				*html-stream*)))
	(:unset (when has-inv
		  `(write-string  ,(format nil "</~a>" string-code)
				  *html-stream*)))
	(t (error "illegal arg ~s to ~s" args string-code)))))
  
  (unless (evenp (length args))
    (warn "arg list ~s isn't even" args))
  
  
  (if args
      `(progn (write-string ,(format nil "<~a" string-code)
			    *html-stream*)

	      ,@(process-attributes args)
	      
	      ,(unless has-inv `(write-string " /" *html-stream*))
	      (write-string ">" *html-stream*)
	      ,@body
	      ,(when (and body has-inv)
		 `(write-string ,(format nil "</~a>" string-code)
				*html-stream*)))
    (if has-inv
	`(progn (write-string ,(format nil "<~a>" string-code)
			      *html-stream*)
		,@body
		,(when body
		   `(write-string ,(format nil "</~a>" string-code)
				  *html-stream*)))
      `(progn (write-string ,(format nil "<~a />" string-code)
			    *html-stream*)))))



(defun princ-http (val)
  ;; print the given value to the http stream using ~a
  (format *html-stream* "~a" val))

(defun prin1-http (val)
  ;; print the given value to the http stream using ~s
  (format *html-stream* "~s" val))


(defun princ-safe-http (val)
  (emit-safe *html-stream* (format nil "~a" val)))

(defun prin1-safe-http (val)
  (emit-safe *html-stream* (format nil "~s" val)))


(defun prin1-safe-http-string (val)
  ;; used only in a parameter value situation
  ;;
  ;; if the parameter value is the symbol with the empty print name
  ;; then turn this into a singleton object.  Thus || is differnent
  ;; than "".
  ;;
  ;; print the contents inside a string double quotes (which should
  ;; not be turned into &quot;'s
  ;; symbols are turned into their name
  ;;
  ;; non-string and non-symbols are written to a string and quoted
  
  (unless (and (symbolp val)
	       (equal "" (symbol-name val)))
    (write-char #\= *html-stream*)
    (when (not (or (stringp val)
		   (symbolp val)))
      (setq val (write-to-string val)))
    (if (or (stringp val)
	    (and (symbolp val) 
		 (setq val (string-downcase
			    (symbol-name val)))))
	(progn
	  (write-char #\" *html-stream*)
	  (emit-safe *html-stream* val)
	  (write-char #\" *html-stream*))
      (prin1-safe-http val))))


(defun emit-safe (stream string)
  "Send the string to the http response stream watching out for
  special html characters and encoding them appropriately."
  (do* ((i 0 (1+ i))
	(start i)
	(end (length string)))
      ((>= i end)
       (when (< start i)
	 (write-sequence string stream :start start :end i)))
      
    (let* ((ch (schar string i))
	   (cvt (case ch
		  (#\< "&lt;")
		  (#\> "&gt;")
		  (#\& "&amp;")
		  (#\" "&quot;"))))
      (when cvt
	 ;; must do a conversion, emit previous chars first
	(when (< start i)
	  (write-sequence string stream :start start :end i))
	(write-string cvt stream)
	(setq start (1+ i))))))
	
		

(defun html-print-list (list-of-forms stream &key unknown)
  ;; html print a list of forms
  (dolist (x list-of-forms)
    (html-print-subst x nil stream unknown)))


(defun html-print-list-subst (list-of-forms subst stream &key unknown)
  ;; html print a list of forms
  (dolist (x list-of-forms)
    (html-print-subst x subst stream unknown)))


(defun html-print (form stream &key unknown)
  (html-print-subst form nil stream unknown))


(defun html-print-subst (form subst stream unknown)
  ;; Print the given lhtml form to the given stream
  (assert (streamp stream))
    
	       
  (let* ((attrs)
	 (attr-name)
	 (name)
	 (possible-kwd (cond 
			((atom form) form)
			((consp (car form))
			 (setq attrs (cdar form))
			 (caar form))
			(t (car form))))
	 print-handler
	 ent)
    (when (keywordp possible-kwd)
      (if (null (setq ent (gethash possible-kwd *html-process-table*)))
	  (if unknown
	      (return-from html-print-subst
		(funcall unknown form stream))
	    (error "unknown html tag: ~s" possible-kwd))
	;; see if we should subst
	(when (and subst 
		   attrs 
		   (setq attr-name (html-process-name-attr ent))
		   (setq name (getf attrs attr-name))
		   (setq attrs (html-find-value name subst)))
	  (return-from html-print-subst
	    (if (functionp (cdr attrs))
		(funcall (cdr attrs) stream)
	      (html-print-subst
	       (cdr attrs)
	       subst
	       stream
	       unknown)))))
      
      (setq print-handler
	(html-process-print ent)))
    
    (cond
     ((atom form)
      (cond
       ((keywordp form)
	(funcall print-handler ent :set nil nil nil nil stream))
       ((stringp form)
	(write-string form stream))
       (t
	(princ form stream))))
     (ent
      (funcall print-handler 
	       ent
	       :full
	       (when (consp (car form)) (cdr (car form)))
	       form 
	       subst
	       unknown
	       stream))
     (t
      (error "Illegal form: ~s" form)))))

  
(defun html-find-value (key subst)
  ; find the (key . value) object in the subst list.
  ; A subst list is an assoc list ((key . value) ....)
  ; but instead of a (key . value) cons you may have an assoc list
  ;
  (let ((to-process nil)
	(alist subst))
    (loop
      (do* ((entlist alist (cdr entlist))
	    (ent (car entlist) (car entlist)))
	  ((null entlist) (setq alist nil))
	(cond
	 ((consp (car ent))
	  ;; this is another alist
	  (when (cdr entlist)
	    (push (cdr entlist) to-process))
	  (setq alist ent)
	  (return))			; exit do*
	 ((equal key (car ent))
	  (return-from html-find-value ent))))
	       
      (when (null alist)
	 ;; we need to find a new alist to process
	(if to-process
	    (setq alist (pop to-process))
	  (return))))))

(defun html-standard-print (ent cmd args form subst unknown stream)
  ;; the print handler for the normal html operators
  (ecase cmd
    (:set ; just turn it on
     (format stream "<~a>" (html-process-key ent)))
    (:full ; set, do body and then unset
     (let (iter)
       (if args
	   (cond
	    ((and (setq iter (getf args :iter))
		  (setq iter (html-find-value iter subst)))
	      ;; remove the iter and pre
	     (setq args (copy-list args))
	     (remf args :iter)
	     (funcall (cdr iter)
		      (cons (cons (caar form)
				  args)
			    (cdr form))
		      subst
		      stream)
	     (return-from html-standard-print))
	    (t
	     (format stream "<~a" (html-process-key ent))
	     (do ((xx args (cddr xx)))
		 ((null xx))
					; assume that the arg is already escaped 
					; since we read it
					; from the parser
	       (format stream " ~a=\"~a\"" (car xx) (cadr xx)))
	     (format stream ">")))
	 (format stream "<~a>" (html-process-key ent)))
       (dolist (ff (cdr form))
	 (html-print-subst ff subst stream unknown)))
     (when (html-process-has-inverse ent)
       ;; end the form
       (format stream "</~a>" (html-process-key ent))))))
     
  
  
		  
		    
  
					 
		      
;; --  defining how html tags are handled. --
;;
;; most tags are handled in a standard way and the def-std-html
;; macro is used to define such tags
;;
;; Some tags need special treatment and def-special-html defines
;; how these are handled.  The tags requiring special treatment
;; are the pseudo tags we added to control operations
;; in the html generator.
;; 
;;
;; tags can be found in three ways:
;;  :br	    		- singleton, no attributes, no body
;;  (:b "foo")          - no attributes but with a body
;;  ((:a href="foo") "balh")  - attributes and body
;;
  
  

(defmacro def-special-html (kwd fcn print-fcn)
  ;; kwd - the tag we're defining behavior for.
  ;; fcn - function to compute the macroexpansion of a use of this
  ;;       tag. args to fcn are: 
  ;;		ent - html-process object holding info on this tag
  ;;		args - list of attribute-values following tag
  ;;		argsp - true if there is a body in this use of the tag
  ;;		body - list of body forms.
  ;; print-fcn - function to print an lhtml form with this tag 
  ;;	    args to fcn are:
  ;;		ent - html-process object holding info on this tag
  ;;		cmd - one of :set, :unset, :full
  ;;		args - list of attribute-value pairs
  ;;		subst - subsitution list
  ;;		unknown - function to call for unknown tags
  ;;		stream - stream to write to
  ;;		
  `(setf (gethash ,kwd *html-process-table*) 
     (make-html-process ,kwd nil nil ,fcn ,print-fcn nil)))


(defmacro named-function (name &body body)
  (declare (ignore name))
  `(function ,@body))

	   
(def-special-html :newline 
    (named-function html-newline-function
      (lambda (ent args argsp body)
	(declare (ignore ent args argsp))
	(when body
	  (error "can't have a body with :newline -- body is ~s" body))
	`(terpri *html-stream*)))
  
  (named-function html-newline-print-function
    (lambda (ent cmd args form subst unknown stream)
      (declare (ignore args ent unknown subst))
      (if (eq cmd :set)
	  (terpri stream)
	(error ":newline in an illegal place: ~s" form)))))

(def-special-html :princ
    (named-function html-princ-function
      (lambda (ent args argsp body)
	(declare (ignore ent args argsp))
	`(progn ,@(mapcar #'(lambda (bod)
			      `(princ-http ,bod))
			  body))))
  
  (named-function html-princ-print-function
    (lambda (ent cmd args form subst unknown stream)
      (declare (ignore args ent unknown subst))
      (assert (eql 2 (length form)))
      (if (eq cmd :full)
	  (format stream "~a" (cadr form))
	(error ":princ must be given an argument")))))

(def-special-html :princ-safe 
    (named-function html-princ-safe-function
      (lambda (ent args argsp body)
	(declare (ignore ent args argsp))
	`(progn ,@(mapcar #'(lambda (bod)
			      `(princ-safe-http ,bod))
			  body))))
  (named-function html-princ-safe-print-function
    (lambda (ent cmd args form subst unknown stream)
      (declare (ignore args ent unknown subst))
      (assert (eql 2 (length form)))
      (if (eq cmd :full)
	  (emit-safe stream (format nil "~a" (cadr form)))
	(error ":princ-safe must be given an argument")))))

(def-special-html :prin1
    (named-function html-prin1-function
      (lambda (ent args argsp body)
	(declare (ignore ent args argsp))
	`(progn ,@(mapcar #'(lambda (bod)
			      `(prin1-http ,bod))
			  body))))
  (named-function html-prin1-print-function
    (lambda (ent cmd args form subst unknown stream)
      (declare (ignore ent args unknown subst))
      (assert (eql 2 (length form)))
      (if (eq cmd :full)
	  (format stream "~s" (cadr form))
	(error ":prin1 must be given an argument")))))

(def-special-html :prin1-safe
    (named-function html-prin1-safe-function
      (lambda (ent args argsp body)
	(declare (ignore ent args argsp))
	`(progn ,@(mapcar #'(lambda (bod)
			      `(prin1-safe-http ,bod))
			  body))))
  (named-function html-prin1-safe-print-function
    (lambda (ent cmd args form subst unknown stream)
      (declare (ignore args ent subst unknown))
      (assert (eql 2 (length form)))
      (if (eq cmd :full)
	  (emit-safe stream (format nil "~s" (cadr form)))
	(error ":prin1-safe must be given an argument")))))

(def-special-html :comment
    (named-function html-comment-function
      (lambda (ent args argsp body)
	;; must use <!--   --> syntax
	(declare (ignore ent args argsp))
	`(progn (write-string "<!--" *html-stream*)
		(html ,@body)
		(write-string "-->" *html-stream*))))
  (named-function html-comment-print-function
    (lambda (ent cmd args form subst unknown stream)
      (declare (ignore ent cmd args subst unknown))
      (format stream "<!--~a-->" (cadr form)))))



(defmacro def-std-html (kwd has-inverse name-attrs)
  (let ((mac-name (intern (format nil "~a-~a" :with-html kwd)))
	(string-code (string-downcase (string kwd))))
    `(progn (setf (gethash ,kwd *html-process-table*)
	      (make-html-process ,kwd ,has-inverse
				     ',mac-name
				     nil
				     #'html-standard-print
				     ',name-attrs))
	    (defmacro ,mac-name (args &rest body)
	      (html-body-key-form ,string-code ,has-inverse args body)))))

    

(def-std-html :a        t nil)
(def-std-html :abbr     t nil)
(def-std-html :acronym  t nil)
(def-std-html :address  t nil)
(def-std-html :applet   t nil)
(def-std-html :area    nil nil)

(def-std-html :b        t nil)
(def-std-html :base     nil nil)
(def-std-html :basefont nil nil)
(def-std-html :bdo      t nil)
(def-std-html :bgsound  nil nil)
(def-std-html :big      t nil)
(def-std-html :blink    t nil)
(def-std-html :blockquote  t nil)
(def-std-html :body      t nil)
(def-std-html :br       nil nil)
(def-std-html :button   nil nil)

(def-std-html :caption  t nil)
(def-std-html :center   t nil)
(def-std-html :cite     t nil)
(def-std-html :code     t nil)
(def-std-html :col      nil nil)
(def-std-html :colgroup nil nil)

(def-std-html :dd        t nil)
(def-std-html :del       t nil)
(def-std-html :dfn       t nil)
(def-std-html :dir       t nil)
(def-std-html :div       t nil)
(def-std-html :dl        t nil)
(def-std-html :dt        t nil)

(def-std-html :em        t nil)
(def-std-html :embed     t nil)

(def-std-html :fieldset        t nil)
(def-std-html :font        t nil)
(def-std-html :form        t :name)
(def-std-html :frame        t nil)
(def-std-html :frameset        t nil)

(def-std-html :h1        t nil)
(def-std-html :h2        t nil)
(def-std-html :h3        t nil)
(def-std-html :h4        t nil)
(def-std-html :h5        t nil)
(def-std-html :h6        t nil)
(def-std-html :head        t nil)
(def-std-html :hr        nil nil)
(def-std-html :html        t nil)

(def-std-html :i     t nil)
(def-std-html :iframe     t nil)
(def-std-html :ilayer     t nil)
(def-std-html :img     nil :id)
(def-std-html :input     nil nil)
(def-std-html :ins     t nil)
(def-std-html :isindex    nil nil)

(def-std-html :kbd  	t nil)
(def-std-html :keygen  	nil nil)

(def-std-html :label  	t nil)
(def-std-html :layer  	t nil)
(def-std-html :legend  	t nil)
(def-std-html :li  	t nil)
(def-std-html :link  	nil nil)
(def-std-html :listing  t nil)

(def-std-html :map  	t nil)
(def-std-html :marquee  t nil)
(def-std-html :menu  	t nil)
(def-std-html :meta  	nil nil)
(def-std-html :multicol t nil)

(def-std-html :nobr  	t nil)
(def-std-html :noembed  t nil)
(def-std-html :noframes t nil)
(def-std-html :noscript t nil)

(def-std-html :object  	t nil)
(def-std-html :ol  	t nil)
(def-std-html :optgroup t nil)
(def-std-html :option  	t nil)

(def-std-html :p  	t nil)
(def-std-html :param  	t nil)
(def-std-html :plaintext  nil nil)
(def-std-html :pre  	t nil)

(def-std-html :q  	t nil)

(def-std-html :s  	t nil)
(def-std-html :samp  	t nil)
(def-std-html :script  	t nil)
(def-std-html :select  	t nil)
(def-std-html :server  	t nil)
(def-std-html :small  	t nil)
(def-std-html :spacer  	nil nil)
(def-std-html :span  	t :id)
(def-std-html :strike  	t nil)
(def-std-html :strong  	t nil)
(def-std-html :style    t nil)  
(def-std-html :sub  	t nil)
(def-std-html :sup  	t nil)

(def-std-html :table  	t :name)
(def-std-html :tbody  	t nil)
(def-std-html :td  	t nil)
(def-std-html :textarea  t nil)
(def-std-html :tfoot  	t nil)
(def-std-html :th  	t nil)
(def-std-html :thead  	t nil)
(def-std-html :title  	t nil)
(def-std-html :tr  	t nil)
(def-std-html :tt  	t nil)

(def-std-html :u 	t nil)
(def-std-html :ul 	t nil)

(def-std-html :var 	t nil)

(def-std-html :wbr  	nil nil)

(def-std-html :xmp 	t nil)




;;; KMR Local Additions

(def-special-html :jscript
    (named-function html-comment-function
      (lambda (ent args argsp body)
	;; must use <!--   --> syntax
	(declare (ignore ent args argsp))
	`(progn
	  #+ignore
	  (write-string "<script language=\"JavaScript\" type=\"text/javascript\">" *html-stream*)
	  (write-string "<script type=\"text/javascript\">" *html-stream*)
	  (write-char #\newline *html-stream*)
	  (write-string "// <![CDATA[" *html-stream*)
	  (write-char #\newline *html-stream*)
	  (html ,@body)
	  (write-char #\newline *html-stream*)
	  (write-string "// ]]>" *html-stream*)
	  (write-char #\newline *html-stream*)
	  (write-string "</script>" *html-stream*))))
  (named-function html-comment-print-function
    (lambda (ent cmd args form subst unknown stream)
      (declare (ignore ent cmd args subst unknown))
      (format stream "<script language=\"JavaScript\" type=\"text/javascript\">~%// <![CDATA[~%~A~%// ]]>~%</script>"
	      (cadr form)))))

(def-special-html :nbsp 
    (named-function html-nbsp-function
      (lambda (ent args argsp body)
	(declare (ignore ent args argsp))
	(when body
	  (error "can't have a body with :nbsp -- body is ~s" body))
	`(write-string "&nbsp;" *html-stream*)))
  
  (named-function html-nbsp-print-function
    (lambda (ent cmd args form subst unknown stream)
      (declare (ignore args ent unknown subst))
      (if (eq cmd :set)
	  (write-string "&nbsp;" stream)
	(error ":nbsp in an illegal place: ~s" form)))))


(def-special-html :load-file
    (named-function html-nbsp-function
      (lambda (ent args argsp body)
	(declare (ignore ent args argsp))
	(unless body
	  (error "must have a body with :load-file"))
	`(progn ,@(mapcar #'(lambda (bod)
			      `(lml-load ,bod))
			  body))))
  
  (named-function html-nbsp-print-function
    (lambda (ent cmd args form subst unknown stream)
      (declare (ignore ent unknown subst stream args))
      (assert (eql 2 (length form)))
      (if (eq cmd :full)
	  (lml-load (cadr form))
	(error ":load-file must be given an argument")))))

(def-special-html :insert-file
    (named-function html-nbsp-function
      (lambda (ent args argsp body)
	(declare (ignore ent args argsp))
	(unless body
	  (error "must have a body with :insert-file"))
	`(progn ,@(mapcar #'(lambda (bod)
			      `(insert-file ,bod))
			  body))))
  
  (named-function html-nbsp-print-function
    (lambda (ent cmd args form subst unknown stream)
      (declare (ignore ent unknown subst stream args))
      (assert (eql 2 (length form)))
      (if (eq cmd :full)
	  (insert-file (cadr form))
	(error ":insert-file must be given an argument")))))

(def-special-html :write-string
    (named-function html-write-string-function
      (lambda (ent args argsp body)
	(declare (ignore ent args argsp))
	(if (= (length body) 1)
	    `(write-string ,(car body) *html-stream*)
	  `(progn ,@(mapcar #'(lambda (bod)
				`(write-string ,bod *html-stream*))
			    body)))))
  
  (named-function html-write-string-print-function
    (lambda (ent cmd args form subst unknown stream)
      (declare (ignore args ent unknown subst))
      (assert (eql 2 (length form)))
      (if (eq cmd :full)
	  (write-string (cadr form) stream)
	  (error ":write-string must be given an argument")))))

(def-special-html :write-char
    (named-function html-write-char-function
      (lambda (ent args argsp body)
	(declare (ignore ent args argsp))
	`(progn ,@(mapcar #'(lambda (bod)
			      `(write-char ,bod *html-stream*))
			  body))))
  
  (named-function html-write-char-print-function
    (lambda (ent cmd args form subst unknown stream)
      (declare (ignore args ent unknown subst))
      (assert (eql 2 (length form)))
      (if (eq cmd :full)
	  (write-char (cadr form) stream)
	  (error ":write-char must be given an argument")))))



