diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c index c071436c..e29db840 100644 --- a/lib/chibi/ast.c +++ b/lib/chibi/ast.c @@ -440,6 +440,37 @@ static sexp sexp_string_contains (sexp ctx, sexp self, sexp_sint_t n, sexp x, se return res ? sexp_make_fixnum(res-sexp_string_data(x)) : SEXP_FALSE; } +static sexp sexp_string_cursor_copy (sexp ctx, sexp self, sexp_sint_t n, sexp dst, sexp sfrom, sexp src, sexp sstart, sexp send) { + unsigned char *pfrom, *pto, *pstart, *pend, *prev, *p; + sexp_sint_t from = sexp_unbox_fixnum(sfrom), to = sexp_string_size(dst), + start = sexp_unbox_fixnum(sstart), end = sexp_unbox_fixnum(send); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, dst); + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, src); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, sfrom); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, sstart); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, send); + if (from < 0 || from > to) + return sexp_user_exception(ctx, self, "string-cursor-copy!: from out of range", sfrom); + if (start < 0 || start > sexp_string_size(src)) + return sexp_user_exception(ctx, self, "string-cursor-copy!: start out of range", sstart); + if (end < start || end > sexp_string_size(src)) + return sexp_user_exception(ctx, self, "string-cursor-copy!: end out of range", send); + pfrom = (unsigned char*)sexp_string_data(dst) + from; + pto = (unsigned char*)sexp_string_data(dst) + to; + pstart = (unsigned char*)sexp_string_data(src) + start; + pend = (unsigned char*)sexp_string_data(src) + end; + for ( ; pfrom < pto && pstart < pend; ++pfrom, ++pstart) + *pfrom = *pstart; + /* adjust for incomplete trailing chars */ + prev = (unsigned char*)sexp_string_utf8_prev(pfrom); + if (sexp_utf8_initial_byte_count(*prev) > pfrom - prev) { + for (p = prev; p < pfrom; ++p) + *p = '\0'; + pstart -= pfrom - prev; + } + return sexp_make_fixnum(pstart - (unsigned char*)sexp_string_data(src)); +} + static sexp sexp_errno (sexp ctx, sexp self, sexp_sint_t n) { #ifdef PLAN9 return SEXP_FALSE; @@ -615,6 +646,7 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char #endif sexp_define_foreign(ctx, env, "thread-list", 0, sexp_thread_list); sexp_define_foreign(ctx, env, "string-contains", 2, sexp_string_contains); + sexp_define_foreign(ctx, env, "string-cursor-copy!", 5, sexp_string_cursor_copy); sexp_define_foreign(ctx, env, "errno", 0, sexp_errno); sexp_define_foreign_opt(ctx, env, "integer->error-string", 1, sexp_error_string, SEXP_FALSE); sexp_define_foreign(ctx, env, "update-free-vars!", 1, sexp_update_free_vars); diff --git a/lib/chibi/ast.sld b/lib/chibi/ast.sld index 2ce1a223..b0091957 100644 --- a/lib/chibi/ast.sld +++ b/lib/chibi/ast.sld @@ -35,7 +35,7 @@ env-define! env-push! env-syntactic? env-syntactic?-set! core-code type-name type-cpl type-parent type-slots type-num-slots type-printer object-size integer->immediate gc atomically thread-list - string-contains errno integer->error-string + string-contains string-cursor-copy! errno integer->error-string flatten-dot update-free-vars! setenv unsetenv safe-setenv) (import (chibi)) (include-shared "ast") diff --git a/lib/chibi/io/io.scm b/lib/chibi/io/io.scm index dab3340d..988dd670 100644 --- a/lib/chibi/io/io.scm +++ b/lib/chibi/io/io.scm @@ -12,14 +12,15 @@ ;; Copy whole characters from the given cursor positions. ;; Return the src cursor position of the next unwritten char, ;; which may be before `to' if the char would overflow. -(define (string-cursor-copy! dst start src from to) - (let lp ((i from) - (j (string-offset->index dst start))) - (let ((i2 (string-cursor-next src i))) - (cond ((> i2 to) i) - (else - (string-set! dst j (string-cursor-ref src i)) - (lp i2 (+ j 1))))))) +;; Now provided as a primitive from (chibi ast). +;; (define (string-cursor-copy! dst start src from to) +;; (let lp ((i from) +;; (j (string-offset->index dst start))) +;; (let ((i2 (string-cursor-next src i))) +;; (cond ((> i2 to) i) +;; (else +;; (string-set! dst j (string-cursor-ref src i)) +;; (lp i2 (+ j 1))))))) (define (utf8->string vec . o) (if (pair? o)