htmlgen.lisp

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