From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 10 Aug 2007 18:06:20 +0000 (+0000)
Subject: Extend STRING to accept a large class of objects, each of which it
X-Git-Tag: 20090517-FFI~472
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=545719698df1e842f3b2332142e8629adef8dadf;p=mit-scheme.git

Extend STRING to accept a large class of objects, each of which it
converts to a string.  Implement UTF8-STRING to do the same thing for
the UTF-8 encoding.
---

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index df4b9b391..7d85c9beb 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.621 2007/08/10 17:57:27 cph Exp $
+$Id: runtime.pkg,v 14.622 2007/08/10 18:06:18 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -884,6 +884,7 @@ USA.
 	  substring<?
 	  substring=?
 	  substring?
+	  utf8-string
 	  vector-8b->hexadecimal
 	  vector-8b-fill!
 	  vector-8b-find-next-char
diff --git a/v7/src/runtime/string.scm b/v7/src/runtime/string.scm
index 50d1a5f5b..e2592a760 100644
--- a/v7/src/runtime/string.scm
+++ b/v7/src/runtime/string.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: string.scm,v 14.64 2007/04/01 17:51:33 riastradh Exp $
+$Id: string.scm,v 14.65 2007/08/10 18:06:20 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -157,25 +157,56 @@ USA.
   (guarantee-string-index start 'STRING-TAIL)
   (%substring string start (string-length string)))
 
+(define (string-copy string)
+  (guarantee-string string 'STRING-COPY)
+  (%string-copy string))
+
+(define (%string-copy string)
+  (let ((size (string-length string)))
+    (let ((result (string-allocate size)))
+      (%substring-move! string 0 size result 0)
+      result)))
+
+(define (string . objects)
+  (%string-append (map ->string objects)))
+
+(define (utf8-string . objects)
+  (%string-append (map ->utf8-string objects)))
+
+(define (->string object)
+  (cond ((symbol? object) (symbol->string object))
+	((string? object) object)
+	((wide-string? object) (wide-string->string object))
+	((8-bit-char? object) (make-string 1 object))
+	(else (%->string object 'STRING))))
+
+(define (->utf8-string object)
+  (cond ((symbol? object) (symbol-name object))
+	((string? object) (string->utf8-string object))
+	((wide-string? object) (wide-string->utf8-string object))
+	((wide-char? object) (wide-string->utf8-string (wide-string object)))
+	(else (%->string object 'UTF8-STRING))))
+
+(define (%->string object caller)
+  (cond ((number? object) (number->string object))
+	((not object) "")
+	(else (error:wrong-type-argument object "string component" caller))))
+
+(define (char->string char)
+  (guarantee-8-bit-char char 'CHAR->STRING)
+  (make-string 1 char))
+
 (define (list->string chars)
   ;; LENGTH will signal an error if CHARS is not a proper list.
   (let ((result (string-allocate (length chars))))
     (let loop ((chars chars) (index 0))
       (if (pair? chars)
 	  (begin
-	    (if (not (char? (car chars)))
-		(error:wrong-type-datum (car chars) "character"))
-	    (if (not (fix:< (char->integer (car chars)) #x100))
-		(error:not-8-bit-char (car chars)))
+	    (guarantee-8-bit-char (car chars))
 	    (string-set! result index (car chars))
 	    (loop (cdr chars) (fix:+ index 1)))
 	  result))))
 
-(define (string . chars)
-  (list->string chars))
-
-(define char->string string)
-
 (define (string->list string)
   (guarantee-string string 'STRING->LIST)
   (%substring->list string 0 (string-length string)))
@@ -192,16 +223,6 @@ USA.
 	    (cons (string-ref string index) chars)
 	    (loop (fix:- index 1) (cons (string-ref string index) chars))))))
 
-(define (string-copy string)
-  (guarantee-string string 'STRING-COPY)
-  (%string-copy string))
-
-(define (%string-copy string)
-  (let ((size (string-length string)))
-    (let ((result (string-allocate size)))
-      (%substring-move! string 0 size result 0)
-      result)))
-
 (define (string-move! string1 string2 start2)
   (guarantee-string string1 'STRING-MOVE!)
   (guarantee-string string2 'STRING-MOVE!)