htmlgen.lisp

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