htmlgen.lisp

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