From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 22 Feb 2017 05:18:53 +0000 (-0800)
Subject: Eliminate set-string-length!.
X-Git-Tag: mit-scheme-pucked-9.2.12~220^2~28
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=15c0a88764c55ece95ec1ba1b0df839759b416e4;p=mit-scheme.git

Eliminate set-string-length!.
---

diff --git a/src/compiler/machines/C/cout.scm b/src/compiler/machines/C/cout.scm
index 83a06dcb6..1ae4ec43b 100644
--- 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))))
 	      '())))))
 
 (define (handle-objects start-offset)
diff --git a/src/compiler/rtlgen/opncod.scm b/src/compiler/rtlgen/opncod.scm
index f050df6a5..ce7933d49 100644
--- 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 96d424f2d..24f56cd4e 100644
--- 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 897c03719..55d705c41 100644
--- 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 27482cb99..1f30c6a42 100644
--- 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))