Move all legacy-string definitions into ustring.

This is preparation for moving all the old string code elsewhere.

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 04b209a00d60710ea6870d82dd87a6f5c8f0156e..c10caa10c7bb975ed93afe5abbb25558feb4d116 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1004,36 +1004,6 @@ USA.
   (parent (runtime))
   (export-deprecated ()                        ;ignored on 9.2 hosts
          (guarantee-vector-8b guarantee-string)
-         (legacy-string string)
-         (legacy-string->list string->list)
-         (legacy-string->vector string->vector)
-         (legacy-string-append string-append)
-         (legacy-string-capitalize string-capitalize)
-         (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-hash string-hash)
-         (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)
          (set-vector-8b-length! set-string-length!)
          (vector-8b-length string-length)
          (vector-8b-maximum-length string-maximum-length)
@@ -1053,36 +1023,6 @@ USA.
          vector-8b-set!)
   (export ()                           ;temporary duplicate for 9.2 hosts
          (guarantee-vector-8b guarantee-string)
-         (legacy-string string)
-         (legacy-string->list string->list)
-         (legacy-string->vector string->vector)
-         (legacy-string-append string-append)
-         (legacy-string-capitalize string-capitalize)
-         (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-hash string-hash)
-         (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)
          (set-vector-8b-length! set-string-length!)
          (vector-8b-length string-length)
          (vector-8b-maximum-length string-maximum-length)
@@ -1280,11 +1220,15 @@ USA.
          ;; vector->ustring
          )
   (export (runtime bytevector)
+         legacy-string?
+         make-legacy-string
          ustring->legacy-string)
   (export (runtime predicate-metadata)
          register-ustring-predicates!)
   (export (runtime symbol)
-         %ustring*))
+         %ustring*
+         legacy-string-downcase
+         legacy-string?))
 
 (define-package (runtime bytevector)
   (files "bytevector")

diff --git a/src/runtime/ustring.scm b/src/runtime/ustring.scm
index 414db4c4b286730288ed071528494db12a2ccdcb..9000b7279ddaf88dd3186b8b708ab0eb8e4d445b 100644 (file)
--- a/src/runtime/ustring.scm
+++ b/src/runtime/ustring.scm
@@ -257,6 +257,85 @@ USA.
          (utf32-string-set! result i (car chars)))
        result))))
 \f
+;;;; Legacy strings
+
+(define-primitives
+  (legacy-string-length string-length 1)
+  (legacy-string-ref string-ref 2)
+  (legacy-string-set! string-set! 3)
+  (legacy-string? string? 1)
+  (make-legacy-string string-allocate 1))
+
+(define (legacy-string-fill! string char #!optional start end)
+  (let* ((end (fix:end-index end (legacy-string-length string) 'string-fill!))
+        (start (fix:start-index start end 'string-fill!)))
+    (do ((index start (fix:+ index 1)))
+       ((not (fix:< index end)) unspecific)
+      (legacy-string-set! string index char))))
+
+(define legacy-string-copy
+  (x-copy-maker legacy-string-length legacy-string-ref make-legacy-string
+               legacy-string-set! 'string-copy))
+
+(define legacy-string-copy!
+  (x-copy!-maker legacy-string-length legacy-string-ref legacy-string-set!
+                'string-copy!))
+
+(define (legacy-string->list string #!optional start end)
+  (let* ((end (fix:end-index end (legacy-string-length string) 'string->list))
+        (start (fix:start-index start end 'string->list)))
+    (let loop ((index (fix:- end 1)) (chars '()))
+      (if (fix:<= start index)
+         (loop (fix:- index 1) (cons (legacy-string-ref string index) chars))
+         chars))))
+
+(define legacy-string->vector
+  (x-copy-maker legacy-string-length legacy-string-ref make-vector vector-set!
+               'string->vector))
+
+(define (legacy-string-find-first-index proc string #!optional start end)
+  (let* ((caller 'legacy-string-find-next-index)
+        (end (fix:end-index end (legacy-string-length string) caller))
+        (start (fix:start-index start end caller)))
+    (let loop ((i start))
+      (and (fix:< i end)
+          (if (proc (legacy-string-ref string i))
+              i
+              (loop (fix:+ i 1)))))))
+
+(define (legacy-string-find-last-index proc string #!optional start end)
+  (let* ((caller 'legacy-string-find-last-index)
+        (end (fix:end-index end (legacy-string-length string) caller))
+        (start (fix:start-index start end caller)))
+    (let loop ((i (fix:- end 1)))
+      (and (fix:>= i start)
+          (if (proc (legacy-string-ref string i))
+              i
+              (loop (fix:- i 1)))))))
+
+(define (legacy-string-downcase string)
+  (let ((end (legacy-string-length string)))
+    (let ((string* (make-legacy-string end)))
+      (do ((i 0 (fix:+ i 1)))
+         ((fix:= i end))
+       (legacy-string-set! string* i
+                           (char-downcase (legacy-string-ref string i))))
+      string*)))
+
+(define (legacy-string-upcase string)
+  (let ((end (legacy-string-length string)))
+    (let ((string* (make-legacy-string end)))
+      (do ((i 0 (fix:+ i 1)))
+         ((fix:= i end))
+       (legacy-string-set! string* i
+                           (char-upcase (legacy-string-ref string i))))
+      string*)))
+
+(define (legacy-string-hash key #!optional modulus)
+  (if (default-object? modulus)
+      ((ucode-primitive string-hash) key)
+      ((ucode-primitive string-hash-mod) key modulus)))
+\f
 ;;;; String
 
 (define (ustring? object)
@@ -264,6 +343,7 @@ USA.
       (utf32-string? object)))
 
 (define (register-ustring-predicates!)
+  (register-predicate! legacy-string? 'legacy-string)
   (register-predicate! utf32-string? 'utf32-string)
   (register-predicate! ustring? 'ustring)
   (set-predicate<=! legacy-string? ustring?)
@@ -605,26 +685,6 @@ USA.
        (else
         (error:not-a ustring? string 'ustring-find-last-index))))
 
-(define (legacy-string-find-first-index proc string #!optional start end)
-  (let* ((caller 'legacy-string-find-next-index)
-        (end (fix:end-index end (legacy-string-length string) caller))
-        (start (fix:start-index start end caller)))
-    (let loop ((i start))
-      (and (fix:< i end)
-          (if (proc (legacy-string-ref string i))
-              i
-              (loop (fix:+ i 1)))))))
-
-(define (legacy-string-find-last-index proc string #!optional start end)
-  (let* ((caller 'legacy-string-find-last-index)
-        (end (fix:end-index end (legacy-string-length string) caller))
-        (start (fix:start-index start end caller)))
-    (let loop ((i (fix:- end 1)))
-      (and (fix:>= i start)
-          (if (proc (legacy-string-ref string i))
-              i
-              (loop (fix:- i 1)))))))
-
 (define (ustring-find-first-char string char #!optional start end)
   (ustring-find-first-index (char=-predicate char) string start end))