;; -*- mode: common-lisp; package: lml2 -*-
;;
-;; $Id: htmlgen.lisp,v 1.17 2003/07/21 16:20:47 kevin Exp $
+;; $Id: htmlgen.lisp,v 1.19 2003/07/21 18:10:00 kevin Exp $
;;
;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA
;; copyright (c) 2003 Kevin Rosenberg
)
(defmacro html (&rest forms &environment env)
- ;; just emit html to the current stream
- ;;(process-html-forms forms env)
-
(post-process-html-forms
- (process-html-forms forms env))
- )
+ (process-html-forms forms env)))
(defun post-process-html-forms (input-forms)
- "KMR: Walk through forms and combining write-strings"
+ "KMR: Walk through forms and combine write-strings"
(let (res strs last-stream)
(flet ((flush-strings ()
(when strs
((atom form)
(flush-strings)
(push form res))
+ ((and (eq (car form) 'cl:write-string)
+ (stringp (cadr form)))
+ (if strs
+ (if (eq last-stream (third form))
+ (setq strs (concatenate 'string strs (second form)))
+ (progn
+ (flush-strings)
+ (setq strs (second form))
+ (setq last-stream (third form))))
+ (progn
+ (setq strs (second form))
+ (setq last-stream (third form)))))
(t
- (cond
- ((eq (car form) 'cl:write-string)
- (if strs
- (if (eq last-stream (third form))
- (setq strs (concatenate 'string strs (second form)))
- (progn
- (flush-strings)
- (setq strs (second form))
- (setq last-stream (third form))))
- (progn
- (setq strs (second form))
- (setq last-stream (third form)))))
- (t
- (flush-strings)
- (push form res)))))))))
+ (flush-strings)
+ (push (post-process-html-forms form) res)))))))
(defmacro html-out-stream-check (stream)
(named-function html-write-string-function
(lambda (ent args argsp body)
(declare (ignore ent args argsp))
- `(progn ,@(mapcar #'(lambda (bod)
- `(write-string ,bod *html-stream*))
- body))))
+ (if (= (length body) 1)
+ `(write-string ,(car body) *html-stream*)
+ `(progn ,@(mapcar #'(lambda (bod)
+ `(write-string ,bod *html-stream*))
+ body)))))
(named-function html-write-string-print-function
(lambda (ent cmd args form subst unknown stream)