Broaden definitions of XSTRING?, XSTRING-LENGTH, XSTRING-REF, and

XSTRING-SET! to also handle wide strings.  Other xstring operations
aren't updated by this change, but will be soon.

diff --git a/v7/src/runtime/string.scm b/v7/src/runtime/string.scm
index 568333810b071d5c4e9dba1ca1685b613a72e31f..e8e866aabf50a8b1969b2e7495696f1a8a004014 100644 (file)
--- a/v7/src/runtime/string.scm
+++ b/v7/src/runtime/string.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: string.scm,v 14.68 2008/02/10 06:14:16 cph Exp $
+$Id: string.scm,v 14.69 2008/07/23 11:10:56 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -1451,37 +1451,44 @@ USA.
        ((ucode-primitive allocate-external-string) n-bytes)
        n-bytes)))))
 
+(define (external-string-ref string index)
+  (ascii->char
+   ((ucode-primitive read-byte-from-memory)
+    (+ (external-string-descriptor string) index))))
+
+(define (external-string-set! string index char)
+  ((ucode-primitive write-byte-to-memory)
+   (char->ascii char)
+   (+ (external-string-descriptor string) index)))
+
+(define-integrable (external-substring-fill! string start end char)
+  ((ucode-primitive VECTOR-8B-FILL!) (external-string-descriptor string)
+                                    start
+                                    end
+                                    (char->ascii char)))
+\f
 (define (xstring? object)
   (or (string? object)
+      (wide-string? object)
       (external-string? object)))
 
-(define (xstring-length xstring)
-  (cond ((string? xstring)
-        (string-length xstring))
-       ((external-string? xstring)
-        (external-string-length xstring))
-       (else
-        (error:wrong-type-argument xstring "xstring" 'XSTRING-LENGTH))))
-
-(define (xstring-ref xstring index)
-  (cond ((external-string? xstring)
-        (ascii->char
-         ((ucode-primitive read-byte-from-memory)
-          (+ (external-string-descriptor xstring) index))))
-       ((string? xstring)
-        (string-ref xstring index))
-       (else
-        (error:wrong-type-argument xstring "xstring" 'XSTRING-REF))))
-
-(define (xstring-set! xstring index char)
-  (cond ((external-string? xstring)
-        ((ucode-primitive write-byte-to-memory)
-         (char->ascii char)
-         (+ (external-string-descriptor xstring) index)))
-       ((string? xstring)
-        (string-set! xstring index char))
-       (else
-        (error:wrong-type-argument xstring "xstring" 'XSTRING-SET!))))
+(define (xstring-length string)
+  (cond ((string? string) (string-length string))
+       ((wide-string? string) (wide-string-length string))
+       ((external-string? string) (external-string-length string))
+       (else (error:not-xstring string 'XSTRING-LENGTH))))
+
+(define (xstring-ref string index)
+  (cond ((string? string) (string-ref string index))
+       ((wide-string? string) (wide-string-ref string index))
+       ((external-string? string) (external-string-ref string index))
+       (else (error:not-xstring string 'XSTRING-REF))))
+
+(define (xstring-set! string index char)
+  (cond ((string? string) (string-set! string index char))
+       ((wide-string? string) (wide-string-set! string index char))
+       ((external-string? string) (external-string-set! string index char))
+       (else (error:not-xstring string 'XSTRING-SET!))))
 
 (define (xstring-move! xstring1 xstring2 start2)
   (xsubstring-move! xstring1 0 (xstring-length xstring1) xstring2 start2))
@@ -1506,38 +1513,32 @@ USA.
     string))
 \f
 (define (xstring-fill! xstring char)
-  (cond ((external-string? xstring)
-        (external-substring-fill! (external-string-descriptor xstring)
+  (cond ((string? xstring)
+        (string-fill! xstring char))
+       ((external-string? xstring)
+        (external-substring-fill! xstring
                                   0
                                   (external-string-length xstring)
                                   char))
-       ((string? xstring)
-        (string-fill! xstring char))
        (else
-        (error:wrong-type-argument xstring "xstring" 'XSTRING-FILL!))))
+        (error:not-xstring xstring 'XSTRING-FILL!))))
 
 (define (xsubstring-fill! xstring start end char)
-  (cond ((external-string? xstring)
-        (external-substring-fill! (external-string-descriptor xstring)
-                                  start
-                                  end
-                                  char))
-       ((string? xstring)
+  (cond ((string? xstring)
         (substring-fill! xstring start end char))
+       ((external-string? xstring)
+        (external-substring-fill! xstring start end char))
        (else
-        (error:wrong-type-argument xstring "xstring" 'XSTRING-FILL!))))
-
-(define-integrable (external-substring-fill! descriptor start end char)
-  ((ucode-primitive VECTOR-8B-FILL!) descriptor start end (char->ascii char)))
+        (error:not-xstring xstring 'XSTRING-FILL!))))
 
 (define-integrable (xsubstring-find-char xstring start end datum finder caller)
   (guarantee-xsubstring xstring start end caller)
-  (cond ((external-string? xstring)
-        (finder (external-string-descriptor xstring) start end datum))
-       ((string? xstring)
+  (cond ((string? xstring)
         (finder xstring start end datum))
+       ((external-string? xstring)
+        (finder (external-string-descriptor xstring) start end datum))
        (else
-        (error:wrong-type-argument xstring "xstring" caller))))
+        (error:not-xstring xstring caller))))
 
 (define (xsubstring-find-next-char xstring start end char)
   (guarantee-char char 'XSUBSTRING-FIND-NEXT-CHAR)