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)