htmlgen.lisp

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