Welcome to the CHICKEN Scheme pasting service

diff --git a/chicken.h b/chicken.h
index 8b1d751..e93fd45 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1629,6 +1629,7 @@ C_fctexport C_word C_fcall C_u_i_string_hash(C_word str, C_word rnd) C_regparm;
 C_fctexport C_word C_fcall C_u_i_string_ci_hash(C_word str, C_word rnd) C_regparm;
 C_fctexport C_word C_fcall C_hash_string(C_word str) C_regparm; /* DEPRECATED, INSECURE */
 C_fctexport C_word C_fcall C_hash_string_ci(C_word str) C_regparm; /* DEPRECATED, INSECURE */
+C_fctexport C_word C_fcall C_u_i_substring_index(C_word s1, C_word s2, C_word off) C_regparm;
 C_fctexport C_word C_halt(C_word msg);
 C_fctexport C_word C_message(C_word msg);
 C_fctexport C_word C_fcall C_equalp(C_word x, C_word y) C_regparm;
diff --git a/data-structures.scm b/data-structures.scm
index 058bc51..55d2c4a 100644
--- a/data-structures.scm
+++ b/data-structures.scm
@@ -324,12 +324,6 @@ EOF
              [else 
               (loop (fx+ istart 1)
                     (fx+ iend 1) ) ] ) ) ) )
-  (set! ##sys#substring-index 
-    (lambda (which where start)
-      (traverse 
-       which where start
-       (lambda (i l) (##core#inline "C_substring_compare" which where 0 i l))
-       'substring-index) ) )
   (set! ##sys#substring-index-ci 
     (lambda (which where start)
       (traverse
@@ -337,6 +331,13 @@ EOF
        (lambda (i l) (##core#inline "C_substring_compare_case_insensitive" which where 0 i l)) 
        'substring-index-ci) ) ) )
 
+(define (##sys#substring-index which where start)
+  ;; XXX TODO: Move the string checks to substring-index so this can be unsafe?
+  (##sys#check-string which 'substring-index)
+  (##sys#check-string where 'substring-index)
+  (##sys#check-range start 0 (##sys#size where) 'substring-index)
+  (##core#inline "C_u_i_substring_index" which where 0))
+
 (define (substring-index which where #!optional (start 0))
   (##sys#substring-index which where start) )
 
diff --git a/runtime.c b/runtime.c
index 9db1a4b..212c7f6 100644
--- a/runtime.c
+++ b/runtime.c
@@ -3769,6 +3769,29 @@ C_regparm C_word C_fcall C_hash_string_ci(C_word str)
   return C_u_i_string_ci_hash(str, C_fix(0));
 }
 
+C_regparm C_word C_fcall C_u_i_substring_index(C_word s1, C_word s2, C_word off)
+{
+  C_word ls1 = C_header_size(s1);
+  C_word ls2 = C_header_size(s2);
+  C_char *ps1 = C_data_pointer(s1);
+  C_char *ps2 = C_data_pointer(s2);
+  C_char *p = ps2 + C_unfix(off);
+  C_char *eps2 = ps2 + ls2 - ls1; /* Last possible search position */
+  C_char c;
+
+  if (ls1-- == 0)               /* Assume bounds have been checked for ls2 */
+    return off;
+
+  c = *ps1++;                   /* Avoid re-checking in memcmp */
+  do {
+    while(*p++ != c) {
+      if (p == eps2)
+        return C_SCHEME_FALSE;
+    }
+  } while (memcmp(p, ps1, ls1));
+  return C_fix(p - ps2 - 1);   /* -1 corrects for initial char 'c' */
+}
+
 C_regparm void C_fcall C_toplevel_entry(C_char *name)
 {
   if(debug_mode)

diff --git a/chicken.h b/chicken.h
index 8b1d751..e93fd45 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1629,6 +1629,7 @@ C_fctexport C_word C_fcall C_u_i_string_hash(C_word str, C_word rnd) C_regparm;
 C_fctexport C_word C_fcall C_u_i_string_ci_hash(C_word str, C_word rnd) C_regparm;
 C_fctexport C_word C_fcall C_hash_string(C_word str) C_regparm; /* DEPRECATED, INSECURE */
 C_fctexport C_word C_fcall C_hash_string_ci(C_word str) C_regparm; /* DEPRECATED, INSECURE */
+C_fctexport C_word C_fcall C_u_i_substring_index(C_word s1, C_word s2, C_word off) C_regparm;
 C_fctexport C_word C_halt(C_word msg);
 C_fctexport C_word C_message(C_word msg);
 C_fctexport C_word C_fcall C_equalp(C_word x, C_word y) C_regparm;
diff --git a/data-structures.scm b/data-structures.scm
index 058bc51..55d2c4a 100644
--- a/data-structures.scm
+++ b/data-structures.scm
@@ -324,12 +324,6 @@ EOF
              [else 
               (loop (fx+ istart 1)
                     (fx+ iend 1) ) ] ) ) ) )
-  (set! ##sys#substring-index 
-    (lambda (which where start)
-      (traverse 
-       which where start
-       (lambda (i l) (##core#inline "C_substring_compare" which where 0 i l))
-       'substring-index) ) )
   (set! ##sys#substring-index-ci 
     (lambda (which where start)
       (traverse
@@ -337,6 +331,13 @@ EOF
        (lambda (i l) (##core#inline "C_substring_compare_case_insensitive" which where 0 i l)) 
        'substring-index-ci) ) ) )
 
+(define (##sys#substring-index which where start)
+  ;; XXX TODO: Move the string checks to substring-index so this can be unsafe?
+  (##sys#check-string which 'substring-index)
+  (##sys#check-string where 'substring-index)
+  (##sys#check-range start 0 (##sys#size where) 'substring-index)
+  (##core#inline "C_u_i_substring_index" which where 0))
+
 (define (substring-index which where #!optional (start 0))
   (##sys#substring-index which where start) )
 
diff --git a/runtime.c b/runtime.c
index 9db1a4b..0f0864d 100644
--- a/runtime.c
+++ b/runtime.c
@@ -3769,6 +3769,30 @@ C_regparm C_word C_fcall C_hash_string_ci(C_word str)
   return C_u_i_string_ci_hash(str, C_fix(0));
 }
 
+C_regparm C_word C_fcall C_u_i_substring_index(C_word s1, C_word s2, C_word off)
+{
+  C_word ls1 = C_header_size(s1);
+  C_char *ps1 = C_data_pointer(s1);
+  C_char *ps2 = C_data_pointer(s2);
+  C_word ls2 = C_header_size(s2);
+  C_char *p = ps2 + C_unfix(off);
+  C_char c;
+  C_char *eps2 = ps2 - ls1;    /* Last possible search position */
+
+  if (ls1-- == 0)
+    return off;
+
+  c = *ps1++;
+  do {
+    p = memchr(p, c, eps2-p);  /* Find possible start of s1 in s2 */
+    if (p++ == NULL)
+      return C_SCHEME_FALSE;
+    if (p > eps2)
+      return C_SCHEME_FALSE;
+  } while (memcmp(p, ps1, ls1));
+  return C_fix(p - ps2 - 1);   /* -1 corrects for initial char 'c' */
+}
+
 C_regparm void C_fcall C_toplevel_entry(C_char *name)
 {
   if(debug_mode)