Eliminate set-string-length!.

diff --git a/src/compiler/machines/C/cout.scm b/src/compiler/machines/C/cout.scm
index 83a06dcb6ac05e4b60ccdc4799f9403e6e906728..1ae4ec43bf4a3a8055ada880498a9ca07ec990d8 100644 (file)
--- a/src/compiler/machines/C/cout.scm
+++ b/src/compiler/machines/C/cout.scm
@@ -626,8 +626,7 @@ USA.
          (if (fix:> j 1)
              (begin
                (string-set! s j #\")
-               (set-string-length! s (fix:+ j 1))
-               (list s))
+               (list (substring s 0 (fix:+ j 1))))
              '())))))
 \f
 (define (handle-objects start-offset)

diff --git a/src/compiler/rtlgen/opncod.scm b/src/compiler/rtlgen/opncod.scm
index f050df6a56d503a571cc9d9e87179fe78e40426b..ce7933d4957b04a4425e2bc89f8a720c7b34ef20 100644 (file)
--- a/src/compiler/rtlgen/opncod.scm
+++ b/src/compiler/rtlgen/opncod.scm
@@ -1090,26 +1090,6 @@ USA.
   (fixed-assignment 'SET-CAR! (ucode-type pair) 0)
   (fixed-assignment 'SET-CDR! (ucode-type pair) 1))
 
-(define-open-coder/effect 'SET-STRING-LENGTH!
-  (simple-open-coder
-   (lambda (combination expressions finish)
-     (let ((object (car expressions))
-          (length (cadr expressions)))
-       (open-code:with-checks
-       combination
-       (let ((name 'SET-STRING-LENGTH!)
-             (block (combination/block combination)))
-         (list (open-code:type-check object (ucode-type string) name block)
-               (open-code:index-fixnum-check length name block)))
-       (finish-vector-assignment (rtl:locative-offset object 1)
-                                 (rtl:make-object->datum length)
-                                 finish)
-       finish
-       'SET-STRING-LENGTH!
-       expressions)))
-   '(0 1)
-   internal-close-coding-for-type-or-range-checks))
-
 (let ((make-assignment
        (lambda (name type)
         (define-open-coder/effect name

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 96d424f2d371c94027b4714d5e879ed97ae9be41..24f56cd4e103bdaf4e07e645844f99cdda338cef 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1002,7 +1002,6 @@ USA.
   (parent (runtime))
   (export-deprecated ()                        ;ignored on 9.2 hosts
          (guarantee-vector-8b guarantee-string)
-         (set-vector-8b-length! set-string-length!)
          (vector-8b-length string-length)
          (vector-8b? string?)
          error:not-string
@@ -1021,7 +1020,6 @@ USA.
          vector-8b-set!)
   (export ()                           ;temporary duplicate for 9.2 hosts
          (guarantee-vector-8b guarantee-string)
-         (set-vector-8b-length! set-string-length!)
          (vector-8b-length string-length)
          (vector-8b? string?)
          error:not-string
@@ -1046,7 +1044,6 @@ USA.
          lisp-string->camel-case
          reverse-string
          reverse-substring
-         set-string-length!
          string-capitalize
          string-capitalized?
          string-compare

diff --git a/src/runtime/string.scm b/src/runtime/string.scm
index 897c037192cdf9a6502a070f0a7d34a965403051..55d705c410cc0ae1dfb40262d95b684419e2ebf1 100644 (file)
--- a/src/runtime/string.scm
+++ b/src/runtime/string.scm
@@ -43,7 +43,6 @@ USA.
 ;;;; Primitives
 
 (define-primitives
-  (set-string-length! 2)
   (string-allocate 1)
   (string-length 1)
   (string-ref 2)

diff --git a/src/win32/clipbrd.scm b/src/win32/clipbrd.scm
index 27482cb9982471fcb0cfe9e13f2ace51a64b88c3..1f30c6a4209b756ea7042246ad6b6682f2fcfcff 100644 (file)
--- a/src/win32/clipbrd.scm
+++ b/src/win32/clipbrd.scm
@@ -52,8 +52,7 @@ USA.
           (copy-memory s ptr maxlen)
           (global-unlock mem)
           (close-clipboard)
-          (set-string-length! s (vector-8b-find-next-char s 0 maxlen 0))
-          s))))
+          (substring s 0 (vector-8b-find-next-char s 0 maxlen 0))))))
 
 (define (win32-screen-width)
   (get-system-metrics SM_CXSCREEN))