htmlgen.lisp

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