From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 28 Feb 2017 05:10:06 +0000 (-0800)
Subject: Fix implementations of string-prefix-ci? and string-suffix-ci?.
X-Git-Tag: mit-scheme-pucked-9.2.12~198^2~14
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=63c760840e9761a471b313f11c4ebb6d0371ecc9;p=mit-scheme.git

Fix implementations of string-prefix-ci? and string-suffix-ci?.
---

diff --git a/src/runtime/ustring.scm b/src/runtime/ustring.scm
index 0bbb33e31..6eb5414e5 100644
--- a/src/runtime/ustring.scm
+++ b/src/runtime/ustring.scm
@@ -396,36 +396,35 @@ USA.
   (string-match-backward (string-foldcase string1)
 			 (string-foldcase string2)))
 
-(define-integrable (prefix-maker c= caller)
-  (lambda (prefix string #!optional start end)
-    (let* ((end (fix:end-index end (string-length string) caller))
-	   (start (fix:start-index start end caller))
-	   (n (string-length prefix)))
-      (and (fix:<= n (fix:- end start))
-	   (let loop ((i 0) (j start))
-	     (if (fix:< i n)
-		 (and (c= (string-ref prefix i) (string-ref string j))
-		      (loop (fix:+ i 1) (fix:+ j 1)))
-		 #t))))))
-
-(define-integrable (suffix-maker c= caller)
-  (lambda (suffix string #!optional start end)
-    (let* ((end (fix:end-index end (string-length string) caller))
-	   (start (fix:start-index start end caller))
-	   (n (string-length suffix)))
-      (and (fix:<= n (fix:- end start))
-	   (let loop ((i 0) (j (fix:- end n)))
-	     (if (fix:< i n)
-		 (and (c= (string-ref suffix i) (string-ref string j))
-		      (loop (fix:+ i 1) (fix:+ j 1)))
-		 #t))))))
-
-(define string-prefix? (prefix-maker eq? 'string-prefix?))
-(define string-suffix? (suffix-maker eq? 'string-suffix?))
-
-;;; Incorrect implementation: should do string-foldcase on both args.
-(define string-prefix-ci? (prefix-maker char-ci=? 'string-prefix-ci?))
-(define string-suffix-ci? (suffix-maker char-ci=? 'string-suffix-ci?))
+(define (string-prefix? prefix string #!optional start end)
+  (let* ((end (fix:end-index end (string-length string) 'string-prefix?))
+	 (start (fix:start-index start end 'string-prefix?))
+	 (n (string-length prefix)))
+    (and (fix:<= n (fix:- end start))
+	 (let loop ((i 0) (j start))
+	   (if (fix:< i n)
+	       (and (eq? (string-ref prefix i) (string-ref string j))
+		    (loop (fix:+ i 1) (fix:+ j 1)))
+	       #t)))))
+
+(define (string-suffix? suffix string #!optional start end)
+  (let* ((end (fix:end-index end (string-length string) 'string-suffix?))
+	 (start (fix:start-index start end 'string-suffix?))
+	 (n (string-length suffix)))
+    (and (fix:<= n (fix:- end start))
+	 (let loop ((i 0) (j (fix:- end n)))
+	   (if (fix:< i n)
+	       (and (eq? (string-ref suffix i) (string-ref string j))
+		    (loop (fix:+ i 1) (fix:+ j 1)))
+	       #t)))))
+
+(define (string-prefix-ci? prefix string #!optional start end)
+  (string-prefix? (string-foldcase prefix)
+		  (string-foldcase (string-slice string start end))))
+
+(define (string-suffix-ci? suffix string #!optional start end)
+  (string-suffix? (string-foldcase suffix)
+		  (string-foldcase (string-slice string start end))))
 
 ;;;; Case