From aa7dc8101d1427566aa90f7f8166daef115b2fd1 Mon Sep 17 00:00:00 2001
From: "Kevin M. Rosenberg" <kevin@rosenberg.net>
Date: Tue, 15 Jul 2003 04:28:56 +0000
Subject: [PATCH] r5306: add new attribute commands

---
 htmlgen.lisp | 59 ++++++++++++++++++++++++++++++++++++++++++++++++----
 utils.lisp   |  6 +++++-
 2 files changed, 60 insertions(+), 5 deletions(-)

diff --git a/htmlgen.lisp b/htmlgen.lisp
index dab8c16..711fcc6 100644
--- a/htmlgen.lisp
+++ b/htmlgen.lisp
@@ -1,6 +1,6 @@
 ;; -*- mode: common-lisp; package: lml2 -*-
 ;;
-;; $Id: htmlgen.lisp,v 1.12 2003/07/13 04:56:12 kevin Exp $
+;; $Id: htmlgen.lisp,v 1.13 2003/07/15 04:28:56 kevin Exp $
 ;;
 ;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA 
 ;; copyright (c) 2003 Kevin Rosenberg
@@ -68,7 +68,7 @@
 	     ;; argsp is true if this isn't a singleton tag  (i.e. it has
 	     ;;     a body) .. (:tag ...) or ((:tag ...) ...)
 	     ;; body is the body if any of the form
-	     ;; 
+	     ;;
 	     (let (spec)
 	       (if* (setq spec (html-process-special ent))
 		  then ; do something different
@@ -84,8 +84,9 @@
 			       (push `(,(html-process-macro ent) :unset) res)
 			       nil
 			  else ; some args
-			       (push `(,(html-process-macro ent) ,args
-								 ,(process-html-forms body env))
+			       (push `(,(html-process-macro ent)
+				       ,args
+				       ,(process-html-forms body env))
 				     res)
 			       nil)))))
 				 
@@ -180,6 +181,32 @@
 			       (prin1-safe-http-string ,(cadddr xx)))
 			     res)
 		       (pop xx) (pop xx)
+		       elseif (eq :fformat (car xx))
+		       then
+		       ;; process :fformat
+		       (unless (and (listp (cadr xx))
+				    (>= (length (cadr xx)) 2))
+			 (error ":fformat must be given a list"))
+		       (push
+			`(write-string 
+			  ,(format nil " ~(~a~)=\"" (car (cadr xx)))
+			  *html-stream*)
+			res)
+		       (push
+			`(fformat *html-stream* ,(cadr (cadr xx))
+			  ,@(cddr (cadr xx)))
+			res)
+		       (push '(write-char #\" *html-stream*) res)
+		       elseif (eq :optional (car xx))
+		       then 
+		       (push
+			`(when ,(cadr (cadr xx))
+			  (write-string
+			   ,(format nil " ~(~a~)=\"" (car (cadr xx)))
+			   *html-stream*)
+			  (fformat *html-stream* "~A\""
+			   ,(cadr (cadr xx))))
+			res)
 		       else 
 		       
 		       (push `(write-string 
@@ -811,3 +838,27 @@
       (if (eq cmd :full)
 	  (write-char (cadr form) stream)
 	  (error ":write-char must be given an argument")))))
+
+;; fast formatter
+(def-special-html :fformat
+    (named-function html-write-char-function
+      (lambda (ent args argsp body)
+	(declare (ignore ent args argsp))
+	`(progn ,@(mapcar #'(lambda (bod)
+			      `(progn
+				(format *html-stream* " ~(~A~)=\"" (car ,bod))
+				(apply #'format *html-stream* (cdr ,bod))
+				(write-char #\" *html-stream*)))
+			  body))))
+  
+  (named-function html-write-char-print-function
+    (lambda (ent cmd args form subst unknown stream)
+      (declare (ignore args ent unknown subst))
+      (assert (eql 2 (length form)))
+      (if (eq cmd :full)
+	  (progn
+	    (format stream " ~(~A~)=\"" (car form))
+	    (apply #'format stream (cdr form))
+	    (write-char #\" stream))
+	  (error ":fformat must be given an argument")))))
+
diff --git a/utils.lisp b/utils.lisp
index a90b325..2a6877f 100644
--- a/utils.lisp
+++ b/utils.lisp
@@ -7,7 +7,7 @@
 ;;;; Author:        Kevin M. Rosenberg
 ;;;; Date Started:  June 2002
 ;;;;
-;;;; $Id: utils.lisp,v 1.3 2003/07/12 17:54:05 kevin Exp $
+;;;; $Id: utils.lisp,v 1.4 2003/07/15 04:28:56 kevin Exp $
 ;;;;
 ;;;; This file, part of LML2, is copyrighted and open-source software.
 ;;;; Rights of modification and redistribution are in the LICENSE file.
@@ -73,3 +73,7 @@
   #-(or allegro clisp cmu scl sbcl cormanlisp lispworks lucid mcl) (truename "."))
 
 
+
+(defun fformat (&rest args)
+  (declare (dynamic-extent args))
+  (apply #'format args))
-- 
2.34.1