From 368d420319030b6cb32ba1782353d7096bac09db Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 23 Feb 2004 20:55:11 +0000 Subject: [PATCH] Some tweaks to handle changes in I/O subsystem. Force UTF-8 coding on output (for now). --- v7/src/xml/xml-output.scm | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/v7/src/xml/xml-output.scm b/v7/src/xml/xml-output.scm index b268890ea..1f5fc3ccf 100644 --- a/v7/src/xml/xml-output.scm +++ b/v7/src/xml/xml-output.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: xml-output.scm,v 1.28 2003/09/26 19:39:01 cph Exp $ +$Id: xml-output.scm,v 1.29 2004/02/23 20:55:11 cph Exp $ -Copyright 2001,2002,2003 Massachusetts Institute of Technology +Copyright 2001,2002,2003,2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -35,17 +35,18 @@ USA. (lambda (port) (write-xml-1 xml port options)))) -(define (xml->string xml . options) - (call-with-output-string - (lambda (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 (xml->string xml . options) + (wide-string->utf8-string (apply xml->wide-string xml options))) + (define (write-xml-1 xml port options) + (let ((operation (port/operation port 'SET-CODING))) + (if operation + (operation port 'UTF-8))) (%write-xml xml (make-ctx port options))) (define-structure (ctx (type-descriptor ) @@ -69,7 +70,10 @@ USA. (write-string ";" port))))) (define (emit-string string ctx) - (write-string string (ctx-port ctx))) + (let ((port (ctx-port ctx))) + (for-each-wide-char string + (lambda (char) + (write-char char port))))) (define (emit-newline ctx) (newline (ctx-port ctx))) -- 2.25.1