From cc6f727adde451cd2f83f6ddb1d4868a5cbd97c9 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 23 Mar 2010 20:52:47 +0900 Subject: [PATCH] sexp_intern, sexp_read_from_string and sexp_eval_string now all take length parameters. this is more flexible and will help if strings are changed to be non-null-terminated. --- eval.c | 44 +++++++++++++++--------------- include/chibi/sexp.h | 4 +-- lib/chibi/ast.c | 8 +++--- lib/chibi/heap-stats.c | 2 +- lib/srfi/27/rand.c | 10 +++---- lib/srfi/69/hash.c | 2 +- main.c | 22 +++++++-------- sexp.c | 62 ++++++++++++++++++++++-------------------- tools/genstubs.scm | 6 ++-- 9 files changed, 83 insertions(+), 77 deletions(-) diff --git a/eval.c b/eval.c index 41e81d4b..9e64e1e5 100644 --- a/eval.c +++ b/eval.c @@ -28,15 +28,15 @@ static sexp sexp_load_module_file_op (sexp ctx, sexp file, sexp env); static sexp sexp_find_module_file_op (sexp ctx, sexp file); #endif -sexp sexp_compile_error (sexp ctx, const char *message, sexp obj) { +sexp sexp_compile_error (sexp ctx, const char *message, sexp o) { sexp exn; sexp_gc_var3(sym, irritants, msg); sexp_gc_preserve3(ctx, sym, irritants, msg); - irritants = sexp_list1(ctx, obj); + irritants = sexp_list1(ctx, o); msg = sexp_c_string(ctx, message, -1); - exn = sexp_make_exception(ctx, sym = sexp_intern(ctx, "compile"), msg, irritants, - SEXP_FALSE, (sexp_pairp(obj) ? - sexp_pair_source(obj) : SEXP_FALSE)); + exn = sexp_make_exception(ctx, sym = sexp_intern(ctx, "compile", -1), + msg, irritants, SEXP_FALSE, + (sexp_pairp(o)?sexp_pair_source(o):SEXP_FALSE)); sexp_gc_release3(ctx); return exn; } @@ -325,7 +325,7 @@ void sexp_init_eval_context_globals (sexp ctx) { sexp_gc_var2(tmp, vec); ctx = sexp_make_child_context(ctx, NULL); sexp_gc_preserve2(ctx, tmp, vec); - tmp = sexp_intern(ctx, "*current-exception-handler*"); + tmp = sexp_intern(ctx, "*current-exception-handler*", -1); sexp_global(ctx, SEXP_G_ERR_HANDLER) = sexp_env_cell_create(ctx, sexp_context_env(ctx), tmp, SEXP_FALSE, NULL); emit(ctx, SEXP_OP_RESUMECC); @@ -337,7 +337,7 @@ void sexp_init_eval_context_globals (sexp ctx) { sexp_global(ctx, SEXP_G_FINAL_RESUMER) = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, tmp, vec); sexp_bytecode_name(sexp_procedure_code(sexp_global(ctx, SEXP_G_FINAL_RESUMER))) - = sexp_intern(ctx, "final-resumer"); + = sexp_intern(ctx, "final-resumer", -1); sexp_global(ctx, SEXP_G_MODULE_PATH) = SEXP_NULL; sexp_add_path(ctx, sexp_default_module_dir); sexp_add_path(ctx, getenv(SEXP_MODULE_PATH_VAR)); @@ -2384,7 +2384,7 @@ sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args if (sexp_exceptionp(op)) res = op; else - sexp_env_define(ctx, env, sexp_intern(ctx, name), op); + sexp_env_define(ctx, env, sexp_intern(ctx, name, -1), op); sexp_gc_release1(ctx); return res; } @@ -2394,7 +2394,7 @@ sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, int num_ar sexp res; sexp_gc_var1(tmp); sexp_gc_preserve1(ctx, tmp); - tmp = sexp_intern(ctx, param); + tmp = sexp_intern(ctx, param, -1); tmp = sexp_env_cell(env, tmp); res = sexp_define_foreign_aux(ctx, env, name, num_args, 3, f, tmp); sexp_gc_release1(ctx); @@ -2477,7 +2477,7 @@ sexp sexp_make_null_env (sexp ctx, sexp version) { sexp_uint_t i; sexp e = sexp_make_env(ctx); for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) - sexp_env_define(ctx, e, sexp_intern(ctx, sexp_core_name(&core_forms[i])), + sexp_env_define(ctx, e, sexp_intern(ctx, sexp_core_name(&core_forms[i]), -1), sexp_copy_core(ctx, &core_forms[i])); return e; } @@ -2490,10 +2490,10 @@ sexp sexp_make_primitive_env (sexp ctx, sexp version) { for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) { op = sexp_copy_opcode(ctx, &opcodes[i]); if (sexp_opcode_opt_param_p(op) && sexp_opcode_data(op)) { - sym = sexp_intern(ctx, (char*)sexp_opcode_data(op)); + sym = sexp_intern(ctx, (char*)sexp_opcode_data(op), -1); sexp_opcode_data(op) = sexp_env_cell_create(ctx, e, sym, SEXP_VOID, NULL); } - sexp_env_define(ctx, e, sexp_intern(ctx, sexp_opcode_name(op)), op); + sexp_env_define(ctx, e, sexp_intern(ctx, sexp_opcode_name(op), -1), op); } sexp_gc_release3(ctx); return e; @@ -2604,21 +2604,21 @@ sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { sexp_gc_preserve3(ctx, op, tmp, sym); sexp_load_standard_parameters(ctx, e); #if SEXP_USE_DL - sexp_env_define(ctx, e, sym=sexp_intern(ctx, "*shared-object-extension*"), + sexp_env_define(ctx, e, sym=sexp_intern(ctx, "*shared-object-extension*", -1), tmp=sexp_c_string(ctx, sexp_so_extension, -1)); #endif - tmp = sexp_list1(ctx, sym=sexp_intern(ctx, sexp_platform)); + tmp = sexp_list1(ctx, sym=sexp_intern(ctx, sexp_platform, -1)); #if SEXP_USE_DL - sexp_push(ctx, tmp, sym=sexp_intern(ctx, "dynamic-loading")); + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "dynamic-loading", -1)); #endif #if SEXP_USE_MODULES - sexp_push(ctx, tmp, sym=sexp_intern(ctx, "modules")); + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "modules", -1)); #endif #if SEXP_USE_BOEHM - sexp_push(ctx, tmp, sym=sexp_intern(ctx, "boehm-gc")); + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "boehm-gc", -1)); #endif - sexp_push(ctx, tmp, sym=sexp_intern(ctx, "chibi")); - sexp_env_define(ctx, e, sexp_intern(ctx, "*features*"), tmp); + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "chibi", -1)); + sexp_env_define(ctx, e, sexp_intern(ctx, "*features*", -1), tmp); sexp_global(ctx, SEXP_G_OPTIMIZATIONS) = SEXP_NULL; #if SEXP_USE_SIMPLIFY op = sexp_make_foreign(ctx, "simplify", 1, 0, @@ -2631,7 +2631,7 @@ sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { /* load and bind config env */ #if SEXP_USE_MODULES if (! sexp_exceptionp(tmp)) { - sym = sexp_intern(ctx, "*config-env*"); + sym = sexp_intern(ctx, "*config-env*", -1); if (! sexp_envp(tmp=sexp_global(ctx, SEXP_G_CONFIG_ENV))) { tmp = sexp_make_env(ctx); if (! sexp_exceptionp(tmp)) { @@ -2768,11 +2768,11 @@ sexp sexp_eval (sexp ctx, sexp obj, sexp env) { return res; } -sexp sexp_eval_string (sexp ctx, const char *str, sexp env) { +sexp sexp_eval_string (sexp ctx, const char *str, sexp_sint_t len, sexp env) { sexp res; sexp_gc_var1(obj); sexp_gc_preserve1(ctx, obj); - obj = sexp_read_from_string(ctx, str); + obj = sexp_read_from_string(ctx, str, len); res = sexp_eval(ctx, obj, env); sexp_gc_release1(ctx); return res; diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index cc45b3ab..952bdfbd 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -834,7 +834,7 @@ SEXP_API sexp sexp_c_string(sexp ctx, const char *str, sexp_sint_t slen); SEXP_API sexp sexp_make_string(sexp ctx, sexp len, sexp ch); SEXP_API sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end); SEXP_API sexp sexp_string_concatenate (sexp ctx, sexp str_ls, sexp sep); -SEXP_API sexp sexp_intern(sexp ctx, const char *str); +SEXP_API sexp sexp_intern(sexp ctx, const char *str, sexp_sint_t len); SEXP_API sexp sexp_string_to_symbol(sexp ctx, sexp str); SEXP_API sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt); SEXP_API sexp sexp_list_to_vector(sexp ctx, sexp ls); @@ -847,7 +847,7 @@ SEXP_API sexp sexp_read_symbol(sexp ctx, sexp in, int init, int internp); SEXP_API sexp sexp_read_number(sexp ctx, sexp in, int base); SEXP_API sexp sexp_read_raw(sexp ctx, sexp in); SEXP_API sexp sexp_read(sexp ctx, sexp in); -SEXP_API sexp sexp_read_from_string(sexp ctx, const char *str); +SEXP_API sexp sexp_read_from_string(sexp ctx, const char *str, sexp_sint_t len); SEXP_API sexp sexp_write_to_string(sexp ctx, sexp obj); SEXP_API sexp sexp_finalize_port (sexp ctx, sexp port); SEXP_API sexp sexp_make_input_port(sexp ctx, FILE* in, sexp name); diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c index 19721c10..ecb00a86 100644 --- a/lib/chibi/ast.c +++ b/lib/chibi/ast.c @@ -10,7 +10,7 @@ static void sexp_define_type_predicate (sexp ctx, sexp env, sexp_gc_preserve2(ctx, name, op); name = sexp_c_string(ctx, cname, -1); op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(type)); - sexp_env_define(ctx, env, name=sexp_intern(ctx, cname), op); + sexp_env_define(ctx, env, name=sexp_intern(ctx, cname, -1), op); sexp_gc_release2(ctx); } @@ -22,9 +22,9 @@ static void sexp_define_accessors (sexp ctx, sexp env, sexp_uint_t ctype, type = sexp_make_fixnum(ctype); index = sexp_make_fixnum(cindex); op = sexp_make_getter(ctx, name=sexp_c_string(ctx, get, -1), type, index); - sexp_env_define(ctx, env, name=sexp_intern(ctx, get), op); + sexp_env_define(ctx, env, name=sexp_intern(ctx, get, -1), op); op = sexp_make_setter(ctx, name=sexp_c_string(ctx, set, -1), type, index); - sexp_env_define(ctx, env, name=sexp_intern(ctx, set), op); + sexp_env_define(ctx, env, name=sexp_intern(ctx, set, -1), op); sexp_gc_release2(ctx); } @@ -43,7 +43,7 @@ static sexp sexp_get_opcode_name (sexp ctx, sexp op) { else if (! sexp_opcode_name(op)) return SEXP_FALSE; else - return sexp_intern(ctx, sexp_opcode_name(op)); + return sexp_intern(ctx, sexp_opcode_name(op), -1); } sexp sexp_init_library (sexp ctx, sexp env) { diff --git a/lib/chibi/heap-stats.c b/lib/chibi/heap-stats.c index 34e415c1..581acfc2 100644 --- a/lib/chibi/heap-stats.c +++ b/lib/chibi/heap-stats.c @@ -103,7 +103,7 @@ static sexp sexp_heap_walk (sexp ctx, int depth, int printp) { res = SEXP_NULL; for (i=hi_type; i>0; i--) if (stats[i]) { - name = sexp_intern(ctx, sexp_type_name_by_index(ctx, i)); + name = sexp_intern(ctx, sexp_type_name_by_index(ctx, i), -1); tmp = sexp_cons(ctx, name, sexp_make_fixnum(stats[i])); res = sexp_cons(ctx, tmp, res); } diff --git a/lib/srfi/27/rand.c b/lib/srfi/27/rand.c index d5d3d984..e56bdbeb 100644 --- a/lib/srfi/27/rand.c +++ b/lib/srfi/27/rand.c @@ -1,6 +1,6 @@ -/* rand.c -- rand_r/random_r interface */ -/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ -/* BSD-style license: http://synthcode.com/license.txt */ +/* rand.c -- rand_r/random_r interface */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ #include #include @@ -180,7 +180,7 @@ sexp sexp_init_library (sexp ctx, sexp env) { name = sexp_c_string(ctx, "random-source?", -1); op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(rs_type_id)); - name = sexp_intern(ctx, "random-source?"); + name = sexp_intern(ctx, "random-source?", -1); sexp_env_define(ctx, env, name, op); sexp_define_foreign(ctx, env, "make-random-source", 0, sexp_make_random_source); @@ -194,7 +194,7 @@ sexp sexp_init_library (sexp ctx, sexp env) { sexp_define_foreign(ctx, env, "random-source-pseudo-randomize!", 2, sexp_random_source_pseudo_randomize); default_random_source = op = sexp_make_random_source(ctx); - name = sexp_intern(ctx, "default-random-source"); + name = sexp_intern(ctx, "default-random-source", -1); sexp_env_define(ctx, env, name, default_random_source); sexp_random_source_randomize(ctx, default_random_source); diff --git a/lib/srfi/69/hash.c b/lib/srfi/69/hash.c index e38c23c0..b6918454 100644 --- a/lib/srfi/69/hash.c +++ b/lib/srfi/69/hash.c @@ -114,7 +114,7 @@ static sexp sexp_get_bucket (sexp ctx, sexp buckets, sexp hash_fn, sexp obj) { args = sexp_list2(ctx, obj, sexp_make_fixnum(len)); res = sexp_apply(ctx, hash_fn, args); if (sexp_exceptionp(res)) { - args = sexp_eval_string(ctx, "(current-error-port)", sexp_context_env(ctx)); + args = sexp_eval_string(ctx, "(current-error-port)", -1, sexp_context_env(ctx)); sexp_print_exception(ctx, res, args); res = sexp_make_fixnum(0); } diff --git a/main.c b/main.c index aa0a44a7..ef97201b 100644 --- a/main.c +++ b/main.c @@ -27,9 +27,9 @@ static void repl (sexp ctx) { sexp_env_define(ctx, sexp_context_env(ctx), sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), env); sexp_context_tracep(ctx) = 1; - in = sexp_eval_string(ctx, "(current-input-port)", env); - out = sexp_eval_string(ctx, "(current-output-port)", env); - err = sexp_eval_string(ctx, "(current-error-port)", env); + in = sexp_eval_string(ctx, "(current-input-port)", -1, env); + out = sexp_eval_string(ctx, "(current-output-port)", -1, env); + err = sexp_eval_string(ctx, "(current-error-port)", -1, env); sexp_port_sourcep(in) = 1; while (1) { sexp_write_string(ctx, "> ", out); @@ -106,11 +106,11 @@ void run_main (int argc, char **argv) { print = (argv[i][1] == 'p'); arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); check_nonull_arg('e', arg); - res = check_exception(ctx, sexp_read_from_string(ctx, arg)); + res = check_exception(ctx, sexp_read_from_string(ctx, arg, -1)); res = check_exception(ctx, sexp_eval(ctx, res, env)); if (print) { if (! sexp_oportp(out)) - out = sexp_eval_string(ctx, "(current-output-port)", env); + out = sexp_eval_string(ctx, "(current-output-port)", -1, env); sexp_write(ctx, res, out); sexp_write_char(ctx, '\n', out); } @@ -134,7 +134,7 @@ void run_main (int argc, char **argv) { impmod[len] = '\0'; for (p=impmod; *p; p++) if (*p == '.') *p=' '; - check_exception(ctx, sexp_eval_string(ctx, impmod, env)); + check_exception(ctx, sexp_eval_string(ctx, impmod, -1, env)); free(impmod); break; case 'q': @@ -171,9 +171,9 @@ void run_main (int argc, char **argv) { case 'V': load_init(); if (! sexp_oportp(out)) - out = sexp_eval_string(ctx, "(current-output-port)", env); + out = sexp_eval_string(ctx, "(current-output-port)", -1, env); sexp_write_string(ctx, sexp_version_string, out); - tmp = sexp_env_ref(env, sexp_intern(ctx, "*features*"), SEXP_NULL); + tmp = sexp_env_ref(env, sexp_intern(ctx, "*features*", -1), SEXP_NULL); sexp_write(ctx, tmp, out); sexp_newline(ctx, out); return; @@ -191,11 +191,11 @@ void run_main (int argc, char **argv) { args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[j],-1), args); else args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[0],-1), args); - sexp_env_define(ctx, env, sexp_intern(ctx, sexp_argv_symbol), args); - sexp_eval_string(ctx, sexp_argv_proc, env); + sexp_env_define(ctx, env, sexp_intern(ctx, sexp_argv_symbol, -1), args); + sexp_eval_string(ctx, sexp_argv_proc, -1, env); if (i < argc) { /* script usage */ check_exception(ctx, sexp_load(ctx, tmp=sexp_c_string(ctx, argv[i], -1), env)); - tmp = sexp_intern(ctx, "main"); + tmp = sexp_intern(ctx, "main", -1); tmp = sexp_env_ref(env, tmp, SEXP_FALSE); if (sexp_procedurep(tmp)) { args = sexp_list1(ctx, args); diff --git a/sexp.c b/sexp.c index 9132fbe1..1da3114c 100644 --- a/sexp.c +++ b/sexp.c @@ -224,14 +224,14 @@ void sexp_init_context_globals (sexp ctx) { #endif sexp_global(ctx, SEXP_G_OOM_ERROR) = sexp_user_exception(ctx, SEXP_FALSE, "out of memory", SEXP_NULL); sexp_global(ctx, SEXP_G_OOS_ERROR) = sexp_user_exception(ctx, SEXP_FALSE, "out of stack space", SEXP_NULL); - sexp_global(ctx, SEXP_G_QUOTE_SYMBOL) = sexp_intern(ctx, "quote"); - sexp_global(ctx, SEXP_G_QUASIQUOTE_SYMBOL) = sexp_intern(ctx, "quasiquote"); - sexp_global(ctx, SEXP_G_UNQUOTE_SYMBOL) = sexp_intern(ctx, "unquote"); - sexp_global(ctx, SEXP_G_UNQUOTE_SPLICING_SYMBOL) = sexp_intern(ctx, "unquote-splicing"); - sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL) = sexp_intern(ctx, "*current-input-port*"); - sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL) = sexp_intern(ctx, "*current-output-port*"); - sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL) = sexp_intern(ctx, "*current-error-port*"); - sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL) = sexp_intern(ctx, "*interaction-environment*"); + sexp_global(ctx, SEXP_G_QUOTE_SYMBOL) = sexp_intern(ctx, "quote", -1); + sexp_global(ctx, SEXP_G_QUASIQUOTE_SYMBOL) = sexp_intern(ctx, "quasiquote", -1); + sexp_global(ctx, SEXP_G_UNQUOTE_SYMBOL) = sexp_intern(ctx, "unquote", -1); + sexp_global(ctx, SEXP_G_UNQUOTE_SPLICING_SYMBOL) = sexp_intern(ctx, "unquote-splicing", -1); + sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL) = sexp_intern(ctx, "*current-input-port*", -1); + sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL) = sexp_intern(ctx, "*current-output-port*", -1); + sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL) = sexp_intern(ctx, "*current-error-port*", -1); + sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL) = sexp_intern(ctx, "*interaction-environment*", -1); sexp_global(ctx, SEXP_G_EMPTY_VECTOR) = sexp_alloc_type(ctx, vector, SEXP_VECTOR); sexp_vector_length(sexp_global(ctx, SEXP_G_EMPTY_VECTOR)) = 0; #if ! SEXP_USE_GLOBAL_TYPES @@ -332,7 +332,7 @@ sexp sexp_user_exception (sexp ctx, sexp self, const char *ms, sexp ir) { sexp res; sexp_gc_var3(sym, str, irr); sexp_gc_preserve3(ctx, sym, str, irr); - res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "user"), + res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "user", -1), str = sexp_c_string(ctx, ms, -1), ((sexp_pairp(ir) || sexp_nullp(ir)) ? ir : (irr = sexp_list1(ctx, ir))), @@ -345,7 +345,7 @@ sexp sexp_type_exception (sexp ctx, const char *message, sexp obj) { sexp res; sexp_gc_var3(sym, str, irr); sexp_gc_preserve3(ctx, sym, str, irr); - res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "type"), + res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "type", -1), str = sexp_c_string(ctx, message, -1), irr = sexp_list1(ctx, obj), SEXP_FALSE, SEXP_FALSE); @@ -359,7 +359,7 @@ sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end) { msg = sexp_c_string(ctx, "bad index range", -1); res = sexp_list2(ctx, start, end); res = sexp_cons(ctx, obj, res); - res = sexp_make_exception(ctx, sexp_intern(ctx, "range"), msg, res, + res = sexp_make_exception(ctx, sexp_intern(ctx, "range", -1), msg, res, SEXP_FALSE, SEXP_FALSE); sexp_gc_release2(ctx); return res; @@ -432,7 +432,7 @@ static sexp sexp_read_error (sexp ctx, const char *msg, sexp ir, sexp port) { name = sexp_cons(ctx, name, sexp_make_fixnum(sexp_port_line(port))); str = sexp_c_string(ctx, msg, -1); irr = ((sexp_pairp(ir) || sexp_nullp(ir)) ? ir : sexp_list1(ctx, ir)); - res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "read"), + res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "read", -1), str, irr, SEXP_FALSE, name); sexp_gc_release4(ctx); return res; @@ -694,27 +694,31 @@ sexp sexp_string_concatenate (sexp ctx, sexp str_ls, sexp sep) { #if SEXP_USE_HASH_SYMS -static sexp_uint_t sexp_string_hash(const char *str, sexp_uint_t acc) { - while (*str) {acc *= FNV_PRIME; acc ^= *str++;} +static sexp_uint_t sexp_string_hash(const char *str, sexp_sint_t len, + sexp_uint_t acc) { + for ( ; len; len--) {acc *= FNV_PRIME; acc ^= *str++;} return acc; } #endif -sexp sexp_intern(sexp ctx, const char *str) { +sexp sexp_intern(sexp ctx, const char *str, sexp_sint_t len) { #if SEXP_USE_HUFF_SYMS struct sexp_huff_entry he; sexp_uint_t space=3, newbits; char c; #endif - sexp_uint_t len, res=FNV_OFFSET_BASIS, bucket; + sexp_uint_t res=FNV_OFFSET_BASIS, bucket, i=0; const char *p=str; - sexp ls; + sexp ls, tmp; sexp_gc_var1(sym); + if (len < 0) len = strlen(str); + #if SEXP_USE_HUFF_SYMS res = 0; - for ( ; (c=*p); p++) { + for ( ; i 127) goto normal_intern; he = huff_table[(unsigned char)c]; @@ -729,20 +733,20 @@ sexp sexp_intern(sexp ctx, const char *str) { normal_intern: #endif #if SEXP_USE_HASH_SYMS - bucket = (sexp_string_hash(p, res) % SEXP_SYMBOL_TABLE_SIZE); + bucket = (sexp_string_hash(p, len-i, res) % SEXP_SYMBOL_TABLE_SIZE); #else bucket = 0; #endif - len = strlen(str) + 1; /* include the trailing NULL in the comparison */ for (ls=sexp_context_symbols(ctx)[bucket]; sexp_pairp(ls); ls=sexp_cdr(ls)) - if (! strncmp(str, sexp_string_data(sexp_symbol_string(sexp_car(ls))), len)) + if ((sexp_string_length(tmp=sexp_symbol_string(sexp_car(ls))) == len) + && ! strncmp(str, sexp_string_data(tmp), len)) return sexp_car(ls); /* not found, make a new symbol */ sexp_gc_preserve1(ctx, sym); sym = sexp_alloc_type(ctx, symbol, SEXP_SYMBOL); if (sexp_exceptionp(sym)) return sym; - sexp_symbol_string(sym) = sexp_c_string(ctx, str, len-1); + sexp_symbol_string(sym) = sexp_c_string(ctx, str, len); sexp_push(ctx, sexp_context_symbols(ctx)[bucket], sym); sexp_gc_release1(ctx); return sym; @@ -751,7 +755,7 @@ sexp sexp_intern(sexp ctx, const char *str) { sexp sexp_string_to_symbol (sexp ctx, sexp str) { if (! sexp_stringp(str)) return sexp_type_exception(ctx, "string->symbol: not a string", str); - return sexp_intern(ctx, sexp_string_data(str)); + return sexp_intern(ctx, sexp_string_data(str), sexp_string_length(str)); } sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt) { @@ -1316,7 +1320,7 @@ sexp sexp_read_symbol(sexp ctx, sexp in, int init, int internp) { } buf[i] = '\0'; - res = (internp ? sexp_intern(ctx, buf) : sexp_c_string(ctx, buf, i)); + res = (internp ? sexp_intern(ctx, buf, i) : sexp_c_string(ctx, buf, i)); if (size != INIT_STRING_BUFFER_SIZE) free(buf); return res; } @@ -1624,11 +1628,11 @@ sexp sexp_read_raw (sexp ctx, sexp in) { sexp_push_char(ctx, c2, in); res = sexp_read_symbol(ctx, in, c1, 1); #if SEXP_USE_INFINITIES - if (res == sexp_intern(ctx, "+inf.0")) + if (res == sexp_intern(ctx, "+inf.0", -1)) res = sexp_make_flonum(ctx, 1.0/0.0); - else if (res == sexp_intern(ctx, "-inf.0")) + else if (res == sexp_intern(ctx, "-inf.0", -1)) res = sexp_make_flonum(ctx, -1.0/0.0); - else if (res == sexp_intern(ctx, "+nan.0")) + else if (res == sexp_intern(ctx, "+nan.0", -1)) res = sexp_make_flonum(ctx, 0.0/0.0); #endif } @@ -1662,11 +1666,11 @@ sexp sexp_read (sexp ctx, sexp in) { return res; } -sexp sexp_read_from_string(sexp ctx, const char *str) { +sexp sexp_read_from_string(sexp ctx, const char *str, sexp_sint_t len) { sexp res; sexp_gc_var2(s, in); sexp_gc_preserve2(ctx, s, in); - s = sexp_c_string(ctx, str, -1); + s = sexp_c_string(ctx, str, len); in = sexp_make_input_string_port(ctx, s); res = sexp_read(ctx, in); sexp_gc_release2(ctx); diff --git a/tools/genstubs.scm b/tools/genstubs.scm index 06bebb97..cdd8d235 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -1044,7 +1044,8 @@ (let ((pred (cadr x))) (cat " tmp = sexp_make_type_predicate(ctx, name, " "sexp_make_fixnum(" (type-id-name name) "));\n" - " name = sexp_intern(ctx, \"" pred "\");\n" + " name = sexp_intern(ctx, \"" pred "\", " + (string-length (x->string pred)) ");\n" " sexp_env_define(ctx, env, name, tmp);\n"))))))) (define (type-getter-name type name field) @@ -1183,7 +1184,8 @@ (define (write-const const) (let ((scheme-name (if (pair? (cadr const)) (caadr const) (cadr const))) (c-name (if (pair? (cadr const)) (cadadr const) (mangle (cadr const))))) - (cat " name = sexp_intern(ctx, \"" scheme-name "\");\n" + (cat " name = sexp_intern(ctx, \"" scheme-name "\", " + (string-length (x->string scheme-name)) ");\n" " sexp_env_define(ctx, env, name, tmp=" (lambda () (c->scheme-converter (car const) c-name)) ");\n")))