From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 30 May 2005 18:49:01 +0000 (+0000)
Subject: Support conversions between symbols and wide strings.
X-Git-Tag: 20090517-FFI~1293
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=220d99312c0ce162f861f0a4c377c1dde9ac1e25;p=mit-scheme.git

Support conversions between symbols and wide strings.
---

diff --git a/v7/src/runtime/parse.scm b/v7/src/runtime/parse.scm
index ea9736360..2609bbf56 100644
--- a/v7/src/runtime/parse.scm
+++ b/v7/src/runtime/parse.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: parse.scm,v 14.59 2005/04/12 18:28:31 cph Exp $
+$Id: parse.scm,v 14.60 2005/05/30 18:48:43 cph Exp $
 
 Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology
 Copyright 1992,1993,1994,1997,1998,1999 Massachusetts Institute of Technology
@@ -220,15 +220,15 @@ USA.
   ctx
   (receive (string quoted?) (parse-atom port db (list char))
     (if quoted?
-	(%string->symbol string)
+	(string->symbol string)
 	(or (string->number string (db-radix db))
-	    (%string->symbol string)))))
+	    (string->symbol string)))))
 
 (define (handler:symbol port db ctx char)
   ctx
   (receive (string quoted?) (parse-atom port db (list char))
     quoted?
-    (%string->symbol string)))
+    (string->symbol string)))
 
 (define (handler:number port db ctx char1 char2)
   ctx
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index dde9d1fc3..6da2d8df8 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.550 2005/05/30 04:42:24 cph Exp $
+$Id: runtime.pkg,v 14.551 2005/05/30 18:48:53 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -504,6 +504,7 @@ USA.
 	  symbol
 	  symbol->string
 	  symbol->utf8-string
+	  symbol->wide-string
 	  symbol-append
 	  symbol-hash
 	  symbol-hash-mod
@@ -512,9 +513,7 @@ USA.
 	  symbol?
 	  uninterned-symbol?
 	  utf8-string->symbol
-	  utf8-string->uninterned-symbol)
-  (export (runtime parser)
-	  %string->symbol))
+	  utf8-string->uninterned-symbol))
 
 (define-package (runtime microcode-data)
   (files "udata")
diff --git a/v7/src/runtime/symbol.scm b/v7/src/runtime/symbol.scm
index 10f78e9ad..180b21693 100644
--- a/v7/src/runtime/symbol.scm
+++ b/v7/src/runtime/symbol.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: symbol.scm,v 1.18 2005/05/24 04:50:35 cph Exp $
+$Id: symbol.scm,v 1.19 2005/05/30 18:49:01 cph Exp $
 
 Copyright 1992,1993,2001,2003,2004,2005 Massachusetts Institute of Technology
 
@@ -51,32 +51,30 @@ USA.
       (error:wrong-type-argument object "uninterned symbol" caller)))
 
 (define (string->uninterned-symbol string)
-  (guarantee-string string 'STRING->UNINTERNED-SYMBOL)
-  ((ucode-primitive system-pair-cons) (ucode-type uninterned-symbol)
-				      (string->utf8-string string)
-				      (make-unmapped-unbound-reference-trap)))
+  (make-uninterned-symbol (if (string? string)
+			      (string->utf8-string string)
+			      (wide-string->utf8-string string))))
 
 (define (utf8-string->uninterned-symbol string)
-  (guarantee-utf8-string string 'UTF8-STRING->UNINTERNED-SYMBOL)
+  (make-uninterned-symbol (if (utf8-string? string)
+			      (string-copy string)
+			      (wide-string->utf8-string string))))
+
+(define (make-uninterned-symbol string)
   ((ucode-primitive system-pair-cons) (ucode-type uninterned-symbol)
-				      (string-copy string)
+				      string
 				      (make-unmapped-unbound-reference-trap)))
 
 (define (string->symbol string)
-  (guarantee-string string 'STRING->SYMBOL)
-  (let ((string* (string->utf8-string string)))
-    (if (eq? string* string)
-	(or ((ucode-primitive find-symbol) string)
-	    ((ucode-primitive string->symbol) (string-copy string)))
-	((ucode-primitive string->symbol) string*))))
+  ((ucode-primitive string->symbol) (if (string? string)
+					(string->utf8-string string)
+					(wide-string->utf8-string string))))
 
 (define (utf8-string->symbol string)
-  (guarantee-utf8-string string 'UTF8-STRING->SYMBOL)
-  (or ((ucode-primitive find-symbol) string)
-      ((ucode-primitive string->symbol) (string-copy string))))
-
-(define (%string->symbol string)
-  ((ucode-primitive string->symbol) (string->utf8-string string)))
+  (if (utf8-string? string)
+      (or ((ucode-primitive find-symbol) string)
+	  ((ucode-primitive string->symbol) (string-copy string)))
+      ((ucode-primitive string->symbol) (wide-string->utf8-string string))))
 
 (define (substring->symbol string start end)
   (guarantee-substring string start end 'SUBSTRING->SYMBOL)
@@ -149,5 +147,8 @@ USA.
 (define (symbol->utf8-string symbol)
   (string-copy (symbol-name symbol)))
 
+(define (symbol->wide-string symbol)
+  (utf8-string->wide-string (symbol-name symbol)))
+
 (define (symbol->string symbol)
-  (wide-string->string (utf8-string->wide-string (symbol-name symbol))))
\ No newline at end of file
+  (wide-string->string (symbol->wide-string symbol)))
\ No newline at end of file