From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 31 Jan 2017 05:20:12 +0000 (-0800)
Subject: Update XML code to use Unicode strings throughout.
X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~8
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=eb49926f56bba333544336341c2f0e5656ce63b8;p=mit-scheme.git

Update XML code to use Unicode strings throughout.

I need this to be able to read the Unicode Character Database.
---

diff --git a/src/xml/parser-macro.scm b/src/xml/parser-macro.scm
index c28d1d9e6..ba201b9b9 100644
--- a/src/xml/parser-macro.scm
+++ b/src/xml/parser-macro.scm
@@ -47,7 +47,7 @@ USA.
 		     ,v
 		     ,(if (string? description)
 			  (string-append "Malformed " description)
-			  `(STRING-APPEND "Malformed " ,description))))))))))
+			  `(USTRING-APPEND "Malformed " ,description))))))))))
 
 (define-*parser-macro (sbracket description open close . body)
   `(BRACKET ,description (NOISE (STRING ,open)) (NOISE (STRING ,close))
diff --git a/src/xml/rdf-nt.scm b/src/xml/rdf-nt.scm
index 163e204e0..4b276ae00 100644
--- a/src/xml/rdf-nt.scm
+++ b/src/xml/rdf-nt.scm
@@ -147,8 +147,8 @@ USA.
 			   (integer->char
 			    (call-with-parser-buffer-tail b p
 			      (lambda (string start end)
-				(substring->number string (+ start 2) end
-						   16 #t)))))
+				(string->number string 16 #t (+ start 2)
+						end)))))
 			  (else #f))))))
 	(if char
 	    (begin
diff --git a/src/xml/rdf-struct.scm b/src/xml/rdf-struct.scm
index 3f4eb9233..4bf1745e8 100644
--- a/src/xml/rdf-struct.scm
+++ b/src/xml/rdf-struct.scm
@@ -96,7 +96,7 @@ USA.
 
 (define (canonicalize-rdf-object object #!optional caller)
   (cond ((rdf-literal? object) object)
-	((string? object) (make-rdf-literal object #f))
+	((ustring? object) (make-rdf-literal object #f))
 	(else (canonicalize-rdf-subject object caller))))
 
 (define (canonicalize-rdf-uri uri #!optional caller)
@@ -161,15 +161,15 @@ USA.
   (if (default-object? name)
       (%make-rdf-bnode)
       (begin
-	(guarantee-string name 'MAKE-RDF-BNODE)
+	(guarantee ustring? name 'MAKE-RDF-BNODE)
 	(hash-table/intern! *rdf-bnode-registry* name %make-rdf-bnode))))
 
 (define (rdf-bnode-name bnode)
-  (string-append "B" (number->string (hash bnode))))
+  (ustring-append "B" (number->string (hash bnode))))
 
 (define (%decode-bnode-uri uri)
   (let ((v
-	 (cond ((string? uri) (*parse-string parse-bnode uri))
+	 (cond ((ustring? uri) (*parse-string parse-bnode uri))
 	       ((symbol? uri) (*parse-symbol parse-bnode uri))
 	       (else #f))))
     (and v
@@ -268,7 +268,7 @@ USA.
 (define (%register-rdf-prefix prefix expansion registry)
   (let ((p (assq prefix (registry-bindings registry))))
     (if p
-	(if (not (string=? (cdr p) expansion))
+	(if (not (ustring=? (cdr p) expansion))
 	    (begin
 	      (warn "RDF prefix override:" prefix (cdr p) expansion)
 	      (set-cdr! p expansion)))
@@ -291,7 +291,7 @@ USA.
 	   (let ((alist
 		  (registry-bindings
 		   (check-registry registry 'URI->RDF-PREFIX)))
-		 (filter (lambda (p) (string-prefix? (cdr p) s))))
+		 (filter (lambda (p) (ustring-prefix? (cdr p) s))))
 	     (or (find-matching-item alist
 		   (lambda (p)
 		     (and (not (eq? (car p) ':))
@@ -308,14 +308,14 @@ USA.
     (receive (prefix expansion) (uri->rdf-prefix uri registry error?)
       (and prefix
 	   (symbol prefix
-		   (string-tail (uri->string uri)
-				(string-length expansion)))))))
+		   (ustring-tail (uri->string uri)
+				 (ustring-length expansion)))))))
 
 (define (rdf-qname->uri qname #!optional registry error?)
   (receive (prefix local) (split-rdf-qname qname)
     (let ((expansion (rdf-prefix-expansion prefix registry)))
       (if expansion
-	  (->absolute-uri (string-append expansion local) 'RDF-QNAME->URI)
+	  (->absolute-uri (ustring-append expansion local) 'RDF-QNAME->URI)
 	  (begin
 	    (if error? (error:bad-range-argument qname 'RDF-QNAME->URI))
 	    #f)))))
@@ -330,19 +330,19 @@ USA.
 (define (rdf-qname-prefix qname)
   (guarantee-rdf-qname qname 'RDF-QNAME-PREFIX)
   (let ((s (symbol-name qname)))
-    (symbol (string-head s (fix:+ (string-find-next-char s #\:) 1)))))
+    (symbol (ustring-head s (fix:+ (ustring-find-first-char s #\:) 1)))))
 
 (define (rdf-qname-local qname)
   (guarantee-rdf-qname qname 'RDF-QNAME-LOCAL)
   (let ((s (symbol-name qname)))
-    (string-tail s (fix:+ (string-find-next-char s #\:) 1))))
+    (ustring-tail s (fix:+ (ustring-find-first-char s #\:) 1))))
 
 (define (split-rdf-qname qname)
   (guarantee-rdf-qname qname 'SPLIT-RDF-QNAME)
   (let ((s (symbol-name qname)))
-    (let ((i (fix:+ (string-find-next-char s #\:) 1)))
-      (values (symbol (string-head s i))
-	      (string-tail s i)))))
+    (let ((i (fix:+ (ustring-find-first-char s #\:) 1)))
+      (values (symbol (ustring-head s i))
+	      (ustring-tail s i)))))
 
 (define (rdf-qname? object)
   (and (interned-symbol? object)
diff --git a/src/xml/turtle.scm b/src/xml/turtle.scm
index 8f36c7b91..58bfcc79a 100644
--- a/src/xml/turtle.scm
+++ b/src/xml/turtle.scm
@@ -211,15 +211,15 @@ USA.
   (*parser
    (map (lambda (s)
 	  (make-rdf-literal
-	   (if (char=? (string-ref s 0) #\-)
+	   (if (char=? (ustring-ref s 0) #\-)
 	       s
-	       (let ((end (string-length s)))
-		 (let loop ((i (if (char=? (string-ref s 0) #\+) 1 0)))
-		   (if (and (fix:< i end) (char=? (string-ref s i) #\0))
+	       (let ((end (ustring-length s)))
+		 (let loop ((i (if (char=? (ustring-ref s 0) #\+) 1 0)))
+		   (if (and (fix:< i end) (char=? (ustring-ref s i) #\0))
 		       (loop (fix:+ i 1))
 		       (if (fix:= i 0)
 			   s
-			   (string-tail s i))))))
+			   (ustring-tail s i))))))
 	   xsd:integer))
 	(match (seq (? (alt "-" "+"))
 		    (+ (char-set char-set:turtle-digit)))))))
@@ -360,7 +360,7 @@ USA.
 	      (parser-buffer-error p (emsg "Malformed string escape")))))
 
       (define (emsg msg)
-	(string-append msg " in " name))
+	(ustring-append msg " in " name))
 
       (define (copy p)
 	(call-with-parser-buffer-tail buffer p
@@ -550,12 +550,12 @@ USA.
 
 (define (post-process-qname prefix local prefixes)
   (string->uri
-   (string-append (cdr
-		   (or (find (lambda (p)
-			       (string=? (car p) prefix))
-			     prefixes)
-		       (error "Unknown prefix:" prefix)))
-		  (or local ""))))
+   (ustring-append (cdr
+		    (or (find (lambda (p)
+				(ustring=? (car p) prefix))
+			      prefixes)
+			(error "Unknown prefix:" prefix)))
+		   (or local ""))))
 
 (define (post-process-collection resources prefixes base-uri)
   (if (pair? resources)
@@ -614,8 +614,9 @@ USA.
 		(lambda (a b)
 		  (let ((a (symbol-name (car a)))
 			(b (symbol-name (car b))))
-		    (substring<? a 0 (fix:- (string-length a) 1)
-				 b 0 (fix:- (string-length b) 1))))))))
+		    (ustring<?
+		     (ustring-head a (fix:- (ustring-length a) 1))
+		     (ustring-head b (fix:- (ustring-length b) 1)))))))))
 
 (define (write-rdf/turtle-prefix prefix expansion #!optional port)
   (let ((port (if (default-object? port) (current-output-port) port)))
@@ -762,7 +763,7 @@ USA.
 						inline-bnode
 						port))
 		     => (lambda (elt)
-			  (string-append "(" elt ")")))
+			  (ustring-append "(" elt ")")))
 		    (else #f))))
 	((rdf-bnode? o)
 	 (and (not (inline-bnode o))
@@ -815,7 +816,7 @@ USA.
 (define (write-object o indentation inline-bnode port)
   (cond ((linear-object-string o inline-bnode port)
 	 => (lambda (s)
-	      (maybe-break (string-length s) indentation port)
+	      (maybe-break (ustring-length s) indentation port)
 	      (write-string s port)))
 	((rdf-graph? o)
 	 (space port)
@@ -911,7 +912,7 @@ USA.
 		      (write-symbol lang port))))))))
 
 (define (write-literal-text text port)
-  (if (string-find-next-char text #\newline)
+  (if (ustring-find-first-char text #\newline)
       (let ((tport (open-input-string text)))
 	(write-string "\"\"\"" port)
 	(let loop ()
@@ -931,10 +932,10 @@ USA.
 
 (define (write-uri uri registry port)
   (let* ((s (uri->string uri))
-	 (end (string-length s)))
+	 (end (ustring-length s)))
     (receive (prefix expansion) (uri->rdf-prefix uri registry #f)
       (if prefix
-	  (let ((start (string-length expansion)))
+	  (let ((start (ustring-length expansion)))
 	    (if (*match-string match:name s start end)
 		(begin
 		  (write-string (symbol-name prefix) port)
@@ -976,10 +977,10 @@ USA.
 	(reverse! groups))))
 
 (define (uri<? a b)
-  (string<? (uri->string a) (uri->string b)))
+  (ustring<? (uri->string a) (uri->string b)))
 
 (define (rdf-bnode<? a b)
-  (string<? (rdf-bnode-name a) (rdf-bnode-name b)))
+  (ustring<? (rdf-bnode-name a) (rdf-bnode-name b)))
 
 (define (rdf-list->list node inline-bnode)
   (let loop ((node node))
diff --git a/src/xml/xhtml-entities.scm b/src/xml/xhtml-entities.scm
index 1abaff9b4..6e1b2b41f 100644
--- a/src/xml/xhtml-entities.scm
+++ b/src/xml/xhtml-entities.scm
@@ -283,9 +283,9 @@ USA.
   (map (lambda (b)
 	 (make-xml-!entity
 	  (car b)
-	  (list (string-append "&#x"
-			       (number->string (char->integer (cadr b)) 16)
-			       ";"))))
+	  (list (ustring-append "&#x"
+				(number->string (char->integer (cadr b)) 16)
+				";"))))
        html-entity-alist))
 
 (define html-char->name-map
diff --git a/src/xml/xhtml.scm b/src/xml/xhtml.scm
index 96e01e42b..fc86a84b5 100644
--- a/src/xml/xhtml.scm
+++ b/src/xml/xhtml.scm
@@ -81,8 +81,8 @@ USA.
   "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd")
 
 (define (html-public-id? id)
-  (and (string? id)
-       (string-prefix? "-//W3C//DTD XHTML " id)))
+  (and (ustring? id)
+       (ustring-prefix? "-//W3C//DTD XHTML " id)))
 
 (define (html-external-id? object)
   (and (xml-external-id? object)
@@ -263,7 +263,7 @@ USA.
 	 contents))
 
 (define (html:id-ref tag . contents)
-  (apply html:href (string-append "#" tag) contents))
+  (apply html:href (ustring-append "#" tag) contents))
 
 (define (html:rel-link rel uri)
   (html:link 'rel rel
@@ -282,10 +282,10 @@ USA.
   (guarantee-keyword-list keyword-list 'HTML:STYLE-ATTR)
   (if (pair? keyword-list)
       (let loop ((bindings keyword-list))
-	(string-append (symbol-name (car bindings))
-		       ": "
-		       (cadr bindings)
-		       (if (pair? (cddr bindings))
-			   (string-append "; " (loop (cddr bindings)))
-			   ";")))
+	(ustring-append (symbol-name (car bindings))
+			": "
+			(cadr bindings)
+			(if (pair? (cddr bindings))
+			    (ustring-append "; " (loop (cddr bindings)))
+			    ";")))
       ""))
\ No newline at end of file
diff --git a/src/xml/xml-names.scm b/src/xml/xml-names.scm
index 5e57c9070..8c83137fe 100644
--- a/src/xml/xml-names.scm
+++ b/src/xml/xml-names.scm
@@ -138,7 +138,7 @@ USA.
 
 (define (name-constructor string-predicate constructor)
   (lambda (object)
-    (if (string? object)
+    (if (ustring? object)
 	(begin
 	  (if (not (string-predicate object))
 	      (error:bad-range-argument object constructor))
@@ -231,9 +231,9 @@ USA.
 
 (define (%xml-qname-prefix qname)
   (let ((s (symbol-name qname)))
-    (let ((c (string-find-next-char s #\:)))
+    (let ((c (ustring-find-first-char s #\:)))
       (if c
-	  (string->symbol (string-head s c))
+	  (string->symbol (ustring-head s c))
 	  (null-xml-name-prefix)))))
 
 (define (xml-qname-local qname)
@@ -242,7 +242,7 @@ USA.
 
 (define (%xml-qname-local qname)
   (let ((s (symbol-name qname)))
-    (let ((c (string-find-next-char s #\:)))
+    (let ((c (ustring-find-first-char s #\:)))
       (if c
-	  (string->symbol (string-tail s (fix:+ c 1)))
+	  (string->symbol (ustring-tail s (fix:+ c 1)))
 	  qname))))
\ No newline at end of file
diff --git a/src/xml/xml-output.scm b/src/xml/xml-output.scm
index 0c36854d8..19b50f243 100644
--- a/src/xml/xml-output.scm
+++ b/src/xml/xml-output.scm
@@ -161,10 +161,10 @@ USA.
   (emit-string "<?" ctx)
   (write-xml-name (xml-processing-instructions-name pi) ctx)
   (let ((text (xml-processing-instructions-text pi)))
-    (if (fix:> (string-length text) 0)
+    (if (fix:> (ustring-length text) 0)
 	(begin
 	  (if (not (char-set-member? char-set:xml-whitespace
-				     (string-ref text 0)))
+				     (ustring-ref text 0)))
 	      (emit-string " " ctx))
 	  (emit-string text ctx))))
   (emit-string "?>" ctx))
@@ -196,7 +196,7 @@ USA.
   (emit-string " " ctx)
   (let ((type (xml-!element-content-type decl)))
     (cond ((symbol? type)
-	   (emit-string (string-upcase (symbol-name type)) ctx))
+	   (emit-string (ustring-upcase (symbol-name type)) ctx))
 	  ((and (pair? type) (eq? (car type) '|#PCDATA|))
 	   (emit-string "(#PCDATA" ctx)
 	   (if (pair? (cdr type))
@@ -243,7 +243,7 @@ USA.
 			 (emit-char (car type) ctx))
 		       (procedure type))))
 		(lose
-		 (lambda () 
+		 (lambda ()
 		   (error "Malformed !ELEMENT content type:" type))))
 	     (write-children type)))))
   (emit-string ">" ctx))
@@ -258,7 +258,7 @@ USA.
 	   (emit-string " " ctx)
 	   (let ((type (cadr definition)))
 	     (cond ((symbol? type)
-		    (emit-string (string-upcase (symbol-name type)) ctx))
+		    (emit-string (ustring-upcase (symbol-name type)) ctx))
 		   ((and (pair? type) (eq? (car type) '|NOTATION|))
 		    (emit-string "NOTATION (" ctx)
 		    (if (pair? (cdr type))
@@ -437,7 +437,7 @@ USA.
 	(emit-char #\" ctx)
 	(for-each
 	 (lambda (item)
-	   (if (string? item)
+	   (if (ustring? item)
 	       (write-escaped-string item
 				     '((#\" . "&quot;")
 				       (#\& . "&amp;")
diff --git a/src/xml/xml-parser.scm b/src/xml/xml-parser.scm
index 658d8cb54..ab2fb39ad 100644
--- a/src/xml/xml-parser.scm
+++ b/src/xml/xml-parser.scm
@@ -36,19 +36,19 @@ USA.
 
 (define (perror ptr msg . irritants)
   (apply error
-	 (string-append msg
-			(if ptr
-			    (string-append
-			     " at "
-			     (parser-buffer-position-string
-			      ;; **** This isn't quite right.  ****
-			      (if (pair? *entity-expansion-nesting*)
-				  (cdar (last-pair *entity-expansion-nesting*))
-				  ptr)))
-			    "")
-			(if (pair? irritants)
-			    ":"
-			    "."))
+	 (ustring-append msg
+			 (if ptr
+			     (ustring-append
+			      " at "
+			      (parser-buffer-position-string
+			       ;; **** This isn't quite right.  ****
+			       (if (pair? *entity-expansion-nesting*)
+				   (cdar (last-pair *entity-expansion-nesting*))
+				   ptr)))
+			     "")
+			 (if (pair? irritants)
+			     ":"
+			     "."))
 	 irritants))
 
 (define (coalesce-elements v)
@@ -57,13 +57,13 @@ USA.
 (define (coalesce-strings! elements)
   (do ((elements elements (cdr elements)))
       ((not (pair? elements)))
-    (if (string? (car elements))
+    (if (ustring? (car elements))
 	(do ()
 	    ((not (and (pair? (cdr elements))
-		       (string? (cadr elements)))))
+		       (ustring? (cadr elements)))))
 	  (set-car! elements
-		    (string-append (car elements)
-				   (cadr elements)))
+		    (ustring-append (car elements)
+				    (cadr elements)))
 	  (set-cdr! elements (cddr elements)))))
   elements)
 
@@ -89,9 +89,7 @@ USA.
 
 (define (string->xml string #!optional start end pi-handlers)
   (parse-xml (string->parser-buffer string start end)
-	     (if (string? string)
-		 'ISO-8859-1
-		 'ANY)
+	     'ANY
 	     (guarantee-pi-handlers pi-handlers 'STRING->XML)))
 
 (define (guarantee-pi-handlers object caller)
@@ -295,7 +293,7 @@ USA.
 	   (if (and version
 		    (not (*match-string match-xml-version version)))
 	       (perror p "Malformed XML version" version))
-	   (if (and version (not (string=? version "1.0")))
+	   (if (and version (not (ustring=? version "1.0")))
 	       (perror p "Unsupported XML version" version))
 	   (if (not (if encoding
 			(*match-string match-encoding encoding)
@@ -356,7 +354,7 @@ USA.
 	       (vector (let ((name (vector-ref v 0)))
 			 (make-xml-element name
 					   (vector-ref v 1)
-					   (if (string=? (vector-ref v 2) ">")
+					   (if (ustring=? (vector-ref v 2) ">")
 					       (parse-element-content b p name)
 					       '()))))))))))
 
@@ -449,7 +447,7 @@ USA.
 	  (let ((av (xml-attribute-value attr)))
 	    (if (and (pair? default)
 		     (eq? (car default) '|#FIXED|)
-		     (not (string=? av (cdr default))))
+		     (not (ustring=? av (cdr default))))
 		(perror (cdar attr) "Incorrect attribute value" name))
 	    (if (not (eq? type '|CDATA|))
 		(set-xml-attribute-value! attr (trim-attribute-whitespace av)))
@@ -499,7 +497,7 @@ USA.
 				   "]]>")))
     (*parser
      (transform (lambda (v)
-		  (if (string-null? (vector-ref v 0))
+		  (if (fix:= 0 (ustring-length (vector-ref v 0)))
 		      '#()
 		      v))
        parse-body))))
@@ -535,7 +533,7 @@ USA.
 	  (match match:xml-name)))))
 
 (define (simple-name-parser type)
-  (let ((m (string-append "Malformed " type " name")))
+  (let ((m (ustring-append "Malformed " type " name")))
     (*parser (require-success m (map make-xml-name (match match:xml-name))))))
 
 (define parse-entity-name (simple-name-parser "entity"))
@@ -574,10 +572,10 @@ USA.
 			       (perror p "Illegal namespace prefix" name))
 			   (string->uri value) ;signals error if not URI
 			   (if (if (xml-name=? name 'xmlns:xml)
-				   (not (string=? value xml-uri-string))
-				   (or (string-null? value)
-				       (string=? value xml-uri-string)
-				       (string=? value xmlns-uri-string)))
+				   (not (ustring=? value xml-uri-string))
+				   (or (fix:= 0 (ustring-length value))
+				       (ustring=? value xml-uri-string)
+				       (ustring=? value xmlns-uri-string)))
 			       (forbidden-uri))
 			   (cons (cons (xml-name-local name) value) tail))
 			  (else tail)))))
@@ -630,7 +628,7 @@ USA.
 	     (lambda (v)
 	       (let ((name (vector-ref v 0))
 		     (text (vector-ref v 1)))
-		 (if (string-ci=? (symbol-name name) "xml")
+		 (if (ustring-ci=? (symbol-name name) "xml")
 		     (perror p "Reserved XML processor name" name))
 		 (let ((entry (assq name *pi-handlers*)))
 		   (if entry
@@ -811,7 +809,7 @@ USA.
     (*parser
      (map (lambda (elements)
 	    (if (not (and (pair? elements)
-			  (string? (car elements))
+			  (ustring? (car elements))
 			  (null? (cdr elements))))
 		(error "Uncoalesced attribute value:" elements))
 	    (normalize-attribute-value (car elements)))
@@ -854,61 +852,64 @@ USA.
 		 (loop))))))))))
 
 (define (trim-attribute-whitespace string)
-  (call-with-output-string
-   (lambda (port)
-     (let ((string (string-trim string)))
-       (let ((end (string-length string)))
-	 (let loop ((start 0))
+  (let ((end (ustring-length string)))
+    (call-with-output-string
+     (lambda (port)
+
+	 (define (skip-spaces start pending-space?)
+	   (if (fix:< start end)
+	       (let ((char (ustring-ref string start)))
+		 (if (char-in-set? char-set:whitespace)
+		     (skip-spaces (fix:+ start 1) pending-space?)
+		     (begin
+		       (if pending-space? (write-char #\space port))
+		       (write-char char port)
+		       (find-next-space (fix:+ start 1)))))))
+
+	 (define (find-next-space start)
 	   (if (fix:< start end)
-	       (let ((regs
-		      (re-substring-search-forward "  +" string start end)))
-		 (if regs
+	       (let ((char (ustring-ref string start)))
+		 (if (char-in-set? char-set:whitespace)
+		     (skip-spaces (fix:+ start 1) #t)
 		     (begin
-		       (write-substring string
-					start
-					(re-match-start-index 0 regs)
-					port)
-		       (write-char #\space port)
-		       (loop (re-match-end-index 0 regs)))
-		     (write-substring string start end port))))))))))
+		       (write-char char port)
+		       (find-next-space (fix:+ start 1)))))))
+
+	 (skip-spaces 0 #f)))))
 
 (define (normalize-line-endings string #!optional always-copy?)
-  (if (string-find-next-char string #\return)
-      (let ((end (string-length string)))
+  (if (ustring-find-first-char string #\return)
+      (let ((end (ustring-length string)))
 	(let ((step-over-eol
 	       (lambda (index)
 		 (fix:+ index
 			(if (and (fix:< (fix:+ index 1) end)
-				 (char=? (string-ref string (fix:+ index 1))
+				 (char=? (ustring-ref string (fix:+ index 1))
 					 #\linefeed))
 			    2
 			    1)))))
 	  (let ((n
 		 (let loop ((start 0) (n 0))
 		   (let ((index
-			  (substring-find-next-char string start end
-						    #\return)))
+			  (ustring-find-first-char string #\return start end)))
 		     (if index
 			 (loop (step-over-eol index)
 			       (fix:+ n (fix:+ (fix:- index start) 1)))
 			 (fix:+ n (fix:- end start)))))))
-	    (let ((string* (make-string n)))
+	    (let ((string* (make-ustring n)))
 	      (let loop ((start 0) (start* 0))
 		(let ((index
-		       (substring-find-next-char string start end
-						 #\return)))
+		       (ustring-find-first-char string #\return start end)))
 		  (if index
 		      (let ((start*
-			     (substring-move! string start index
-					      string* start*)))
-			(string-set! string* start* #\newline)
+			     (ustring-copy! string* start* string start index)))
+			(ustring-set! string* start* #\newline)
 			(loop (step-over-eol index)
 			      (fix:+ start* 1)))
-		      (substring-move! string start end string* start*))))
+		      (ustring-copy! string* start* string start end))))
 	      string*))))
-      (if (and (not (default-object? always-copy?))
-	       always-copy?)
-	  (string-copy string)
+      (if (if (default-object? always-copy?) #f always-copy?)
+	  (ustring-copy string)
 	  string)))
 
 ;;;; Parameter entities
@@ -941,7 +942,7 @@ USA.
 		(and entity
 		     (xml-parameter-!entity-value entity))))))
     (if (and (pair? value)
-	     (string? (car value))
+	     (ustring? (car value))
 	     (null? (cdr value)))
 	(car value)
 	(begin
@@ -972,7 +973,7 @@ USA.
       (if (xml-external-id? value)
 	  (perror p "Reference to external entity" name))
       (if (not (and (pair? value)
-		    (string? (car value))
+		    (ustring? (car value))
 		    (null? (cdr value))))
 	  (perror p "Reference to partially-declared entity" name))
       (if in-attribute?
@@ -1065,8 +1066,8 @@ USA.
 	  (transform
 	      (lambda (v)
 		(let ((value (vector-ref v 0)))
-		  (if (string? value)
-		      (reparse-text (vector (string-append " " value " "))
+		  (if (ustring? value)
+		      (reparse-text (vector (ustring-append " " value " "))
 				    parse-external-subset-decl
 				    "parameter-entity value"
 				    p)
@@ -1110,7 +1111,7 @@ USA.
 	(lambda (v)
 	  (if (fix:= (vector-length v) 1)
 	      (vector-ref v 0)
-	      (list (string-ref (vector-ref v 1) 0)
+	      (list (ustring-ref (vector-ref v 1) 0)
 		    (vector-ref v 0))))))
 
     (*parser
@@ -1317,13 +1318,13 @@ USA.
 (define (reparse-text v parser description ptr)
   (let ((v (coalesce-elements v)))
     (if (and (fix:= (vector-length v) 1)
-	     (string? (vector-ref v 0)))
+	     (ustring? (vector-ref v 0)))
 	(let ((v*
 	       (fluid-let ((*external-expansion?* #t))
 		 (*parse-string parser (vector-ref v 0)))))
 	  (if (not v*)
 	      (perror ptr
-		      (string-append "Malformed " description)
+		      (ustring-append "Malformed " description)
 		      (vector-ref v 0)))
 	  v*)
 	v)))
diff --git a/src/xml/xml-rpc.scm b/src/xml/xml-rpc.scm
index 53f913418..a37a17c8d 100644
--- a/src/xml/xml-rpc.scm
+++ b/src/xml/xml-rpc.scm
@@ -81,13 +81,26 @@ USA.
     (let ((elt (xml-document-root document)))
       (require (xml-name=? (xml-element-name elt) '|methodCall|))
       (values (let ((s (content-string (named-child '|methodName| elt))))
-		(require (re-string-match "\\`[a-zA-Z0-9_.:/]+\\'" s))
+		(require (valid-method-name? s))
 		(string->symbol s))
 	      (let ((elt (%named-child 'params elt)))
 		(if elt
 		    (parse-params elt)
 		    '()))))))
 
+(define (valid-method-name? string)
+  (and (fix:> 0 (ustring-length string))
+       (ustring-every (char-set-predicate char-set:method-name) string)))
+
+(define char-set:method-name
+  (char-set-union (ascii-range->char-set (char->integer #\a)
+					 (fix:+ (char->integer #\z) 1))
+		  (ascii-range->char-set (char->integer #\A)
+					 (fix:+ (char->integer #\Z) 1))
+		  (ascii-range->char-set (char->integer #\0)
+					 (fix:+ (char->integer #\9) 1))
+		  (char-set #\_ #\. #\: #\/)))
+
 (define (xml-rpc:parse-response document)
   (fluid-let ((*document* document)
 	      (*caller* 'xml-rpc:parse-response))
@@ -104,7 +117,7 @@ USA.
 		 (let ((p1 (or (assq '|faultCode| alist) (lose)))
 		       (p2 (or (assq '|faultString| alist) (lose))))
 		   (require (exact-integer? (cdr p1)))
-		   (require (string? (cdr p2)))
+		   (require (ustring? (cdr p2)))
 		   (error:xml-rpc-fault (cdr p1) (cdr p2)))))
 	      (else (lose)))))))
 
@@ -204,7 +217,7 @@ USA.
 (define (decode-value elt)
   (let ((items (xml-element-contents elt)))
     (if (and (pair? items)
-	     (string? (car items))
+	     (ustring? (car items))
 	     (null? (cdr items)))
 	(car items)
 	(let ((object (decode-value-1 (single-child elt))))
@@ -216,8 +229,8 @@ USA.
   (case (xml-element-name elt)
     ((boolean)
      (let ((s (content-string elt)))
-       (cond ((string=? s "0") #f)
-	     ((string=? s "1") #t)
+       (cond ((ustring=? s "0") #f)
+	     ((ustring=? s "1") #t)
 	     (else (lose)))))
     ((nil)
      #!default)
@@ -258,7 +271,7 @@ USA.
   (let ((items (xml-element-contents elt)))
     (require
      (and (pair? items)
-	  (string? (car items))
+	  (ustring? (car items))
 	  (null? (cdr items))))
     (car items)))
 
@@ -288,7 +301,7 @@ USA.
 	    (rpc-elt:boolean (if object "1" "0")))
 	   ((default-object? object)
 	    (rpc-elt:nil))
-	   ((string? object)
+	   ((ustring? object)
 	    (encode-string object))
 	   ((symbol? object)
 	    (encode-string (symbol->string object)))
@@ -319,7 +332,7 @@ USA.
        (call-with-output-string
 	 (lambda (port)
 	   (let ((context (encode-base64:initialize port #f)))
-	     (encode-base64:update context string 0 (string-length string))
+	     (encode-base64:update context string 0 (ustring-length string))
 	     (encode-base64:finalize context)))))))
 
 (define *xml-rpc:encode-value-handler* #f)
diff --git a/src/xml/xml-struct.scm b/src/xml/xml-struct.scm
index b47c7ecb4..ad2ab2820 100644
--- a/src/xml/xml-struct.scm
+++ b/src/xml/xml-struct.scm
@@ -123,13 +123,13 @@ USA.
   (string-composed-of? object char-set:xml-whitespace))
 
 (define (string-composed-of? string char-set)
-  (and (string? string)
-       (substring-composed-of? string 0 (string-length string) char-set)))
+  (and (ustring? string)
+       (ustring-every (char-set-predicate char-set) string)))
 
 (define (substring-composed-of? string start end char-set)
   (let loop ((index start))
     (or (fix:= index end)
-	(and (char-set-member? char-set (string-ref string index))
+	(and (char-set-member? char-set (ustring-ref string index))
 	     (loop (fix:+ index 1))))))
 
 (define-xml-type declaration
@@ -139,7 +139,7 @@ USA.
 
 (define (xml-version? object)
   (and (string-composed-of? object char-set:xml-version)
-       (fix:> (string-length object) 0)))
+       (fix:> (ustring-length object) 0)))
 
 (define char-set:xml-version
   (char-set-union char-set:alphanumeric
@@ -147,10 +147,10 @@ USA.
 
 (define (xml-encoding? object)
   (or (not object)
-      (and (string? object)
-	   (let ((end (string-length object)))
+      (and (ustring? object)
+	   (let ((end (ustring-length object)))
 	     (and (fix:> end 0)
-		  (char-alphabetic? (string-ref object 0))
+		  (char-alphabetic? (ustring-ref object 0))
 		  (substring-composed-of? object 1 end
 					  char-set:xml-encoding))))))
 
@@ -172,9 +172,9 @@ USA.
 
 (define (canonicalize-char-data object)
   (cond ((unicode-char? object)
-	 (call-with-output-string
-	   (lambda (port)
-	     (write-char object port))))
+         (if (not (char-in-set? object char-set:xml-char))
+	     (error:wrong-type-datum object "well-formed XML char data"))
+         (ustring object))
 	((ustring? object)
 	 (if (not (string-of-xml-chars? object))
 	     (error:wrong-type-datum object "well-formed XML char data"))
@@ -230,7 +230,7 @@ USA.
 	      (let ((item (car items))
 		    (items (cdr items)))
 		(if (xml-char-data? item)
-		    (join (string-append s (canonicalize-char-data item))
+		    (join (ustring-append s (canonicalize-char-data item))
 			  items)
 		    (begin
 		      (check-item item)
@@ -278,7 +278,7 @@ USA.
 	 (xml-attribute-value attr))))
 
 (define (xml-name-arg arg caller)
-  (if (string? arg)
+  (if (ustring? arg)
       (make-xml-name arg)
       (begin
 	(guarantee-xml-name arg caller)
@@ -499,7 +499,7 @@ USA.
   (let ((attr
 	 (find (lambda (attr)
 		 (and (xml-attribute-namespace-decl? attr)
-		      (string=? (xml-attribute-value attr) uri-string)))
+		      (ustring=? (xml-attribute-value attr) uri-string)))
 	       (xml-element-attributes elt))))
     (and attr
 	 (let ((name (xml-attribute-name attr)))
@@ -565,10 +565,10 @@ USA.
 	    (let ((item (car items))
 		  (items (cdr items)))
 	      (cond ((and (or (xml-name? item)
-			      (string? item))
+			      (ustring? item))
 			  (pair? items))
 		     (let ((name
-			    (if (string? item)
+			    (if (ustring? item)
 				(make-xml-name item)
 				item))
 			   (value (car items))
@@ -621,19 +621,19 @@ USA.
   (if (pair? nmtokens)
       (let ((nmtoken-length
 	     (lambda (nmtoken)
-	       (string-length (symbol-name nmtoken)))))
+	       (ustring-length (symbol-name nmtoken)))))
 	(let ((s
-	       (make-string
+	       (make-ustring
 		(let loop ((nmtokens nmtokens) (n 0))
 		  (let ((n (fix:+ n (nmtoken-length (car nmtokens)))))
 		    (if (pair? (cdr nmtokens))
 			(loop (cdr nmtokens) (fix:+ n 1))
 			n))))))
 	  (let loop ((nmtokens nmtokens) (index 0))
-	    (string-move! (symbol-name (car nmtokens)) s index)
+	    (ustring-copy! s index (symbol-name (car nmtokens)))
 	    (if (pair? (cdr nmtokens))
 		(let ((index (fix:+ index (nmtoken-length (car nmtokens)))))
-		  (string-set! s index #\space)
+		  (ustring-set! s index #\space)
 		  (loop (cdr nmtokens) (fix:+ index 1)))))
 	  s))
-      (make-string 0)))
\ No newline at end of file
+      (make-ustring 0)))
\ No newline at end of file