Add operations for XSTRING (extended string) objects.

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 4b1aaba531679545f36637d40d480c5f0eb74013..132fdc7bda0a8ff707f60b0c802833fc8a7b852d 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.356 2001/01/04 22:25:46 cph Exp $
+$Id: runtime.pkg,v 14.357 2001/01/05 20:06:57 cph Exp $
 
 Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
@@ -196,7 +196,11 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
          vector-8b-find-previous-char
          vector-8b-find-previous-char-ci
          vector-8b-ref
-         vector-8b-set!)
+         vector-8b-set!
+         xstring-length
+         xstring-move!
+         xstring?
+         xsubstring-move!)
   (export (runtime char-syntax)
          guarantee-substring)
   (initialization (initialize-package!)))

diff --git a/v7/src/runtime/string.scm b/v7/src/runtime/string.scm
index 35eb8db38dca26f239e0367909e9a9ca10ef4fa5..5c04f73a96fe17f21beafc90e39ff814e81f77d9 100644 (file)
--- a/v7/src/runtime/string.scm
+++ b/v7/src/runtime/string.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: string.scm,v 14.36 2001/01/04 22:25:49 cph Exp $
+$Id: string.scm,v 14.37 2001/01/05 20:06:52 cph Exp $
 
 Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
@@ -989,8 +989,30 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   (if (not (external-string? xstring))
       (error:wrong-type-argument xstring "external string"
                                 'EXTERNAL-STRING-LENGTH))
-  ((ucode-primitive extended-string-length)
-   (external-string-descriptor xstring)))
+   ((ucode-primitive extended-string-length)
+    (external-string-descriptor xstring)))
+
+(define (xstring? object)
+  (or (string? object)
+      (external-string? object)))
+
+(define (xstring-length xstring)
+  (cond ((string? xstring)
+        (string-length xstring))
+       ((external-string? xstring)
+        ((ucode-primitive extended-string-length)
+         (external-string-descriptor xstring)))
+       (else
+        (error:wrong-type-argument xstring "xstring" 'XSTRING-LENGTH))))
+
+(define (xstring-move! xstring1 xstring2 start2)
+  (xsubstring-move! xstring1 0 (xstring-length xstring1) xstring2 start2))
+
+(define (xsubstring-move! xstring1 start1 end1 xstring2 start2)
+  (cond ((or (not (eq? xstring2 xstring1)) (< start2 start1))
+        (substring-move-left! xstring1 start1 end1 xstring2 start2))
+       ((> start2 start1)
+        (substring-move-right! xstring1 0 end1 xstring2 start2))))
 \f
 ;;;; Guarantors
 ;;