htmlgen.lisp

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