htmlgen.lisp

   1 ;; -*- mode: common-lisp; package: lml2 -*-
   2 ;;
   3 ;; $Id: htmlgen.lisp,v 1.4 2003/06/24 16:30:05 kevin Exp $
   4 ;;
   5 ;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA
   6 ;; copyright (c) 2003 Kevin Rosenberg
   7 ;;
   8 ;; Main changes from Allegro version:
   9 ;;    - Support XHTML
  10 ;;    - lowercase symbol names
  11 ;;
  12 ;; This code is free software; you can redistribute it and/or
  13 ;; modify it under the terms of the version 2.1 of
  14 ;; the GNU Lesser General Public License as published by
  15 ;; the Free Software Foundation, as clarified by the AllegroServe
  16 ;; prequel found in license-allegroserve.txt.
  17
  18
  19 (in-package #:lml2)
  20
  21
  22 ;; html generation
  23
  24 (defstruct (html-process (:type list) (:constructor
  25                                        make-html-process (key has-inverse
  26                                                               macro special
  27                                                               print
  28                                                               name-attr
  29                                                               )))
  30   key           ; keyword naming this tag
  31   has-inverse   ; t if the / form is used
  32   macro         ; the macro to define this
  33   special       ; if true then call this to process the keyword and return
  34                 ; the macroexpansion
  35   print         ; function used to handle this in html-print
  36   name-attr     ; attribute symbols which can name this object for subst purposes
  37   )
  38
  39
  40 (defparameter *html-process-table*
  41     (make-hash-table :test #'equal) ; #'eq is accurate but want to avoid rehashes
  42   )
  43
  44 (defmacro html (&rest forms &environment env)
  45   ;; just emit html to the current stream
  46   (process-html-forms forms env))
  47
  48 (defmacro html-out-stream-check (stream)
  49   ;; ensure that a real stream is passed to this function
  50   `(let ((.str. ,stream))
  51      (if* (not (streamp .str.))
  52         then (error "html-stream must be passed a stream object, not ~s"
  53                     .str.))
  54      .str.))
  55
  56
  57 (defmacro html-stream (stream &rest forms)
  58   ;; set output stream and emit html
  59   `(let ((*html-stream* (html-out-stream-check ,stream))) (html ,@forms)))
  60
  61
  62 (defun process-html-forms (forms env)
  63   (let (res)
  64     (flet ((do-ent (ent args argsp body)
  65              ;; ent is an html-process object associated with the
  66              ;;     html tag we're processing
  67              ;; args is the list of values after the tag in the form
  68              ;;     ((:tag &rest args) ....)
  69              ;; argsp is true if this isn't a singleton tag  (i.e. it has
  70              ;;     a body) .. (:tag ...) or ((:tag ...) ...)
  71              ;; body is the body if any of the form
  72              ;;
  73              (let (spec)
  74                (if* (setq spec (html-process-special ent))
  75                   then ; do something different
  76                        (push (funcall spec ent args argsp body) res)
  77                 elseif (null argsp)
  78                   then ; singleton tag, just do the set
  79                        (push `(,(html-process-macro ent) :set) res)
  80                        nil
  81                   else (if* (equal args '(:unset))
  82                           then ; ((:tag :unset)) is a special case.
  83                                ; that allows us to close off singleton tags
  84                                ; printed earlier.
  85                                (push `(,(html-process-macro ent) :unset) res)
  86                                nil
  87                           else ; some args
  88                                (push `(,(html-process-macro ent) ,args
  89                                                                  ,(process-html-forms body env))
  90                                      res)
  91                                nil)))))
  92
  93
  94
  95       (do* ((xforms forms (cdr xforms))
  96             (form (car xforms) (car xforms)))
  97           ((null xforms))
  98
  99         (setq form (macroexpand form env))
 100
 101         (if* (atom form)
 102            then (if* (keywordp form)
 103                    then (let ((ent (gethash form *html-process-table*)))
 104                           (if* (null ent)
 105                              then (error "unknown html keyword ~s"
 106                                          form)
 107                              else (do-ent ent nil nil nil)))
 108                  elseif (stringp form)
 109                    then ; turn into a print of it
 110                         (push `(write-string ,form *html-stream*) res)
 111                    else (push form res))
 112            else (let ((first (car form)))
 113                   (if* (keywordp first)
 114                      then ; (:xxx . body) form
 115                           (let ((ent (gethash first
 116                                             *html-process-table*)))
 117                             (if* (null ent)
 118                                then (error "unknown html keyword ~s"
 119                                            form)
 120                                else (do-ent ent nil t (cdr form))))
 121                    elseif (and (consp first) (keywordp (car first)))
 122                      then ; ((:xxx args ) . body)
 123                           (let ((ent (gethash (car first)
 124                                             *html-process-table*)))
 125                             (if* (null ent)
 126                                then (error "unknown html keyword ~s"
 127                                            form)
 128                                else (do-ent ent (cdr first) t (cdr form))))
 129                      else (push form res))))))
 130     `(progn ,@(nreverse res))))
 131
 132
 133 (defun html-atom-check (args open close body)
 134   (if* (and args (atom args))
 135      then (let ((ans (case args
 136                        (:set `(write-string  ,open *html-stream*))
 137                        (:unset `(write-string  ,close *html-stream*))
 138                        (t (error "illegal arg ~s to ~s" args open)))))
 139             (if* (and ans body)
 140                then (error "can't have a body form with this arg: ~s"
 141                            args)
 142                else ans))))
 143
 144 (defun html-body-form (open close body)
 145   ;; used when args don't matter
 146   `(progn (write-string  ,open *html-stream*)
 147           ,@body
 148           (write-string  ,close *html-stream*)))
 149
 150
 151 (defun html-body-key-form (string-code has-inv args body)
 152   ;; do what's needed to handle given keywords in the args
 153   ;; then do the body
 154   (if* (and args (atom args))
 155      then ; single arg
 156           (return-from html-body-key-form
 157             (case args
 158               (:set (if* has-inv
 159                          then `(write-string  ,(format nil "<~a>" string-code)
 160                                 *html-stream*)
 161                          else `(write-string  ,(format nil "<~a />" string-code)
 162                                 *html-stream*)))
 163               (:unset (if* has-inv
 164                            then `(write-string  ,(format nil "</~a>" string-code)
 165                                   *html-stream*)))
 166               (t (error "illegal arg ~s to ~s" args string-code)))))
 167
 168   (if* (not (evenp (length args)))
 169        then (warn "arg list ~s isn't even" args))
 170
 171
 172   (if* args
 173      then `(progn (write-string ,(format nil "<~a" string-code)
 174                    *html-stream*)
 175             ,@(do ((xx args (cddr xx))
 176                    (res))
 177                   ((null xx)
 178                    (nreverse res))
 179                   (if* (eq :if* (car xx))
 180                        then ; insert following conditionally
 181                        (push `(if* ,(cadr xx)
 182                                then (write-string
 183                                      ,(format nil " ~(~a~)" (caddr xx))
 184                                      *html-stream*)
 185                                (prin1-safe-http-string ,(cadddr xx)))
 186                              res)
 187                        (pop xx) (pop xx)
 188                        else
 189
 190                        (push `(write-string
 191                                ,(format nil " ~(~a~)" (car xx))
 192                                *html-stream*)
 193                              res)
 194                        (push `(prin1-safe-http-string ,(cadr xx)) res)))
 195
 196             ,(unless has-inv `(write-string " /" *html-stream*))
 197             (write-string ">" *html-stream*)
 198             ,@body
 199             ,(if* (and body has-inv)
 200                   then `(write-string ,(format nil "</~a>" string-code)
 201                          *html-stream*)))
 202      else
 203      (if* has-inv
 204           then
 205           `(progn (write-string ,(format nil "<~a>" string-code)
 206                    *html-stream*)
 207             ,@body
 208             ,(if* body
 209                   then `(write-string ,(format nil "</~a>" string-code)
 210                          *html-stream*)))
 211           else
 212           `(progn (write-string ,(format nil "<~a />" string-code)
 213                    *html-stream*)))))
 214
 215
 216
 217 (defun princ-http (val)
 218   ;; print the given value to the http stream using ~a
 219   (format *html-stream* "~a" val))
 220
 221 (defun prin1-http (val)
 222   ;; print the given value to the http stream using ~s
 223   (format *html-stream* "~s" val))
 224
 225
 226 (defun princ-safe-http (val)
 227   (emit-safe *html-stream* (format nil "~a" val)))
 228
 229 (defun prin1-safe-http (val)
 230   (emit-safe *html-stream* (format nil "~s" val)))
 231
 232
 233 (defun prin1-safe-http-string (val)
 234   ;; used only in a parameter value situation
 235   ;;
 236   ;; if the parameter value is the symbol with the empty print name
 237   ;; then turn this into a singleton object.  Thus || is differnent
 238   ;; than "".
 239   ;;
 240   ;; print the contents inside a string double quotes (which should
 241   ;; not be turned into &quot;'s
 242   ;; symbols are turned into their name
 243   (if* (and (symbolp val)
 244             (equal "" (symbol-name val)))
 245      thenret ; do nothing
 246      else (write-char #\= *html-stream*)
 247           (if* (or (stringp val)
 248                    (and (symbolp val)
 249                         (setq val (string-downcase
 250                                    (symbol-name val)))))
 251              then (write-char #\" *html-stream*)
 252                   (emit-safe *html-stream* val)
 253                   (write-char #\" *html-stream*)
 254              else (prin1-safe-http val))))
 255
 256
 257
 258 (defun emit-safe (stream string)
 259   ;; send the string to the http response stream watching out for
 260   ;; special html characters and encoding them appropriately
 261   (do* ((i 0 (1+ i))
 262         (start i)
 263         (end (length string)))
 264       ((>= i end)
 265        (if* (< start i)
 266           then  (write-sequence string
 267                                 stream
 268                                 :start start
 269                                 :end i)))
 270
 271
 272     (let ((ch (schar string i))
 273           (cvt ))
 274       (if* (eql ch #\<)
 275          then (setq cvt "&lt;")
 276        elseif (eq ch #\>)
 277          then (setq cvt "&gt;")
 278        elseif (eq ch #\&)
 279          then (setq cvt "&amp;")
 280        elseif (eq ch #\")
 281          then (setq cvt "&quot;"))
 282       (if* cvt
 283          then ; must do a conversion, emit previous chars first
 284
 285               (if* (< start i)
 286                  then  (write-sequence string
 287                                        stream
 288                                        :start start
 289                                        :end i))
 290               (write-string cvt stream)
 291
 292               (setq start (1+ i))))))
 293
 294
 295
 296 (defun html-print-list (list-of-forms stream &key unknown)
 297   ;; html print a list of forms
 298   (dolist (x list-of-forms)
 299     (html-print-subst x nil stream unknown)))
 300
 301
 302 (defun html-print-list-subst (list-of-forms subst stream &key unknown)
 303   ;; html print a list of forms
 304   (dolist (x list-of-forms)
 305     (html-print-subst x subst stream unknown)))
 306
 307
 308 (defun html-print (form stream &key unknown)
 309   (html-print-subst form nil stream unknown))
 310
 311
 312 (defun html-print-subst (form subst stream unknown)
 313   ;; Print the given lhtml form to the given stream
 314   (assert (streamp stream))
 315
 316
 317   (let* ((attrs)
 318          (attr-name)
 319          (name)
 320          (possible-kwd (if* (atom form)
 321                           then form
 322                         elseif (consp (car form))
 323                           then (setq attrs (cdar form))
 324                                (caar form)
 325                           else (car form)))
 326          print-handler
 327          ent)
 328     (if* (keywordp possible-kwd)
 329        then (if* (null (setq ent (gethash possible-kwd *html-process-table*)))
 330                then (if* unknown
 331                        then (return-from html-print-subst
 332                               (funcall unknown form stream))
 333                        else (error "unknown html tag: ~s" possible-kwd))
 334                else ; see if we should subst
 335                     (if* (and subst
 336                               attrs
 337                               (setq attr-name (html-process-name-attr ent))
 338                               (setq name (getf attrs attr-name))
 339                               (setq attrs (html-find-value name subst)))
 340                        then
 341                             (return-from html-print-subst
 342                               (if* (functionp (cdr attrs))
 343                                  then
 344                                       (funcall (cdr attrs) stream)
 345                                  else (html-print-subst
 346                                        (cdr attrs)
 347                                        subst
 348                                        stream
 349                                        unknown)))))
 350
 351             (setq print-handler
 352               (html-process-print ent)))
 353     (if* (atom form)
 354        then (if* (keywordp form)
 355                then (funcall print-handler ent :set nil nil nil nil stream)
 356              elseif (stringp form)
 357                then (write-string form stream)
 358                else (princ form stream))
 359      elseif ent
 360        then (funcall print-handler
 361                      ent
 362                      :full
 363                      (if* (consp (car form)) then (cdr (car form)))
 364                      form
 365                      subst
 366                      unknown
 367                      stream)
 368        else (error "Illegal form: ~s" form))))
 369
 370
 371 (defun html-find-value (key subst)
 372   ; find the (key . value) object in the subst list.
 373   ; A subst list is an assoc list ((key . value) ....)
 374   ; but instead of a (key . value) cons you may have an assoc list
 375   ;
 376   (let ((to-process nil)
 377         (alist subst))
 378     (loop
 379       (do* ((entlist alist (cdr entlist))
 380             (ent (car entlist) (car entlist)))
 381           ((null entlist) (setq alist nil))
 382         (if* (consp (car ent))
 383            then ; this is another alist
 384                 (if* (cdr entlist)
 385                    then (push (cdr entlist) to-process))
 386                 (setq alist ent)
 387                 (return) ; exit do*
 388          elseif (equal key (car ent))
 389            then (return-from html-find-value ent)))
 390
 391       (if* (null alist)
 392          then ; we need to find a new alist to process
 393
 394               (if* to-process
 395                  then (setq alist (pop to-process))
 396                  else (return))))))
 397
 398 (defun html-standard-print (ent cmd args form subst unknown stream)
 399   ;; the print handler for the normal html operators
 400   (ecase cmd
 401     (:set ; just turn it on
 402      (format stream "<~a>" (html-process-key ent)))
 403     (:full ; set, do body and then unset
 404      (let (iter)
 405        (if* args
 406           then (if* (and (setq iter (getf args :iter))
 407                          (setq iter (html-find-value iter subst)))
 408                   then ; remove the iter and pre
 409                        (setq args (copy-list args))
 410                        (remf args :iter)
 411                        (funcall (cdr iter)
 412                                 (cons (cons (caar form)
 413                                             args)
 414                                       (cdr form))
 415                                 subst
 416                                 stream)
 417                        (return-from html-standard-print)
 418                   else
 419                        (format stream "<~a" (html-process-key ent))
 420                        (do ((xx args (cddr xx)))
 421                            ((null xx))
 422                          ; assume that the arg is already escaped
 423                          ; since we read it
 424                          ; from the parser
 425                          (format stream " ~a=\"~a\"" (car xx) (cadr xx)))
 426                        (format stream ">"))
 427           else (format stream "<~a>" (html-process-key ent)))
 428        (dolist (ff (cdr form))
 429          (html-print-subst ff subst stream unknown)))
 430      (if* (html-process-has-inverse ent)
 431         then ; end the form
 432              (format stream "</~a>" (html-process-key ent))))))
 433
 434
 435
 436
 437
 438
 439
 440
 441 ;; --  defining how html tags are handled. --
 442 ;;
 443 ;; most tags are handled in a standard way and the def-std-html
 444 ;; macro is used to define such tags
 445 ;;
 446 ;; Some tags need special treatment and def-special-html defines
 447 ;; how these are handled.  The tags requiring special treatment
 448 ;; are the pseudo tags we added to control operations
 449 ;; in the html generator.
 450 ;;
 451 ;;
 452 ;; tags can be found in three ways:
 453 ;;  :br                 - singleton, no attributes, no body
 454 ;;  (:b "foo")          - no attributes but with a body
 455 ;;  ((:a href="foo") "balh")  - attributes and body
 456 ;;
 457
 458
 459
 460 (defmacro def-special-html (kwd fcn print-fcn)
 461   ;; kwd - the tag we're defining behavior for.
 462   ;; fcn - function to compute the macroexpansion of a use of this
 463   ;;       tag. args to fcn are:
 464   ;;            ent - html-process object holding info on this tag
 465   ;;            args - list of attribute-values following tag
 466   ;;            argsp - true if there is a body in this use of the tag
 467   ;;            body - list of body forms.
 468   ;; print-fcn - function to print an lhtml form with this tag
 469   ;;        args to fcn are:
 470   ;;            ent - html-process object holding info on this tag
 471   ;;            cmd - one of :set, :unset, :full
 472   ;;            args - list of attribute-value pairs
 473   ;;            subst - subsitution list
 474   ;;            unknown - function to call for unknown tags
 475   ;;            stream - stream to write to
 476   ;;
 477   `(setf (gethash ,kwd *html-process-table*)
 478      (make-html-process ,kwd nil nil ,fcn ,print-fcn nil)))
 479
 480
 481 (defmacro named-function (name &body body)
 482   (declare (ignore name))
 483   `(function ,@body))
 484
 485
 486 (def-special-html :newline
 487     (named-function html-newline-function
 488       (lambda (ent args argsp body)
 489         (declare (ignore ent args argsp))
 490         (if* body
 491            then (error "can't have a body with :newline -- body is ~s" body))
 492
 493         `(terpri *html-stream*)))
 494
 495   (named-function html-newline-print-function
 496     (lambda (ent cmd args form subst unknown stream)
 497       (declare (ignore args ent unknown subst))
 498       (if* (eq cmd :set)
 499          then (terpri stream)
 500          else (error ":newline in an illegal place: ~s" form)))))
 501
 502 (def-special-html :princ
 503     (named-function html-princ-function
 504       (lambda (ent args argsp body)
 505         (declare (ignore ent args argsp))
 506         `(progn ,@(mapcar #'(lambda (bod)
 507                               `(princ-http ,bod))
 508                           body))))
 509
 510   (named-function html-princ-print-function
 511     (lambda (ent cmd args form subst unknown stream)
 512       (declare (ignore args ent unknown subst))
 513       (assert (eql 2 (length form)))
 514       (if* (eq cmd :full)
 515          then (format stream "~a" (cadr form))
 516          else (error ":princ must be given an argument")))))
 517
 518 (def-special-html :princ-safe
 519     (named-function html-princ-safe-function
 520       (lambda (ent args argsp body)
 521         (declare (ignore ent args argsp))
 522         `(progn ,@(mapcar #'(lambda (bod)
 523                               `(princ-safe-http ,bod))
 524                           body))))
 525   (named-function html-princ-safe-print-function
 526     (lambda (ent cmd args form subst unknown stream)
 527       (declare (ignore args ent unknown subst))
 528       (assert (eql 2 (length form)))
 529       (if* (eq cmd :full)
 530          then (emit-safe stream (format nil "~a" (cadr form)))
 531          else (error ":princ-safe must be given an argument")))))
 532
 533 (def-special-html :prin1
 534     (named-function html-prin1-function
 535       (lambda (ent args argsp body)
 536         (declare (ignore ent args argsp))
 537         `(progn ,@(mapcar #'(lambda (bod)
 538                               `(prin1-http ,bod))
 539                           body))))
 540   (named-function html-prin1-print-function
 541     (lambda (ent cmd args form subst unknown stream)
 542       (declare (ignore ent args unknown subst))
 543       (assert (eql 2 (length form)))
 544       (if* (eq cmd :full)
 545          then (format stream "~s" (cadr form))
 546          else (error ":prin1 must be given an argument")))))
 547
 548 (def-special-html :prin1-safe
 549     (named-function html-prin1-safe-function
 550       (lambda (ent args argsp body)
 551         (declare (ignore ent args argsp))
 552         `(progn ,@(mapcar #'(lambda (bod)
 553                               `(prin1-safe-http ,bod))
 554                           body))))
 555   (named-function html-prin1-safe-print-function
 556     (lambda (ent cmd args form subst unknown stream)
 557       (declare (ignore args ent subst unknown))
 558       (assert (eql 2 (length form)))
 559       (if* (eq cmd :full)
 560          then (emit-safe stream (format nil "~s" (cadr form)))
 561          else (error ":prin1-safe must be given an argument")))))
 562
 563 (def-special-html :comment
 564     (named-function html-comment-function
 565       (lambda (ent args argsp body)
 566         ;; must use <!--   --> syntax
 567         (declare (ignore ent args argsp))
 568         `(progn (write-string "<!--" *html-stream*)
 569                 (html ,@body)
 570                 (write-string "-->" *html-stream*))))
 571   (named-function html-comment-print-function
 572     (lambda (ent cmd args form subst unknown stream)
 573       (declare (ignore ent cmd args subst unknown))
 574       (format stream "<!--~a-->" (cadr form)))))
 575
 576
 577
 578 (defmacro def-std-html (kwd has-inverse name-attrs)
 579   (let ((mac-name (intern (format nil "~a-~a" :with-html kwd)))
 580         (string-code (string-downcase (string kwd))))
 581     `(progn (setf (gethash ,kwd *html-process-table*)
 582               (make-html-process ,kwd ,has-inverse
 583                                      ',mac-name
 584                                      nil
 585                                      #'html-standard-print
 586                                      ',name-attrs))
 587             (defmacro ,mac-name (args &rest body)
 588               (html-body-key-form ,string-code ,has-inverse args body)))))
 589
 590
 591
 592 (def-std-html :a        t nil)
 593 (def-std-html :abbr     t nil)
 594 (def-std-html :acronym  t nil)
 595 (def-std-html :address  t nil)
 596 (def-std-html :applet   t nil)
 597 (def-std-html :area    nil nil)
 598
 599 (def-std-html :b        t nil)
 600 (def-std-html :base     nil nil)
 601 (def-std-html :basefont nil nil)
 602 (def-std-html :bdo      t nil)
 603 (def-std-html :bgsound  nil nil)
 604 (def-std-html :big      t nil)
 605 (def-std-html :blink    t nil)
 606 (def-std-html :blockquote  t nil)
 607 (def-std-html :body      t nil)
 608 (def-std-html :br       nil nil)
 609 (def-std-html :button   nil nil)
 610
 611 (def-std-html :caption  t nil)
 612 (def-std-html :center   t nil)
 613 (def-std-html :cite     t nil)
 614 (def-std-html :code     t nil)
 615 (def-std-html :col      nil nil)
 616 (def-std-html :colgroup nil nil)
 617
 618 (def-std-html :dd        t nil)
 619 (def-std-html :del       t nil)
 620 (def-std-html :dfn       t nil)
 621 (def-std-html :dir       t nil)
 622 (def-std-html :div       t nil)
 623 (def-std-html :dl        t nil)
 624 (def-std-html :dt        t nil)
 625
 626 (def-std-html :em        t nil)
 627 (def-std-html :embed     t nil)
 628
 629 (def-std-html :fieldset        t nil)
 630 (def-std-html :font        t nil)
 631 (def-std-html :form        t :name)
 632 (def-std-html :frame        t nil)
 633 (def-std-html :frameset        t nil)
 634
 635 (def-std-html :h1        t nil)
 636 (def-std-html :h2        t nil)
 637 (def-std-html :h3        t nil)
 638 (def-std-html :h4        t nil)
 639 (def-std-html :h5        t nil)
 640 (def-std-html :h6        t nil)
 641 (def-std-html :head        t nil)
 642 (def-std-html :hr        nil nil)
 643 (def-std-html :html        t nil)
 644
 645 (def-std-html :i     t nil)
 646 (def-std-html :iframe     t nil)
 647 (def-std-html :ilayer     t nil)
 648 (def-std-html :img     nil :id)
 649 (def-std-html :input     nil nil)
 650 (def-std-html :ins     t nil)
 651 (def-std-html :isindex    nil nil)
 652
 653 (def-std-html :kbd      t nil)
 654 (def-std-html :keygen   nil nil)
 655
 656 (def-std-html :label    t nil)
 657 (def-std-html :layer    t nil)
 658 (def-std-html :legend   t nil)
 659 (def-std-html :li       t nil)
 660 (def-std-html :link     nil nil)
 661 (def-std-html :listing  t nil)
 662
 663 (def-std-html :map      t nil)
 664 (def-std-html :marquee  t nil)
 665 (def-std-html :menu     t nil)
 666 (def-std-html :meta     nil nil)
 667 (def-std-html :multicol t nil)
 668
 669 (def-std-html :nobr     t nil)
 670 (def-std-html :noembed  t nil)
 671 (def-std-html :noframes t nil)
 672 (def-std-html :noscript t nil)
 673
 674 (def-std-html :object   t nil)
 675 (def-std-html :ol       t nil)
 676 (def-std-html :optgroup t nil)
 677 (def-std-html :option   t nil)
 678
 679 (def-std-html :p        t nil)
 680 (def-std-html :param    t nil)
 681 (def-std-html :plaintext  nil nil)
 682 (def-std-html :pre      t nil)
 683
 684 (def-std-html :q        t nil)
 685
 686 (def-std-html :s        t nil)
 687 (def-std-html :samp     t nil)
 688 (def-std-html :script   t nil)
 689 (def-std-html :select   t nil)
 690 (def-std-html :server   t nil)
 691 (def-std-html :small    t nil)
 692 (def-std-html :spacer   nil nil)
 693 (def-std-html :span     t :id)
 694 (def-std-html :strike   t nil)
 695 (def-std-html :strong   t nil)
 696 (def-std-html :style    t nil)
 697 (def-std-html :sub      t nil)
 698 (def-std-html :sup      t nil)
 699
 700 (def-std-html :table    t :name)
 701 (def-std-html :tbody    t nil)
 702 (def-std-html :td       t nil)
 703 (def-std-html :textarea  t nil)
 704 (def-std-html :tfoot    t nil)
 705 (def-std-html :th       t nil)
 706 (def-std-html :thead    t nil)
 707 (def-std-html :title    t nil)
 708 (def-std-html :tr       t nil)
 709 (def-std-html :tt       t nil)
 710
 711 (def-std-html :u        t nil)
 712 (def-std-html :ul       t nil)
 713
 714 (def-std-html :var      t nil)
 715
 716 (def-std-html :wbr      nil nil)
 717
 718 (def-std-html :xmp      t nil)
 719
 720
 721
 722
 723 ;;; KMR Local Additions
 724
 725 (def-special-html :jscript
 726     (named-function html-comment-function
 727       (lambda (ent args argsp body)
 728         ;; must use <!--   --> syntax
 729         (declare (ignore ent args argsp))
 730         `(progn
 731           (write-string "<script language=\"JavasSript\" type=\"text/javascript\">" *html-stream*)
 732           (write-char #\newline *html-stream*)
 733           (write-string "//![CDATA[" *html-stream*)
 734           (write-char #\newline *html-stream*)
 735           (html ,@body)
 736           (write-char #\newline *html-stream*)
 737           (write-string "//]]>" *html-stream*)
 738           (write-char #\newline *html-stream*)
 739           (write-string "</script>" *html-stream*))))
 740   (named-function html-comment-print-function
 741     (lambda (ent cmd args form subst unknown stream)
 742       (declare (ignore ent cmd args subst unknown))
 743       (format stream "<script language=\"JavaScript\" type=\"text/javascript\">~%//![CDATA[~%~A~%//]]>~%</script>"
 744               (cadr form)))))
 745
 746 (def-special-html :nbsp
 747     (named-function html-nbsp-function
 748       (lambda (ent args argsp body)
 749         (declare (ignore ent args argsp))
 750         (when body
 751           (error "can't have a body with :nbsp -- body is ~s" body))
 752         `(write-string "&nbsp;" *html-stream*)))
 753
 754   (named-function html-nbsp-print-function
 755     (lambda (ent cmd args form subst unknown stream)
 756       (declare (ignore args ent unknown subst))
 757       (if* (eq cmd :set)
 758          then (write-string "&nbsp;" stream)
 759          else (error ":nbsp in an illegal place: ~s" form)))))
 760
 761 (def-special-html :insert-file
 762     (named-function html-nbsp-function
 763       (lambda (ent args argsp body)
 764         (declare (ignore ent argsp))
 765         (unless body
 766           (error "must have a body with :insert-file"))
 767         `(lml-load-path (car ,args) *html-stream*)))
 768
 769   (named-function html-nbsp-print-function
 770     (lambda (ent cmd args form subst unknown stream)
 771       (declare (ignore args ent unknown subst))
 772       (if* (eq cmd :full)
 773            then (lml-load-path (car args))
 774            else (error ":insert-file must be given an argument")))))