From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 1 Mar 2017 02:13:35 +0000 (-0800)
Subject: Eliminate guarantee-substring.
X-Git-Tag: mit-scheme-pucked-9.2.12~198^2~8
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4d32c0b5ffcd7c68b6d95f90582f53077cfcc46c;p=mit-scheme.git

Eliminate guarantee-substring.
---

diff --git a/src/runtime/chrsyn.scm b/src/runtime/chrsyn.scm
index cda863597..c27370324 100644
--- a/src/runtime/chrsyn.scm
+++ b/src/runtime/chrsyn.scm
@@ -149,21 +149,26 @@ USA.
   '#(" " "." "w" "_" "(" ")" "'" "\"" "$" "\\" "/" "<" ">"))
 
 (define (substring-find-next-char-of-syntax string start end table code)
-  (guarantee-substring string start end 'SUBSTRING-FIND-NEXT-CHAR-OF-SYNTAX)
-  (let loop ((index start))
-    (and (fix:< index end)
-	 (if (char=? code (char->syntax-code table (string-ref string index)))
-	     index
-	     (loop (fix:+ index 1))))))
+  (guarantee 8-bit-string? string 'substring-find-next-char-of-syntax)
+  (let ((index
+	 (string-find-first-index (syntax-code-predicate code)
+				  (string-slice string start end))))
+    (and index
+	 (fix:+ start index))))
 
 (define (substring-find-next-char-not-of-syntax string start end table code)
-  (guarantee-substring string start end
-		       'SUBSTRING-FIND-NEXT-CHAR-NOT-OF-SYNTAX)
-  (let loop ((index start))
-    (and (fix:< index end)
-	 (if (char=? code (char->syntax-code table (string-ref string index)))
-	     (loop (fix:+ index 1))
-	     index))))
+  (guarantee 8-bit-string? string 'substring-find-next-char-not-of-syntax)
+  (let ((index
+	 (string-find-first-index (let ((pred (syntax-code-predicate code)))
+				    (lambda (char)
+				      (not (pred char))))
+				  (string-slice string start end))))
+    (and index
+	 (fix:+ start index))))
+
+(define (syntax-code-predicate code)
+  (lambda (char)
+    (char=? code (char->syntax-code char))))
 
 (define (char->syntax-code table char)
   (string-ref (vector-ref char-syntax-codes
diff --git a/src/runtime/regsexp.scm b/src/runtime/regsexp.scm
index ef40f6009..52e95a371 100644
--- a/src/runtime/regsexp.scm
+++ b/src/runtime/regsexp.scm
@@ -544,7 +544,7 @@ USA.
 
 (define (regsexp-match-input-port crsexp port)
   (let ((caller 'REGSEXP-MATCH-INPUT-PORT))
-    (guarantee-compiled-regsexp crsexp caller)
+    (guarantee compiled-regsexp? crsexp caller)
     (guarantee textual-input-port? port caller)
     (%top-level-match crsexp
 		      (%char-source->position
@@ -585,21 +585,10 @@ USA.
 
 (define (regsexp-match-string crsexp string #!optional start end)
   (let ((caller 'REGSEXP-MATCH-STRING))
-    (guarantee-compiled-regsexp crsexp caller)
-    (guarantee-string string caller)
-    (let* ((end
-	    (let ((length (string-length string)))
-	      (if (default-object? end)
-		  length
-		  (begin
-		    (guarantee-substring-end-index end length caller)
-		    end))))
-	   (start
-	    (if (default-object? start)
-		0
-		(begin
-		  (guarantee-substring-start-index start end caller)
-		  start))))
+    (guarantee compiled-regsexp? crsexp caller)
+    (guarantee string? string caller)
+    (let* ((end (fix:end-index end (string-length string) caller))
+	   (start (fix:start-index start end caller)))
       (%top-level-match crsexp
 			(cons start (%make-substring string start end))))))
 
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 83cceb90a..756737b5d 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -974,17 +974,13 @@ USA.
 	  vector-8b-ref
 	  vector-8b-set!)
   (export ()
-	  guarantee-substring
-	  guarantee-substring-end-index
-	  guarantee-substring-start-index
 	  string-search-all
 	  string-search-backward
 	  string-search-forward
 	  substring-search-all
 	  substring-search-backward
 	  substring-search-forward
-	  substring?)
-  (initialization (initialize-package!)))
+	  substring?))
 
 (define-package (runtime ustring)
   (files "ustring")
@@ -1029,6 +1025,7 @@ USA.
 	  substring=?)
   (export ()
 	  (substring string-copy)
+	  8-bit-string?
 	  grapheme-cluster-length
 	  grapheme-cluster-slice
 	  list->string
diff --git a/src/runtime/string.scm b/src/runtime/string.scm
index 3b89c7b88..c39010c99 100644
--- a/src/runtime/string.scm
+++ b/src/runtime/string.scm
@@ -329,16 +329,6 @@ USA.
 (declare (integrate-operator guarantee-string))
 (define-guarantee string "string")
 
-(define-integrable (guarantee-2-strings object1 object2 procedure)
-  (if (not (and (string? object1) (string? object2)))
-      (guarantee-2-strings/fail object1 object2 procedure)))
-
-(define (guarantee-2-strings/fail object1 object2 procedure)
-  (cond ((not (string? object1))
-	 (error:wrong-type-argument object1 "string" procedure))
-	((not (string? object2))
-	 (error:wrong-type-argument object2 "string" procedure))))
-
 (define-integrable (guarantee-string-index object caller)
   (if (not (index-fixnum? object))
       (error:wrong-type-argument object "string index" caller)))
diff --git a/src/runtime/ustring.scm b/src/runtime/ustring.scm
index f066bad34..3923307b7 100644
--- a/src/runtime/ustring.scm
+++ b/src/runtime/ustring.scm
@@ -140,6 +140,7 @@ USA.
   (register-predicate! legacy-string? 'legacy-string '<= string?)
   (register-predicate! full-string? 'full-string '<= string?)
   (register-predicate! slice? 'string-slice '<= string?)
+  (register-predicate! 8-bit-string? '8-bit-string '<= string?)
   (register-predicate! ->string-component? '->string-component))
 
 ;;;; Strings
@@ -1280,6 +1281,10 @@ USA.
 	 (list 'fill-with grapheme-cluster-string? " ")
 	 (list 'clip? boolean? #t))))
 
+(define (8-bit-string? object)
+  (and (string? object)
+       (string-8-bit? object)))
+
 (define (string-8-bit? string)
   (receive (string start end) (translate-slice string 0 (string-length string))
     (if (legacy-string? string)