htmlgen.lisp

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