Gaucheでテンプレートエンジン(作りかけ)

Schemerは目に優しい丸括弧のSXMLで片付けてしまいますが、テンプレートエンジンもあると便利かなと思って、半日仕事ででっちあげました。単純なXSLTです。
作りかけです。バグがあります。コードもひどいです。コメントお願いします。

仕様

挿入

<p> Hello, #{S式} </p> 
HTMLエスケープなし

<p> Hello, ${S式} </p>
HTMLエスケープあり

<p> Hello, <?scm S式 ?> </p>
HTMLエスケープなし
XMLのPIなので、S式中でダブルクオートなどのHTML特殊文字が使える

条件処理

<choose test="真偽値を返すS式">
  <then>...</then>
  <else>...</else>
</choose>
thenノード、elseノードは省略可

繰り返し処理

<foreach var="リストを返すS式">
  ...
</foreach>

例

掛け算表

<table>
  <foreach i="(list 1 2 3)">
    <tr>
      <foreach j="(list 1 2 3)">
	<td>#{(* i j)}</td>
      </foreach>
    </tr>
  </foreach>
</table>

<table>
  <tr>
    <td>1</td>
    <td>2</td>
    <td>3</td>
  </tr>
  <tr>
    <td>2</td>
    <td>4</td>
    <td>6</td>
  </tr>
  <tr>
    <td>3</td>
    <td>6</td>
    <td>9</td>
  </tr>
</table>

挿入例1 & 条件処理

<foreach n="(list 0 1 2 3 4 5 6)">
  <choose test="(= n 6)">
    <then>
      <p>That's all.</p>
    </then>
    <else>
      <p>Factorial #{n} = #{(fact n)}</p>
    </else>
  </choose>
</foreach>

<p>Factorial 0 = 1</p>
<p>Factorial 1 = 1</p>
<p>Factorial 2 = 2</p>
<p>Factorial 3 = 6</p>
<p>Factorial 4 = 24</p>
<p>Factorial 5 = 120</p>
<p>That's all.</p>

挿入例2

<foreach fruit="items">
  <a href="http://localhost/fruit/${fruit}">
    Yummy <?scm (string-append fruit "!") ?>
  </a>
</foreach>

<a href="http://localhost/fruit/apple">
    Yummy apple!</a>
<a href="http://localhost/fruit/orange">
    Yummy orange!</a>
<a href="http://localhost/fruit/melon">
    Yummy melon!</a>

バグ

私のコードにバグがあって、こんな簡単な入れ子のテンプレートが、処理できません。
このバグが、なかなかとれなくて困っています。私の根本的な設計ミスだと思うので、ぜひ助言をください。

<choose test="(= 1 1)">
  <then>
    <foreach i="(list 0 1 2 3)">
      <choose test="#t">
	<then>
	  <foreach j="(list 0 1 2 3)">
            <p>#{(+ i j)}</p>
	  </foreach>
	</then>
      </choose>
    </foreach>
  </then>
</choose>

コード

(use srfi-1)
(use sxml.ssax)
(use sxml.serializer)
(use sxml.tools)
(use sxml.tree-trans)

;;文字列 "Factorial #{n} = #{(fact n)}"から
;;S式 (string-append "Factorial " (x->string n) " = " (x->string (fact n))) を生成する

(define (process-text text)
  (if (not (string? text))
    text
    (let loop ((l '())
	       (text text))
      (cond 
       ((#/\#\{([^\}]*)\}/ text) =>
	(lambda (m)
	  (loop (cons `(x->string ,(read-from-string (m 1))) (cons (m 'before) l)) (m 'after))))
       ((#/\$\{([^\}]*)\}/ text) =>
	(lambda (m)
	  (loop (cons `(sxml:string->html (x->string ,(read-from-string (m 1)))) (cons (m 'before) l)) (m 'after))))
       ((null? l) text)
       (else (list 'unquote `(string-append ,@(reverse (cons text l)))))))))

(define (transform sxml)
  ;; (@ ((href "http://localhost") (name "hoge))) のcdrを取り出す
  (define (attributes-ref a)
    (and (not (null? a))
	 (eq? '@ (car a))
	 (not (null? (cdr a)))
	 (cdr a)))

  (pre-post-order
   sxml
   `((choose *macro* . ,(lambda (tag a . elems)
			  (and-let* ((attr (attributes-ref a)))
			    (let ((test-exp (read-from-string (cadar attr)))
				  (then-exp (or (assq 'then elems) '(then "")))
				  (else-exp (or (assq 'else elems) '(else ""))))
			      (list 'unquote `(if ,test-exp
						,(list 'quasiquote (cadr then-exp))
						,(list 'quasiquote (cadr else-exp))))))))
     (foreach *macro* . ,(lambda (tag a . elems)
			   (and-let* ((attr (attributes-ref a)))
			     (let ((item (caar attr))
				   (items (read-from-string (cadar attr))))
			       `(unquote-splicing (append-map (lambda (,item)
								,(list 'quasiquote elems))
							      ,items))))))
     (*PI* . ,(lambda (tag target str)
		(list 'unquote (read-from-string str))))
     (*text* . ,(lambda (trigger x) 
		  (process-text x)))
     (*default* . ,(lambda x x)))))

(define (eval-sxml env sxml)
  (eval `(let ,env
	   ,(list 'quasiquote sxml))
	(interaction-environment)))

(define (template-engine env in)
  (format #t (srl:sxml->html (eval-sxml env (transform (ssax:xml->sxml in '()))))))

(define (main args)
  (define env '((name "Gemma")
		(items '("apple" "orange" "melon"))
		(fact (lambda (x) (apply * (iota x 1))))))

  (if (null? (cdr args))
    (template-engine env (current-input-port))
    (call-with-input-file (cadr args)
      (lambda (in)
	(template-engine env in)))))