htmlgen.lisp

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