From 8096a3c3ef2ac7241db94912770a1dda70fa9a35 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 5 Jan 2001 20:06:57 +0000
Subject: [PATCH] Add operations for XSTRING (extended string) objects.
---
v7/src/runtime/runtime.pkg | 8 ++++++--
v7/src/runtime/string.scm | 28 +++++++++++++++++++++++++---
2 files changed, 31 insertions(+), 5 deletions(-)
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 4b1aaba53..132fdc7bd 100644
--- 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 35eb8db38..5c04f73a9 100644
--- 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))))
;;;; Guarantors
;;
--
2.25.1