From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 5 Mar 2003 01:14:40 +0000 (+0000)
Subject: Restructure XML output procedures to take a rest argument that is a
X-Git-Tag: 20090517-FFI~2006
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=111e661f51828dfac8b8d13aba4a2457f60278e3;p=mit-scheme.git

Restructure XML output procedures to take a rest argument that is a
list of keyword options.  At present, there is only one option,
'start-indent, which turns the indentation on or off.
---

diff --git a/v7/src/xml/xml-output.scm b/v7/src/xml/xml-output.scm
index 52c1e172c..3219fc3a5 100644
--- a/v7/src/xml/xml-output.scm
+++ b/v7/src/xml/xml-output.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml-output.scm,v 1.15 2003/03/01 16:52:53 cph Exp $
+$Id: xml-output.scm,v 1.16 2003/03/05 01:14:40 cph Exp $
 
 Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
@@ -27,114 +27,155 @@ USA.
 
 (declare (usual-integrations))
 
-(define (write-xml-file xml pathname)
+(define (write-xml xml port . options)
+  (write-xml-1 xml port options))
+
+(define (write-xml-file xml pathname . options)
   (call-with-output-file pathname
     (lambda (port)
-      (write-xml xml port))))
+      (write-xml-1 xml port options))))
 
-(define (xml->string xml)
+(define (xml->string xml . options)
   (call-with-output-string
    (lambda (port)
-     (write-xml xml port))))
+     (write-xml-1 xml port options))))
+
+(define (xml->wide-string xml . options)
+  (call-with-wide-output-string
+   (lambda (port)
+     (write-xml-1 xml port options))))
+
+(define (write-xml-1 xml port options)
+  (%write-xml xml (make-ctx port options)))
+
+(define-structure (ctx (type-descriptor ctx-rtd)
+		       (keyword-constructor %make-ctx)
+		       (print-procedure
+			(standard-unparser-method 'XML-OUTPUT-CONTEXT #f)))
+  (port #f read-only #t)
+  ;; Either a non-negative integer (# of columns) or #f.
+  (start-indent #f read-only #t))
+
+(define (make-ctx port options)
+  (apply %make-ctx 'PORT port options))
+
+(define (emit-char char ctx)
+  (write-char char (ctx-port ctx)))
 
-(define-generic write-xml (object port))
+(define (emit-string string ctx)
+  (write-string string (ctx-port ctx)))
 
-(define-method write-xml ((document xml-document-rtd) port)
+(define (emit-newline ctx)
+  (newline (ctx-port ctx)))
+
+(define (ctx-start-col ctx)
+  (let ((indent (ctx-start-indent ctx))
+	(col (output-port/column (ctx-port ctx))))
+    (and indent
+	 col
+	 (+ indent col))))
+
+(define (ctx-x-size ctx)
+  (output-port/x-size (ctx-port ctx)))
+
+(define-generic %write-xml (object ctx))
+
+(define-method %write-xml ((document xml-document-rtd) ctx)
   (if (xml-document-declaration document)
-      (write-xml (xml-document-declaration document) port))
-  (for-each (lambda (object) (write-xml object port))
+      (%write-xml (xml-document-declaration document) ctx))
+  (for-each (lambda (object) (%write-xml object ctx))
 	    (xml-document-misc-1 document))
   (if (xml-document-dtd document)
-      (write-xml (xml-document-dtd document) port))
-  (for-each (lambda (object) (write-xml object port))
+      (%write-xml (xml-document-dtd document) ctx))
+  (for-each (lambda (object) (%write-xml object ctx))
 	    (xml-document-misc-2 document))
-  (write-xml (xml-document-root document) port)
-  (for-each (lambda (object) (write-xml object port))
+  (%write-xml (xml-document-root document) ctx)
+  (for-each (lambda (object) (%write-xml object ctx))
 	    (xml-document-misc-3 document)))
 
-(define-method write-xml ((declaration xml-declaration-rtd) port)
-  (write-string "<?xml version=\"" port)
-  (write-string (xml-declaration-version declaration) port)
-  (write-string "\"" port)
+(define-method %write-xml ((declaration xml-declaration-rtd) ctx)
+  (emit-string "<?xml version=\"" ctx)
+  (emit-string (xml-declaration-version declaration) ctx)
+  (emit-string "\"" ctx)
   (if (xml-declaration-encoding declaration)
       (begin
-	(write-string " encoding=\"" port)
-	(write-string (xml-declaration-encoding declaration) port)
-	(write-string "\"" port)))
+	(emit-string " encoding=\"" ctx)
+	(emit-string (xml-declaration-encoding declaration) ctx)
+	(emit-string "\"" ctx)))
   (if (xml-declaration-standalone declaration)
       (begin
-	(write-string " standalone=\"" port)
-	(write-string (xml-declaration-standalone declaration) port)
-	(write-string "\"" port)))
-  (write-string "?>" port))
+	(emit-string " standalone=\"" ctx)
+	(emit-string (xml-declaration-standalone declaration) ctx)
+	(emit-string "\"" ctx)))
+  (emit-string "?>" ctx))
 
-(define-method write-xml ((element xml-element-rtd) port)
+(define-method %write-xml ((element xml-element-rtd) ctx)
   (let ((name (xml-element-name element))
 	(contents (xml-element-contents element)))
-    (write-string "<" port)
-    (write-xml-name name port)
+    (emit-string "<" ctx)
+    (write-xml-name name ctx)
     (write-xml-attributes (xml-element-attributes element)
 			  (if (pair? contents) 1 3)
-			  port)
+			  ctx)
     (if (pair? contents)
 	(begin
-	  (write-string ">" port)
-	  (for-each (lambda (content) (write-xml content port))
+	  (emit-string ">" ctx)
+	  (for-each (lambda (content) (%write-xml content ctx))
 		    contents)
-	  (write-string "</" port)
-	  (write-xml-name (xml-element-name element) port)
-	  (write-string ">" port))
-	(write-string " />" port))))
-
-(define-method write-xml ((comment xml-comment-rtd) port)
-  (write-string "<!--" port)
-  (write-string (xml-comment-text comment) port)
-  (write-string "-->" port))
-
-(define-method write-xml ((pi xml-processing-instructions-rtd) port)
-  (write-string "<?" port)
-  (write-xml-name (xml-processing-instructions-name pi) port)
-  (write-string (xml-processing-instructions-text pi) port)
-  (write-string "?>" port))
+	  (emit-string "</" ctx)
+	  (write-xml-name (xml-element-name element) ctx)
+	  (emit-string ">" ctx))
+	(emit-string " />" ctx))))
+
+(define-method %write-xml ((comment xml-comment-rtd) ctx)
+  (emit-string "<!--" ctx)
+  (emit-string (xml-comment-text comment) ctx)
+  (emit-string "-->" ctx))
+
+(define-method %write-xml ((pi xml-processing-instructions-rtd) ctx)
+  (emit-string "<?" ctx)
+  (write-xml-name (xml-processing-instructions-name pi) ctx)
+  (emit-string (xml-processing-instructions-text pi) ctx)
+  (emit-string "?>" ctx))
 
-(define-method write-xml ((dtd xml-dtd-rtd) port)
+(define-method %write-xml ((dtd xml-dtd-rtd) ctx)
   ;;root external internal
-  (write-string "<!DOCTYPE " port)
-  (let ((indent (output-port/column port)))
-    (write-xml-name (xml-dtd-root dtd) port)
+  (emit-string "<!DOCTYPE " ctx)
+  (let ((col (ctx-start-col ctx)))
+    (write-xml-name (xml-dtd-root dtd) ctx)
     (if (xml-dtd-external dtd)
-	(write-xml-external-id (xml-dtd-external dtd) indent port))
+	(write-xml-external-id (xml-dtd-external dtd) col ctx))
     (if (pair? (xml-dtd-internal dtd))
 	(begin
 	  (if (xml-dtd-external dtd)
-	      (newline port)
-	      (write-string " " port))
-	  (write-string "[" port)
-	  (newline port)
+	      (emit-newline ctx)
+	      (emit-string " " ctx))
+	  (emit-string "[" ctx)
+	  (emit-newline ctx)
 	  (for-each (lambda (element)
-		      (write-xml element port)
-		      (newline port))
+		      (%write-xml element ctx)
+		      (emit-newline ctx))
 		    (xml-dtd-internal dtd))
-	  (write-string "]" port)))
-    (write-string ">" port)))
+	  (emit-string "]" ctx)))
+    (emit-string ">" ctx)))
 
-(define-method write-xml ((decl xml-!element-rtd) port)
-  (write-string "<!ELEMENT " port)
-  (write-xml-name (xml-!element-name decl) port)
-  (write-string " " port)
+(define-method %write-xml ((decl xml-!element-rtd) ctx)
+  (emit-string "<!ELEMENT " ctx)
+  (write-xml-name (xml-!element-name decl) ctx)
+  (emit-string " " ctx)
   (let ((type (xml-!element-content-type decl)))
     (cond ((symbol? type)
-	   (write-string (string-upcase (symbol-name type)) port))
+	   (emit-string (string-upcase (symbol-name type)) ctx))
 	  ((and (pair? type) (eq? (car type) 'MIX))
-	   (write-string "(#PCDATA" port)
+	   (emit-string "(#PCDATA" ctx)
 	   (if (pair? (cdr type))
 	       (begin
 		 (for-each (lambda (name)
-			     (write-string "|" port)
-			     (write-xml-name name port))
+			     (emit-string "|" ctx)
+			     (write-xml-name name ctx))
 			   (cdr type))
-		 (write-string ")*" port))
-	       (write-string ")" port)))
+		 (emit-string ")*" ctx))
+	       (emit-string ")" ctx)))
 	  (else
 	   (letrec
 	       ((write-children
@@ -144,21 +185,21 @@ USA.
 		       (if (not (and (pair? type)
 				     (list? (cdr type))))
 			   (lose))
-		       (write-string "(" port)
+		       (emit-string "(" ctx)
 		       (write-cp (cadr type))
 		       (for-each
 			(let ((sep (if (eq? (car type) 'ALT) "|" ",")))
 			  (lambda (type)
-			    (write-string sep port)
+			    (emit-string sep ctx)
 			    (write-cp type)))
 			(cddr type))
-		       (write-string ")" port)))))
+		       (emit-string ")" ctx)))))
 		(write-cp
 		 (lambda (type)
 		   (handle-iterator type
 		     (lambda (type)
 		       (if (symbol? type)
-			   (write-xml-name type port)
+			   (write-xml-name type ctx)
 			   (write-children type))))))
 		(handle-iterator
 		 (lambda (type procedure)
@@ -168,143 +209,143 @@ USA.
 			    (null? (cddr type)))
 		       (begin
 			 (procedure (cadr type))
-			 (write-char (car type) port))
+			 (emit-char (car type) ctx))
 		       (procedure type))))
 		(lose
 		 (lambda () 
 		   (error "Malformed !ELEMENT content type:" type))))
 	     (write-children type)))))
-  (write-string ">" port))
+  (emit-string ">" ctx))
 
-(define-method write-xml ((decl xml-!attlist-rtd) port)
-  (write-string "<!ATTLIST " port)
-  (write-xml-name (xml-!attlist-name decl) port)
+(define-method %write-xml ((decl xml-!attlist-rtd) ctx)
+  (emit-string "<!ATTLIST " ctx)
+  (write-xml-name (xml-!attlist-name decl) ctx)
   (let ((definitions (xml-!attlist-definitions decl))
 	(write-definition
 	 (lambda (definition)
-	   (write-xml-name (car definition) port)
-	   (write-string " " port)
+	   (write-xml-name (car definition) ctx)
+	   (emit-string " " ctx)
 	   (let ((type (cadr definition)))
 	     (cond ((symbol? type)
-		    (write-string (string-upcase (symbol-name type)) port))
+		    (emit-string (string-upcase (symbol-name type)) ctx))
 		   ((and (pair? type) (eq? (car type) 'NOTATION))
-		    (write-string "NOTATION (" port)
+		    (emit-string "NOTATION (" ctx)
 		    (if (pair? (cdr type))
 			(begin
-			  (write-xml-name (cadr type) port)
+			  (write-xml-name (cadr type) ctx)
 			  (for-each (lambda (name)
-				      (write-string "|" port)
-				      (write-xml-name name port))
+				      (emit-string "|" ctx)
+				      (write-xml-name name ctx))
 				    (cddr type))))
-		    (write-string ")" port))
+		    (emit-string ")" ctx))
 		   ((and (pair? type) (eq? (car type) 'ENUMERATED))
-		    (write-string "(" port)
+		    (emit-string "(" ctx)
 		    (if (pair? (cdr type))
 			(begin
-			  (write-xml-name (cadr type) port)
+			  (write-xml-name (cadr type) ctx)
 			  (for-each (lambda (name)
-				      (write-string "|" port)
-				      (write-xml-name name port))
+				      (emit-string "|" ctx)
+				      (write-xml-name name ctx))
 				    (cddr type))))
-		    (write-string ")" port))
+		    (emit-string ")" ctx))
 		   (else
 		    (error "Malformed !ATTLIST type:" type))))
-	   (write-string " " port)
+	   (emit-string " " ctx)
 	   (let ((default (caddr definition)))
 	     (cond ((eq? default 'REQUIRED)
-		    (write-string "#REQUIRED" port))
+		    (emit-string "#REQUIRED" ctx))
 		   ((eq? default 'IMPLIED)
-		    (write-string "#IMPLIED" port))
+		    (emit-string "#IMPLIED" ctx))
 		   ((and (pair? default) (eq? (car default) 'FIXED))
-		    (write-string "#FIXED" port)
-		    (write-string " " port)
-		    (write-xml-attribute-value (cdr default) port))
+		    (emit-string "#FIXED" ctx)
+		    (emit-string " " ctx)
+		    (write-xml-attribute-value (cdr default) ctx))
 		   ((and (pair? default) (eq? (car default) 'DEFAULT))
-		    (write-xml-attribute-value (cdr default) port))
+		    (write-xml-attribute-value (cdr default) ctx))
 		   (else
 		    (error "Malformed !ATTLIST default:" default)))))))
     (if (pair? definitions)
 	(if (pair? (cdr definitions))
 	    (for-each (lambda (definition)
-			(newline port)
-			(write-string "          " port)
+			(emit-newline ctx)
+			(emit-string "          " ctx)
 			(write-definition definition))
 		      definitions)
 	    (begin
-	      (write-string " " port)
+	      (emit-string " " ctx)
 	      (write-definition (car definitions))))))
-  (write-string ">" port))
+  (emit-string ">" ctx))
 
-(define-method write-xml ((decl xml-!entity-rtd) port)
-  (write-string "<!ENTITY " port)
-  (let ((indent (output-port/column port)))
-    (write-xml-name (xml-!entity-name decl) port)
-    (write-string " " port)
-    (write-entity-value (xml-!entity-value decl) indent port)
-    (write-string ">" port)))
-
-(define-method write-xml ((decl xml-unparsed-!entity-rtd) port)
-  (write-string "<!ENTITY " port)
-  (let ((indent (output-port/column port)))
-    (write-xml-name (xml-unparsed-!entity-name decl) port)
-    (write-string " " port)
-    (write-xml-external-id (xml-unparsed-!entity-id decl) indent port)
-    (write-string " NDATA " port)
-    (write-xml-name (xml-unparsed-!entity-notation decl) port)
-    (write-string ">" port)))
-
-(define-method write-xml ((decl xml-parameter-!entity-rtd) port)
-  (write-string "<!ENTITY " port)
-  (let ((indent (output-port/column port)))
-    (write-string "% " port)
-    (write-xml-name (xml-parameter-!entity-name decl) port)
-    (write-string " " port)
-    (write-entity-value (xml-parameter-!entity-value decl) indent port)
-    (write-string ">" port)))
-
-(define-method write-xml ((decl xml-!notation-rtd) port)
-  (write-string "<!NOTATION " port)
-  (let ((indent (output-port/column port)))
-    (write-xml-name (xml-!notation-name decl) port)
-    (write-string " " port)
-    (write-xml-external-id (xml-!notation-id decl) indent port)
-    (write-string ">" port)))
-
-(define-method write-xml ((string <string>) port)
+(define-method %write-xml ((decl xml-!entity-rtd) ctx)
+  (emit-string "<!ENTITY " ctx)
+  (let ((col (ctx-start-col ctx)))
+    (write-xml-name (xml-!entity-name decl) ctx)
+    (emit-string " " ctx)
+    (write-entity-value (xml-!entity-value decl) col ctx)
+    (emit-string ">" ctx)))
+
+(define-method %write-xml ((decl xml-unparsed-!entity-rtd) ctx)
+  (emit-string "<!ENTITY " ctx)
+  (let ((col (ctx-start-col ctx)))
+    (write-xml-name (xml-unparsed-!entity-name decl) ctx)
+    (emit-string " " ctx)
+    (write-xml-external-id (xml-unparsed-!entity-id decl) col ctx)
+    (emit-string " NDATA " ctx)
+    (write-xml-name (xml-unparsed-!entity-notation decl) ctx)
+    (emit-string ">" ctx)))
+
+(define-method %write-xml ((decl xml-parameter-!entity-rtd) ctx)
+  (emit-string "<!ENTITY " ctx)
+  (let ((col (ctx-start-col ctx)))
+    (emit-string "% " ctx)
+    (write-xml-name (xml-parameter-!entity-name decl) ctx)
+    (emit-string " " ctx)
+    (write-entity-value (xml-parameter-!entity-value decl) col ctx)
+    (emit-string ">" ctx)))
+
+(define-method %write-xml ((decl xml-!notation-rtd) ctx)
+  (emit-string "<!NOTATION " ctx)
+  (let ((col (ctx-start-col ctx)))
+    (write-xml-name (xml-!notation-name decl) ctx)
+    (emit-string " " ctx)
+    (write-xml-external-id (xml-!notation-id decl) col ctx)
+    (emit-string ">" ctx)))
+
+(define-method %write-xml ((string <string>) ctx)
   (write-escaped-string string
 			'((#\< . "&lt;")
 			  (#\& . "&amp;"))
-			port))
+			ctx))
 
-(define-method write-xml ((ref xml-entity-ref-rtd) port)
-  (write-string "&" port)
-  (write-xml-name (xml-entity-ref-name ref) port)
-  (write-string ";" port))
+(define-method %write-xml ((ref xml-entity-ref-rtd) ctx)
+  (emit-string "&" ctx)
+  (write-xml-name (xml-entity-ref-name ref) ctx)
+  (emit-string ";" ctx))
 
-(define-method write-xml ((ref xml-parameter-entity-ref-rtd) port)
-  (write-string "%" port)
-  (write-xml-name (xml-parameter-entity-ref-name ref) port)
-  (write-string ";" port))
+(define-method %write-xml ((ref xml-parameter-entity-ref-rtd) ctx)
+  (emit-string "%" ctx)
+  (write-xml-name (xml-parameter-entity-ref-name ref) ctx)
+  (emit-string ";" ctx))
 
-(define (write-xml-attributes attributes suffix-cols port)
-  (let ((start-col (output-port/column port)))
-    (if (and start-col
+(define (write-xml-attributes attributes suffix-cols ctx)
+  (let ((col (ctx-start-col ctx)))
+    (if (and col
 	     (pair? attributes)
 	     (pair? (cdr attributes))
-	     (>= (+ start-col
+	     (>= (+ col
 		    (xml-attributes-columns attributes)
 		    suffix-cols)
-		 (output-port/x-size port)))
+		 (ctx-x-size ctx)))
 	(begin
-	  (write-char #\space port)
-	  (write-xml-attribute (car attributes) port)
+	  (emit-char #\space ctx)
+	  (write-xml-attribute (car attributes) ctx)
 	  (for-each (lambda (attribute)
-		      (write-indent (+ start-col 1) port)
-		      (write-xml-attribute attribute port))
+		      (write-indent (+ col 1) ctx)
+		      (write-xml-attribute attribute ctx))
 		    (cdr attributes)))
 	(for-each (lambda (attribute)
-		    (write-char #\space port)
-		    (write-xml-attribute attribute port))
+		    (emit-char #\space ctx)
+		    (write-xml-attribute attribute ctx))
 		  attributes))))
 
 (define (xml-attributes-columns attributes)
@@ -314,19 +355,19 @@ USA.
 	      (+ n-cols 1 (xml-attribute-columns (car attributes))))
 	n-cols)))
 
-(define (write-xml-attribute attribute port)
-  (write-xml-name (car attribute) port)
-  (write-char #\= port)
-  (write-xml-attribute-value (cdr attribute) port))
+(define (write-xml-attribute attribute ctx)
+  (write-xml-name (car attribute) ctx)
+  (emit-char #\= ctx)
+  (write-xml-attribute-value (cdr attribute) ctx))
 
-(define (write-xml-attribute-value value port)
-  (write-char #\" port)
+(define (write-xml-attribute-value value ctx)
+  (emit-char #\" ctx)
   (for-each (lambda (item)
 	      (if (string? item)
-		  (write-xml-string item port)
-		  (write-xml item port)))
+		  (write-xml-string item ctx)
+		  (%write-xml item ctx)))
 	    value)
-  (write-char #\" port))
+  (emit-char #\" ctx))
 
 (define (xml-attribute-columns attribute)
   (+ (xml-name-columns (car attribute))
@@ -341,38 +382,38 @@ USA.
 			   2))))
 	   n))))
 
-(define (write-xml-string string port)
+(define (write-xml-string string ctx)
   (write-escaped-string string
 			'((#\" . "&quot;")
 			  (#\< . "&lt;")
 			  (#\& . "&amp;"))
-			port))
+			ctx))
 
 (define (xml-string-columns string)
-  (let ((n (utf8-string-length string)))
-    (for-each-utf8-char string
+  (let ((n 0))
+    (for-each-wide-char string
       (lambda (char)
 	(set! n
 	      (fix:+ n
 		     (case char
-		       ((#\") 5)
-		       ((#\<) 3)
-		       ((#\&) 4)
-		       (else 0))))
+		       ((#\") 6)
+		       ((#\<) 4)
+		       ((#\&) 5)
+		       (else 1))))
 	unspecific))
     n))
 
-(define (write-xml-name name port)
-  (write-string (symbol-name name) port))
+(define (write-xml-name name ctx)
+  (emit-string (symbol-name name) ctx))
 
 (define (xml-name-columns name)
   (utf8-string-length (symbol-name name)))
 
-(define (write-entity-value value indent port)
+(define (write-entity-value value col ctx)
   (if (xml-external-id? value)
-      (write-xml-external-id value indent port)
+      (write-xml-external-id value col ctx)
       (begin
-	(write-char #\" port)
+	(emit-char #\" ctx)
 	(for-each
 	 (lambda (item)
 	   (if (string? item)
@@ -380,58 +421,66 @@ USA.
 				     '((#\" . "&quot;")
 				       (#\& . "&amp;")
 				       (#\% . "&#37;"))
-				     port)
-	       (write-xml item port)))
+				     ctx)
+	       (%write-xml item ctx)))
 	 value)
-	(write-char #\" port))))
+	(emit-char #\" ctx))))
 
-(define (write-xml-external-id id indent port)
+(define (write-xml-external-id id col ctx)
   (let ((quoted-string
 	 (lambda (string)
-	   (write-char #\" port)
-	   (write-xml-string string port)
-	   (write-char #\" port))))
+	   (emit-char #\" ctx)
+	   (write-xml-string string ctx)
+	   (emit-char #\" ctx))))
     (if (xml-external-id-id id)
 	(begin
-	  (write-indent indent port)
-	  (write-string "PUBLIC " port)
+	  (write-indent col ctx)
+	  (emit-string "PUBLIC " ctx)
 	  (quoted-string (xml-external-id-id id))
 	  (if (xml-external-id-uri id)
 	      (begin
-		(write-indent indent port)
+		(write-indent col ctx)
 		(quoted-string (xml-external-id-uri id)))))
 	(begin
-	  (write-indent indent port)
-	  (write-string "SYSTEM" port)
-	  (write-string " " port)
+	  (write-indent col ctx)
+	  (emit-string "SYSTEM" ctx)
+	  (emit-string " " ctx)
 	  (quoted-string (xml-external-id-uri id))))))
-
-(define (write-indent n port)
-  (if n
+
+(define (write-indent col ctx)
+  (if col
       (begin
-	(newline port)
-	(let ((q.r (integer-divide n 8)))
+	(emit-newline ctx)
+	(let ((q.r (integer-divide col 8)))
 	  (do ((i 0 (fix:+ i 1)))
 	      ((fix:= i (car q.r)))
-	    (write-char #\tab port))
+	    (emit-char #\tab ctx))
 	  (do ((i 0 (fix:+ i 1)))
 	      ((fix:= i (cdr q.r)))
-	    (write-char #\space port))))
-      (write-char #\space port)))
+	    (emit-char #\space ctx))))
+      (emit-char #\space ctx)))
 
-(define (write-escaped-string string escapes port)
-  (for-each-utf8-char string
+(define (write-escaped-string string escapes ctx)
+  (for-each-wide-char string
     (lambda (char)
       (let ((e (assq char escapes)))
 	(if e
-	    (write-string (cdr e) port)
-	    (write-utf8-char char port))))))
-
-(define (for-each-utf8-char string procedure)
-  (let ((port (open-input-string string)))
-    (let loop ()
-      (let ((char (read-utf8-char port)))
-	(if (not (eof-object? char))
-	    (begin
-	      (procedure char)
-	      (loop)))))))
\ No newline at end of file
+	    (emit-string (cdr e) ctx)
+	    (emit-char char ctx))))))
+
+(define (for-each-wide-char string procedure)
+  (if (wide-string? string)
+      (let ((port (open-wide-input-string string)))
+	(let loop ()
+	  (let ((char (read-char port)))
+	    (if (not (eof-object? char))
+		(begin
+		  (procedure char)
+		  (loop))))))
+      (let ((port (open-input-string string)))
+	(let loop ()
+	  (let ((char (read-utf8-char port)))
+	    (if (not (eof-object? char))
+		(begin
+		  (procedure char)
+		  (loop))))))))
\ No newline at end of file