htmlgen.lisp

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