Initial draft of new string implementation.

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 6d4dd39bcc5098fb4f559c6b6c6880883f6dd43d..9bfea3364904357be391bab254602a86ca4be0e2 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -973,17 +973,54 @@ USA.
   (export ()
          ;; BEGIN deprecated bindings
          (guarantee-vector-8b guarantee-string)
+         (set-vector-8b-length! set-string-length!)
+         (vector-8b-length string-length)
+         (vector-8b-maximum-length string-maximum-length)
+         (vector-8b? string?)
          error:not-string
          error:not-xstring
          guarantee-string
          guarantee-string-index
          guarantee-xstring
-         legacy-string?
+         hexadecimal->vector-8b
+         make-vector-8b
+         vector-8b->hexadecimal
+         vector-8b-fill!
+         vector-8b-find-next-char
+         vector-8b-find-next-char-ci
+         vector-8b-find-previous-char
+         vector-8b-find-previous-char-ci
+         vector-8b-ref
+         vector-8b-set!
          ;; END deprecated bindings
-         (set-vector-8b-length! set-string-length!)
-         (vector-8b-length string-length)
-         (vector-8b-maximum-length string-maximum-length)
-         (vector-8b? string?)
+         (legacy-string string)
+         (legacy-string->list string->list)
+         (legacy-string->vector string->vector)
+         (legacy-string-append string-append)
+         (legacy-string-ci<=? string-ci<=?)
+         (legacy-string-ci<? string-ci<?)
+         (legacy-string-ci=? string-ci=?)
+         (legacy-string-ci>=? string-ci>=?)
+         (legacy-string-ci>? string-ci>?)
+         (legacy-string-copy string-copy)
+         (legacy-string-copy! string-copy!)
+         (legacy-string-downcase string-downcase)
+         (legacy-string-fill! string-fill!)
+         (legacy-string-for-each string-for-each)
+         (legacy-string-length string-length)
+         (legacy-string-map string-map)
+         (legacy-string-ref string-ref)
+         (legacy-string-set! string-set!)
+         (legacy-string-upcase string-upcase)
+         (legacy-string<=? string<=?)
+         (legacy-string<? string<?)
+         (legacy-string=? string=?)
+         (legacy-string>=? string>=?)
+         (legacy-string>? string>?)
+         (legacy-string? string?)
+         (legacy-substring substring)
+         (list->legacy-string list->string)
+         (make-legacy-string make-string)
          ascii-string-copy
          burst-string
          camel-case-string->lisp
@@ -992,11 +1029,9 @@ USA.
          guarantee-substring
          guarantee-substring-end-index
          guarantee-substring-start-index
-         hexadecimal->vector-8b
          lisp-string->camel-case
          list->string
          make-string
-         make-vector-8b
          reverse-string
          reverse-string!
          reverse-substring
@@ -1107,21 +1142,7 @@ USA.
          substring=?
          substring?
          utf8-string
-         vector-8b->hexadecimal
-         vector-8b-fill!
-         vector-8b-find-next-char
-         vector-8b-find-next-char-ci
-         vector-8b-find-previous-char
-         vector-8b-find-previous-char-ci
-         vector-8b-ref
-         vector-8b-set!
-         xstring-fill!
-         xstring-length
          xstring-move!
-         xstring-ref
-         xstring-set!
-         xstring?
-         xsubstring
          xsubstring-fill!
          xsubstring-find-next-char
          xsubstring-find-next-char-ci
@@ -1130,10 +1151,42 @@ USA.
          xsubstring-find-previous-char-ci
          xsubstring-find-previous-char-in-set
          xsubstring-move!)
-  (export (runtime generic-i/o-port)
-         %substring-move!)
   (initialization (initialize-package!)))
 
+(define-package (runtime xstring)
+  (files "xstring")
+  (parent (runtime))
+  (export ()
+         (list->xstring list->utf32-string)
+         (make-xstring make-utf32-string)
+         (xstring utf32-string)
+         (xsubstring xstring-copy)
+         xstring->list
+         xstring->vector
+         xstring-append
+         ;; xstring-ci<=?
+         ;; xstring-ci<?
+         ;; xstring-ci=?
+         ;; xstring-ci>=?
+         ;; xstring-ci>?
+         xstring-copy
+         xstring-copy!
+         ;; xstring-downcase
+         xstring-fill!
+         ;; xstring-foldcase
+         xstring-for-each
+         xstring-length
+         xstring-map
+         xstring-ref
+         xstring-set!
+         ;; xstring-upcase
+         ;; xstring<=?
+         ;; xstring<?
+         ;; xstring=?
+         ;; xstring>=?
+         ;; xstring>?
+         xstring?))
+
 (define-package (runtime bytevector)
   (files "bytevector")
   (parent (runtime))
@@ -5747,11 +5800,7 @@ USA.
          wide-string-ref
          wide-string-set!
          wide-string?
-         wide-substring)
-  (export (runtime generic-i/o-port)
-         wide-string-contents)
-  (export (runtime input-port)
-         wide-string-contents))
+         wide-substring))
 
 (define-package (runtime uri)
   (files "url")

diff --git a/src/runtime/string.scm b/src/runtime/string.scm
index 30c3a41214a8ca6396d4a2a015c3f5548ea9dbe8..7bc8efd6b2affb5d4cd930bb215d194f401e7ca8 100644 (file)
--- a/src/runtime/string.scm
+++ b/src/runtime/string.scm
@@ -1643,25 +1643,6 @@ USA.
            (outer k (fix:+ q 1)))))
     pi))
 \f
-(define (xstring? object)
-  (or (string? object)
-      (wide-string? object)))
-
-(define (xstring-length string)
-  (cond ((string? string) (string-length string))
-       ((wide-string? string) (wide-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))
-       (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))
-       (else (error:not-xstring string 'XSTRING-SET!))))
-
 (define (xstring-move! xstring1 xstring2 start2)
   (xsubstring-move! xstring1 0 (xstring-length xstring1) xstring2 start2))
 
@@ -1673,18 +1654,6 @@ USA.
         (substring-move-right! xstring1 start1 end1
                                xstring2 start2))))
 
-(define (xsubstring xstring start end)
-  (guarantee-xsubstring xstring start end 'XSUBSTRING)
-  (let ((string (make-string (- end start))))
-    (xsubstring-move! xstring start end string 0)
-    string))
-\f
-(define (xstring-fill! xstring char)
-  (cond ((string? xstring)
-        (string-fill! xstring char))
-       (else
-        (error:not-xstring xstring 'XSTRING-FILL!))))
-
 (define (xsubstring-fill! xstring start end char)
   (cond ((string? xstring)
         (substring-fill! xstring start end char))

diff --git a/src/runtime/xstring.scm b/src/runtime/xstring.scm
new file mode 100644 (file)
index 0000000..1c07c76
--- /dev/null
+++ b/src/runtime/xstring.scm
@@ -0,0 +1,353 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Extended strings
+;;; package: (runtime xstring)
+
+;;; This implementation supports all R7RS string operations in which all the
+;;; names have "string" replaced by "xstring".  This is a transitional
+;;; implementation to convert MIT/GNU Scheme to full Unicode string support.
+;;;
+;;; At some point in the future we'll renaming everything back to "string".
+
+;; get-output-xstring
+;; number->xstring
+;; open-output-xstring
+;; read-xstring
+;; symbol->xstring
+;; utf8->xstring
+;; vector->xstring
+;; write-xstring
+;; xstring->number
+;; xstring->symbol
+;; xstring->utf8
+
+(declare (usual-integrations))
+\f
+;;;; U32 vector
+
+(define-integrable (u32->byte-index index)
+  (fix:* index 4))
+
+(define-integrable (byte->u32-index index)
+  (fix:quotient index 4))
+
+(define (make-u32-vector length)
+  (make-bytevector (u32->byte-index length)))
+
+(define (u32-vector-length bytes)
+  (byte->u32-index (bytevector-length bytes)))
+
+(define (u32-vector-ref bytes index)
+  (bytevector-u32be-ref bytes (u32->byte-index index)))
+
+(define (u32-vector-set! bytes index u32)
+  (bytevector-u32be-set! bytes (u32->byte-index index) u32))
+
+(define (u32-vector-copy! to at from start end)
+  (bytevector-copy! to (u32->byte-index to)
+                   from (u32->byte-index start) (u32->byte-index end)))
+
+(define (u32-vector-fill! bytes start end u32)
+  (do ((i start (fix:+ i 1)))
+      ((not (fix:< i end)))
+    (u32-vector-set! bytes i u32)))
+\f
+;;;; UTF-32 string
+
+(define (make-utf32-string k #!optional char)
+  (let ((v (make-u32-vector k)))
+    (if (not (default-object? char))
+       (u32-vector-fill! v 0 k (char->integer char)))
+    (%make-utf32-string v)))
+
+(define (utf32-string . chars)
+  (list->utf32-string chars))
+
+(define (list->utf32-string chars)
+  (let ((v (make-u32-vector (length chars))))
+    (do ((chars chars (cdr chars))
+        (i 0 (fix:+ i 1)))
+       ((not (pair? chars)))
+      (u32-vector-set! v i (char->integer (car chars))))
+    (%make-utf32-string v)))
+
+(define-record-type <utf32-string>
+    (%make-utf32-string vector)
+    utf32-string?
+  (vector utf32-string-vector))
+
+(define (utf32-string-length string)
+  (u32-vector-length (utf32-string-vector string)))
+
+(define (utf32-string-ref string index)
+  (integer->char (u32-vector-ref (utf32-string-vector string) index)))
+
+(define (utf32-string-set! string index char)
+  (u32-vector-set! (utf32-string-vector string)
+                  index
+                  (char->integer char)))
+
+(define (utf32-string-copy string #!optional start end)
+  (let* ((end (get-end end (utf32-string-length string) 'utf32-string-copy))
+        (start (get-start start end 'utf32-string-copy))
+        (to (make-utf32-string (fix:- end start))))
+    (%utf32-string-copy! to 0 string start end)
+    to))
+
+(define (utf32-string-copy! to at from #!optional start end)
+  (let* ((end (get-end end (utf32-string-length from) 'utf32-string-copy!))
+        (start (get-start start end 'utf32-string-copy!)))
+    (%utf32-string-copy! to at from start end)))
+
+(define-integrable (%utf32-string-copy! to at from start end)
+  (u32-vector-copy! (utf32-string-vector to) at
+                   (utf32-string-vector from) start end))
+
+(define (utf32-string-fill! string char #!optional start end)
+  (let* ((end (get-end end (utf32-string-length string) 'utf32-string-fill!))
+        (start (get-start start end 'utf32-string-fill!)))
+    (u32-vector-fill! (utf32-string-vector string) start end
+                     (char->integer char))))
+
+(define (utf32-string->list string #!optional start end)
+  (let* ((end (get-end end (utf32-string-length string) 'utf32-string->list))
+        (start (get-start start end 'utf32-string->list)))
+    (do ((i (fix:- end 1) (fix:- i 1))
+        (chars '() (cons (utf32-string-ref string i) chars)))
+       ((not (fix:>= i start)) chars))))
+
+(define (utf32-string->vector string #!optional start end)
+  (let* ((end (get-end end (utf32-string-length string) 'utf32-string->vector))
+        (start (get-start start end 'utf32-string->vector))
+        (v (make-vector (fix:- end start))))
+    (do ((i start (fix:+ i 1)))
+       ((not (fix:< i end)))
+      (vector-set! v i (utf32-string-ref string i)))
+    v))
+\f
+(define (utf32-string-map proc string . strings)
+  (if (null? strings)
+      (let* ((n (utf32-string-length string))
+            (result (make-utf32-string n)))
+       (do ((i 0 (fix:+ i 1)))
+           ((not (fix:< i n)))
+         (utf32-string-set! result i (proc (utf32-string-ref string i))))
+       result)
+      (let* ((n (min-length utf32-string-length string strings))
+            (result (make-utf32-string n)))
+       (do ((i 0 (fix:+ i 1)))
+           ((not (fix:< i n)))
+         (utf32-string-set! result i
+                            (apply proc
+                                   (utf32-string-ref string i)
+                                   (map (lambda (string)
+                                          (utf32-string-ref string i))
+                                        strings))))
+       result)))
+
+(define (utf32-string-for-each procedure string . strings)
+  (if (null? strings)
+      (let ((n (utf32-string-length string)))
+       (do ((i 0 (fix:+ i 1)))
+           ((not (fix:< i n)))
+         (procedure (utf32-string-ref string i))))
+      (let ((n (min-length utf32-string-length string strings)))
+       (do ((i 0 (fix:+ i 1)))
+           ((not (fix:< i n)))
+         (apply procedure
+                (utf32-string-ref string i)
+                (map (lambda (string)
+                       (utf32-string-ref string i))
+                     strings))))))
+\f
+;;;; String
+
+(define (xstring? object)
+  (or (legacy-string? object)
+      (utf32-string? object)))
+
+(define (create-xstring-registrations!)
+  (register-predicate! legacy-string? 'legacy-string)
+  (register-predicate! utf32-string? 'utf32-string)
+  (register-predicate! xstring? 'xstring
+                      '<= legacy-string?
+                      '<= utf32-string?))
+
+(define (xstring-append . strings)
+  (let ((string
+        (make-utf32-string
+         (do ((strings strings (cdr strings))
+              (n 0 (fix:+ n (xstring-length (car strings)))))
+             ((not (pair? strings)) n)))))
+    (let loop ((strings strings) (i 0))
+      (if (pair? strings)
+         (let ((n (xstring-length (car strings))))
+           (xstring-copy! string i (car strings) 0 n)
+           (loop (cdr strings) (fix:+ i n)))))
+    string))
+
+(define (xstring-length string)
+  (cond ((legacy-string? string) (legacy-string-length string))
+       ((utf32-string? string) (utf32-string-length string))
+       (else (error:not-a xstring? string 'xstring-length))))
+
+(define (xstring-ref string index)
+  (cond ((legacy-string? string) (legacy-string-ref string index))
+       ((utf32-string? string) (utf32-string-ref string index))
+       (else (error:not-a xstring? string 'xstring-ref))))
+
+(define (xstring-set! string index char)
+  (cond ((legacy-string? string) (legacy-string-set! string index char))
+       ((utf32-string? string) (utf32-string-set! string index char))
+       (else (error:not-a xstring? string 'xstring-set!))))
+
+(define (xstring-copy string #!optional start end)
+  (cond ((legacy-string? string) (legacy-string-copy string start end))
+       ((utf32-string? string) (utf32-string-copy string start end))
+       (else (error:not-a xstring? string 'xstring-copy))))
+
+(define (xstring-copy! to at from #!optional start end)
+  (cond ((legacy-string? to)
+        (cond ((legacy-string? from)
+               (legacy-string-copy! to at from start end))
+              ((utf32-string? from)
+               (utf32->legacy-copy! to at from start end))
+              (else
+               (error:not-a xstring? from 'xstring-copy!))))
+       ((utf32-string? to)
+        (cond ((legacy-string? from)
+               (legacy->utf32-copy! to at from start end))
+              ((utf32-string? from)
+               (utf32-string-copy! to at from start end))
+              (else
+               (error:not-a xstring? from 'xstring-copy!))))
+       (else
+        (error:not-a xstring? to 'xstring-copy!))))
+
+(define (utf32->legacy-copy! to at from #!optional start end)
+  (let* ((end (get-end end (utf32-string-length from) 'xstring-copy!))
+        (start (get-start start end 'xstring-copy!)))
+    (do ((i start (fix:+ i 1))
+        (j at (fix:+ j 1)))
+       ((not (fix:< i end)))
+      (legacy-string-set! to j (utf32-string-ref from i)))))
+
+(define (legacy->utf32-copy! to at from #!optional start end)
+  (let* ((end (get-end end (legacy-string-length from) 'xstring-copy!))
+        (start (get-start start end 'xstring-copy!)))
+    (do ((i start (fix:+ i 1))
+        (j at (fix:+ j 1)))
+       ((not (fix:< i end)))
+      (utf32-string-set! to j (legacy-string-ref from i)))))
+
+(define (xstring-fill! string char #!optional start end)
+  (cond ((legacy-string? string) (legacy-string-fill! string char start end))
+       ((utf32-string? string) (utf32-string-fill! string char start end))
+       (else (error:not-a xstring? string 'xstring-fill!))))
+
+(define (xstring->list string #!optional start end)
+  (cond ((legacy-string? string) (legacy-string->list string start end))
+       ((utf32-string? string) (utf32-string->list string start end))
+       (else (error:not-a xstring? string 'xstring->list))))
+
+(define (xstring->vector string #!optional start end)
+  (cond ((legacy-string? string) (legacy-string->vector string start end))
+       ((utf32-string? string) (utf32-string->vector string start end))
+       (else (error:not-a xstring? string 'xstring->vector))))
+
+(define (xstring-for-each procedure string . strings)
+  (if (null? strings)
+      (let ((n (xstring-length string)))
+       (do ((i 0 (fix:+ i 1)))
+           ((not (fix:< i n)))
+         (procedure (xstring-ref string i))))
+      (let ((n (min-length xstring-length string strings)))
+       (do ((i 0 (fix:+ i 1)))
+           ((not (fix:< i n)))
+         (apply procedure
+                (xstring-ref string i)
+                (map (lambda (string)
+                       (xstring-ref string i))
+                     strings))))))
+
+(define (xstring-map proc string . strings)
+  (if (null? strings)
+      (let* ((n (xstring-length string))
+            (result (make-utf32-string n)))
+       (do ((i 0 (fix:+ i 1)))
+           ((not (fix:< i n)))
+         (utf32-string-set! result i (proc (xstring-ref string i))))
+       result)
+      (let* ((n (min-length xstring-length string strings))
+            (result (make-utf32-string n)))
+       (do ((i 0 (fix:+ i 1)))
+           ((not (fix:< i n)))
+         (utf32-string-set! result i
+                            (apply proc
+                                   (xstring-ref string i)
+                                   (map (lambda (string)
+                                          (xstring-ref string i))
+                                        strings))))
+       result)))
+
+;; (xstring-ci<=? string1 string2 . strings)
+;; (xstring-ci<? string1 string2 . strings)
+;; (xstring-ci=? string1 string2 . strings)
+;; (xstring-ci>=? string1 string2 . strings)
+;; (xstring-ci>? string1 string2 . strings)
+;; (xstring-downcase string)
+;; (xstring-foldcase string)
+;; (xstring-upcase string)
+;; (xstring<=? string1 string2 . strings)
+;; (xstring<? string1 string2 . strings)
+;; (xstring=? string1 string2 . strings)
+;; (xstring>=? string1 string2 . strings)
+;; (xstring>? string1 string2 . strings)
+\f
+(define (get-end end length caller)
+  (if (default-object? end)
+      length
+      (begin
+       (guarantee index-fixnum? end caller)
+       (if (not (fix:<= end length))
+           (error:bad-range-argument end caller))
+       end)))
+
+(define (get-start start end caller)
+  (if (default-object? start)
+      0
+      (begin
+       (guarantee index-fixnum? start caller)
+       (if (not (fix:<= start end))
+           (error:bad-range-argument start caller))
+       start)))
+
+(define (min-length string-length string strings)
+  (do ((strings strings (cdr strings))
+       (n (string-length string)
+         (fix:min n (string-length (car strings)))))
+      ((null? strings) n)))
\ No newline at end of file