Add ASCII-STRING-COPY procedure.

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index f86084bc14baa1b2a22e20e228e8c4ba38311114..7ecfaf4953cf294a471fdba0174fa612e1e41a2c 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -925,6 +925,7 @@ USA.
          (vector-8b-maximum-length string-maximum-length)
          (vector-8b? string?)
          allocate-external-string
+         ascii-string-copy
          burst-string
          camel-case-string->lisp
          char->string

diff --git a/src/runtime/string.scm b/src/runtime/string.scm
index fe0de39c2ac6d464910b09080f93ebc5a9eb9cd2..9a92d0f3e7318f2180a7a2b3c75c326c6612e8d1 100644 (file)
--- a/src/runtime/string.scm
+++ b/src/runtime/string.scm
@@ -153,6 +153,17 @@ USA.
     (let ((result (string-allocate size)))
       (%substring-move! string 0 size result 0)
       result)))
+
+(define (ascii-string-copy string)
+  (guarantee-string string 'ASCII-STRING-COPY)
+  (%ascii-string-copy string))
+
+(define (%ascii-string-copy string)
+  (let ((size (string-length string)))
+    (let ((result (string-allocate size)))
+      (and (%ascii-substring-move! string 0 size result 0)
+          result))))
+
 \f
 (define (string-head! string end)
   (declare (no-type-checks) (no-range-checks))
@@ -331,6 +342,79 @@ USA.
                ((fix:= n 1) (unrolled-move-right 1))))
       (fix:+ start2 n))))
 \f
+;;; Almost all symbols are ascii, so it is worthwhile to handle them
+;;; specially.  In this procedure, we `optimistically' move the
+;;; characters, but if we find any non-ascii characters, we
+;;; immediately return #F.  Success is signalled by returning the
+;;; second string.  NOTE that the second string will likely be mutated
+;;; in either case.
+(define (%ascii-substring-move! string1 start1 end1 string2 start2)
+  (let-syntax
+      ((unrolled-move-left
+       (sc-macro-transformer
+        (lambda (form environment)
+          environment
+          (let ((n (cadr form)))
+            `(LET ((CODE (VECTOR-8B-REF STRING1 START1)))
+               (AND (FIX:< CODE #x80)
+                     (BEGIN
+                       (VECTOR-8B-SET! STRING2 START2 CODE)
+                       ,(let loop ((i 1))
+                          (if (< i n)
+                              `(LET ((CODE (VECTOR-8B-REF STRING1 (FIX:+ START1 ,i))))
+                                 (AND (FIX:< CODE #x80)
+                                      (BEGIN
+                                        (VECTOR-8B-SET! STRING2 (FIX:+ START2 ,i) CODE)
+                                        ,(loop (+ i 1)))))
+                              'STRING2)))))))))
+       (unrolled-move-right
+       (sc-macro-transformer
+        (lambda (form environment)
+          environment
+          (let ((n (cadr form)))
+            `(LET ((CODE (VECTOR-8B-REF STRING1 (FIX:+ START1 ,(- n 1)))))
+               (AND (FIX:< CODE #x80)
+                     (BEGIN
+                       (VECTOR-8B-SET! STRING2 (FIX:+ START2 ,(- n 1)) CODE)
+                       ,(let loop ((i (- n 1)))
+                          (if (> i 0)
+                              `(LET ((CODE (VECTOR-8B-REF STRING1 (FIX:+ START1 ,(- i 1)))))
+                                 (AND (FIX:< CODE #x80)
+                                      (BEGIN
+                                        (VECTOR-8B-SET! STRING2 (FIX:+ START2 ,(- i 1)) CODE)
+                                        ,(loop (- i 1)))))
+                              'STRING2))))))))))
+    (let ((n (fix:- end1 start1)))
+      (if (or (not (eq? string2 string1)) (fix:< start2 start1))
+         (cond ((fix:> n 4)
+                (let loop ((i1 start1) (i2 start2))
+                  (if (fix:< i1 end1)
+                      (let ((code (vector-8b-ref string1 i1)))
+                        (and (fix:< code #x80)
+                             (begin
+                               (vector-8b-set! string2 i2 code)
+                               (loop (fix:+ i1 1) (fix:+ i2 1)))))
+                      string2)))
+               ((fix:= n 4) (unrolled-move-left 4))
+               ((fix:= n 3) (unrolled-move-left 3))
+               ((fix:= n 2) (unrolled-move-left 2))
+               ((fix:= n 1) (unrolled-move-left 1)))
+         (cond ((fix:> n 4)
+                (let loop ((i1 end1) (i2 (fix:+ start2 n)))
+                  (if (fix:> i1 start1)
+                      (let ((i1 (fix:- i1 1))
+                            (i2 (fix:- i2 1)))
+                        (let ((code (vector-8b-ref string1 i1)))
+                          (and (fix:< code #x80)
+                               (begin
+                                 (vector-8b-set! string2 i2 code)
+                                 (loop i1 i2)))))
+                      string2)))
+               ((fix:= n 4) (unrolled-move-right 4))
+               ((fix:= n 3) (unrolled-move-right 3))
+               ((fix:= n 2) (unrolled-move-right 2))
+               ((fix:= n 1) (unrolled-move-right 1)))))))
+\f
 (define (string-append . strings)
   (%string-append strings))